diff --git a/obsolete/clos/2.0/CLOS-BROWSER.TEDIT.Z b/obsolete/clos/2.0/CLOS-BROWSER.TEDIT.Z
deleted file mode 100644
index 337dd792..00000000
Binary files a/obsolete/clos/2.0/CLOS-BROWSER.TEDIT.Z and /dev/null differ
diff --git a/obsolete/clos/2.0/NEW-CLOS-BROWSER b/obsolete/clos/2.0/NEW-CLOS-BROWSER
deleted file mode 100644
index fbc4c912..00000000
--- a/obsolete/clos/2.0/NEW-CLOS-BROWSER
+++ /dev/null
@@ -1,1634 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE (LET ((*PACKAGE*)) (CLIN-PACKAGE "CLOS-BROWSER") (CLUSE-PACKAGE "CLOS") (
-CLFIND-PACKAGE "USER")) READTABLE "XCL" BASE 10)
-(IL:FILECREATED " 4-Dec-91 12:16:19" 
-IL:|{DSK}<usr>local>users>welch>lisp>clos>browser>NEW-CLOS-BROWSER.;22| 91732  
-
-      IL:|previous| IL:|date:| "19-Nov-91 14:14:15" 
-IL:|{DSK}<usr>local>users>welch>lisp>clos>browser>NEW-CLOS-BROWSER.;21|)
-
-
-; Copyright (c) 1991 by Venue.  All rights reserved.
-
-(IL:PRETTYCOMPRINT IL:NEW-CLOS-BROWSERCOMS)
-
-(IL:RPAQQ IL:NEW-CLOS-BROWSERCOMS 
-          (
-
-(IL:* IL:|;;;| "***************************************")
-
-           
-
-(IL:* IL:|;;;| "")
-
-           
-
-(IL:* IL:|;;;| "Print out a copyright notice when loading")
-
-           
-           (IL:* IL:|;;| "")
-
-           (IL:P (FORMAT T 
-                      "~&;CLOS-BROWSER Copyright (c) 1991 VENUE Corporation.  All rights reserved.~%"
-                        ))
-           
-
-(IL:* IL:|;;;| "LOAD DEPENDENT MODULES")
-
-           
-           (IL:* IL:|;;| "Note: before compiling clos-browser:")
-
-           
-           (IL:* IL:|;;| "    (load 'web-editor.dfasl)")
-
-           
-           (IL:* IL:|;;| "    (load 'clos-browser.dfasl)")
-
-           
-           (IL:* IL:|;;| "    (load 'clos-browser 'prop)")
-
-           
-           (IL:* IL:|;;| "")
-
-           
-
-(IL:* IL:|;;;| "PACKAGE STUFF ")
-
-           (IL:PROPS (IL:NEW-CLOS-BROWSER IL:MAKEFILE-ENVIRONMENT)
-                  (IL:NEW-CLOS-BROWSER IL:FILETYPE))
-           
-           (IL:* IL:|;;| "(IL:P IL:* USER::CLOS-BROWSER-PACKAGE-COMMANDS)")
-
-           
-           (IL:* IL:|;;| "")
-
-           
-
-(IL:* IL:|;;;| "SYSTEM PATCHES")
-
-           
-           (IL:* IL:|;;| "")
-
-           
-           (IL:* IL:|;;| "")
-
-           
-           (IL:* IL:|;;| "")
-
-           
-
-(IL:* IL:|;;;| "CLOS-ICON CLASS & INSTANCE INITIALIZATION")
-
-           (CLOS::CLASSES CLOS-BROWSER:CLOS-ICON)
-           (IL:VARIABLES CLOS-BROWSER:CLOS-ICON)
-           
-           (IL:* IL:|;;| "")
-
-           
-
-(IL:* IL:|;;;| "CLOS-BROWSER CLASS")
-
-           (IL:FUNCTIONS CLOS-BROWSER:BROWSE-CLASS CLOS-BROWSER::COLLECT-FAMILY 
-                  CLOS-BROWSER::MAKE-NODES CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN 
-                  CLOS-BROWSER::BROWSER-CONTAINS-P)
-           (CLOS::CLASSES CLOS-BROWSER::CLOS-BROWSER)
-           (CLOS::METHODS (CLOS-BROWSER::ADD-ROOT (CLOS-BROWSER::CLOS-BROWSER))
-                  (CLOS-BROWSER::ADD-ROOTS (CLOS-BROWSER::CLOS-BROWSER))
-                  (WEB:BOX-NODE (CLOS-BROWSER::CLOS-BROWSER))
-                  (WEB:BROWSE (CLOS-BROWSER::CLOS-BROWSER))
-                  (CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES (CLOS-BROWSER::CLOS-BROWSER))
-                  (WEB:ICON-TITLE (CLOS-BROWSER::CLOS-BROWSER))
-                  (WEB:INITIALIZE-EDITOR (CLOS-BROWSER::CLOS-BROWSER))
-                  (CLOS-BROWSER::NEW-ITEM (CLOS-BROWSER::CLOS-BROWSER))
-                  (WEB:RECOMPUTE (CLOS-BROWSER::CLOS-BROWSER))
-                  (CLOS-BROWSER::REAL-ADD-ROOT (CLOS-BROWSER::CLOS-BROWSER))
-                  (WEB:SHAPE-TO-HOLD (CLOS-BROWSER::CLOS-BROWSER))
-                                                             (IL:* IL:\; "multi-method")
-                  (CLOS-BROWSER::SUBCLASSES-OF NIL)
-                  (CLOS-BROWSER::CONTAINS-P (T CLOS-BROWSER::CLOS-BROWSER)))
-           
-           (IL:* IL:|;;| "")
-
-           
-
-(IL:* IL:|;;;| "CLOS-BROWSER-NODE CLASS")
-
-           (CLOS::CLASSES CLOS-BROWSER::CLOS-BROWSER-NODE)
-           (CLOS::METHODS (CLOS-BROWSER::OBJECT-NAME (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::OVERRIDE (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::CACHE (T CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::UNCACHE (CLOS-BROWSER::CLOS-BROWSER-NODE)))
-           (IL:VARS (CLOS-BROWSER::*METHOD-PROMPT-STRING* (CONCATENATE 'STRING 
-                                                                 "Left button to edit the method." 
-                                                                 "
-" "Middle button provides a menu of operations.")))
-           (IL:FUNCTIONS CLOS-BROWSER::EDIT CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS 
-                  CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS 
-                  CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU)
-           
-           (IL:* IL:|;;| "")
-
-           
-           (IL:* IL:|;;| "OPERATORS (via CLOS-BROWSER-NODE) ON CLOS::STANDARD-CLASS")
-
-           (CLOS::METHODS (CLOS-BROWSER:ADD-BROWSER-METHOD (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::BROWSE-SUBS (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::EDIT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::INSPECT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::MENU-METHODS (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::MAKE-WHENSELECTEDFN (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::DESCRIBE-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::DOCUMENTATION-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::PRINT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))
-                  (CLOS-BROWSER::SPECIALIZE-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)))
-           (IL:FUNCTIONS CLOS-BROWSER::COMPLETE-ADD-METHOD CLOS-BROWSER::COMPLETE-SPECIALIZE 
-                  CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE CLOS-BROWSER::THIS-CLASS-NODE-P 
-                  CLOS::CLASS-DIRECT-METHODS)
-           
-           (IL:* IL:|;;| "")
-
-           
-           (IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-CLASS (directly)")
-
-           (CLOS::METHODS (CLOS::COMPUTE-INHERITED-METHODS (STANDARD-CLASS))
-                  (CLOS-BROWSER::SPECIALIZE (STANDARD-CLASS))
-                  (CLOS-BROWSER::SUBCLASSES-OF (STANDARD-CLASS)))
-           
-           (IL:* IL:|;;| "")
-
-           
-           (IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-METHOD")
-
-           (CLOS::METHODS (CLOS-BROWSER::DELETE-METHOD (STANDARD-METHOD))
-                  (CLOS-BROWSER::COPY (STANDARD-METHOD STANDARD-CLASS))
-                  (CLOS-BROWSER::MOVE (STANDARD-METHOD STANDARD-CLASS))
-                                                             (IL:* IL:\; 
-                                                           "web:move is shadowed above")
-                  (CLOS-BROWSER::PRINT-DEFINITION (STANDARD-METHOD))
-                  (CLOS-BROWSER::DESCRIBE-METHOD (CLOS::METHOD))
-                  (CLOS-BROWSER::RENAME (STANDARD-METHOD))
-                  (CLOS-BROWSER::UPDATE-CACHED-MENUES (STANDARD-METHOD))
-                  (CLOS-BROWSER::WHO-OWNS (STANDARD-METHOD))
-                  
-                  (IL:* IL:|;;| 
-                "update-cached-menues must appear before add-method :after in the coms")
-
-                  (ADD-METHOD :AFTER (STANDARD-GENERIC-FUNCTION STANDARD-METHOD)))
-           (IL:FUNCTIONS CLOS-BROWSER::REPLACE-SPECIALIZERS)
-           
-           (IL:* IL:|;;| "")
-
-           
-
-(IL:* IL:|;;;| "SETUP RELEASE INFO")
-
-           (IL:VARS (CLOS-BROWSER::RELEASE-ID "0.02")
-                  (CLOS-BROWSER::SYSTEM-DATE (CAAR (IL:GETPROP 'IL:CLOS-BROWSER 'IL:FILEDATES))))
-           
-           (IL:* IL:|;;| "")
-
-           
-           (IL:* IL:|;;| "")
-
-           
-           (IL:* IL:|;;| "SETUP BACKGROUND MENU")
-
-           (IL:FUNCTIONS CLOS-BROWSER::IN-SELECT-PACKAGE CLOS-BROWSER::CLASSES-IN-PACKAGE)
-           (IL:P 
-                 (IL:* IL:|;;| "pushnew should eliminate this")
-
-                 (SETQ IL:|BackgroundMenuCommands| (REMOVE 'IL:|BrowseClass| 
-                                                          IL:|BackgroundMenuCommands| :KEY
-                                                          #'CAR))
-                 (PUSH '(IL:|BrowseClass| (CLOS-BROWSER:BROWSE-CLASS)
-                               "Bring up a class browser."
-                               (IL:SUBITEMS (IL:|all in a package| (CLOS-BROWSER:BROWSE-CLASS
-                                                                    (CLOS-BROWSER::CLASSES-IN-PACKAGE
-                                                                     (CLOS-BROWSER::IN-SELECT-PACKAGE
-                                                                      )))
-                                                   
-                               "Select a package and browse all the classes defined in that package."
-                                                   )))
-                       IL:|BackgroundMenuCommands|)
-                 (SETQ IL:|BackgroundMenu| NIL))))
-
-
-
-(IL:* IL:|;;;| "***************************************")
-
-
-
-
-(IL:* IL:|;;;| "")
-
-
-
-
-(IL:* IL:|;;;| "Print out a copyright notice when loading")
-
-
-
-
-(IL:* IL:|;;| "")
-
-
-(FORMAT T "~&;CLOS-BROWSER Copyright (c) 1991 VENUE Corporation.  All rights reserved.~%")
-
-
-
-(IL:* IL:|;;;| "LOAD DEPENDENT MODULES")
-
-
-
-
-(IL:* IL:|;;| "Note: before compiling clos-browser:")
-
-
-
-
-(IL:* IL:|;;| "    (load 'web-editor.dfasl)")
-
-
-
-
-(IL:* IL:|;;| "    (load 'clos-browser.dfasl)")
-
-
-
-
-(IL:* IL:|;;| "    (load 'clos-browser 'prop)")
-
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;;| "PACKAGE STUFF ")
-
-
-(IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:MAKEFILE-ENVIRONMENT (:PACKAGE (LET ((*PACKAGE*))
-                                                                            (IN-PACKAGE 
-                                                                                   "CLOS-BROWSER")
-                                                                            (USE-PACKAGE "CLOS")
-                                                                            (FIND-PACKAGE "USER"))
-                                                                    :READTABLE "XCL" :BASE 10))
-
-(IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:FILETYPE :COMPILE-FILE)
-
-
-
-(IL:* IL:|;;| "(IL:P IL:* USER::CLOS-BROWSER-PACKAGE-COMMANDS)")
-
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;;| "SYSTEM PATCHES")
-
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;;| "CLOS-ICON CLASS & INSTANCE INITIALIZATION")
-
-
-(DEFCLASS CLOS-BROWSER:CLOS-ICON (STANDARD-OBJECT)
-    ((CLOS-BROWSER::CLASS-BROWSERS :ALLOCATION :CLASS :INITFORM NIL)
-                                                             (IL:* IL:\; 
-                                                           "list of all open browsers")
-     (CLOS-BROWSER::DESTINATION-BROWSER :ALLOCATION :CLASS :INITFORM NIL)
-                                                             (IL:* IL:\; 
-                                                           "browser containing boxed node")
-     (CLOS-BROWSER::MENU-CACHE-SWITCH :ALLOCATION :CLASS :INITFORM :LAZY 
-
-            (IL:* IL:|;;| "valid values:")
-
-            (IL:* IL:|;;| ":none for never use cache")
-
-            (IL:* IL:|;;| ":lazy for invalidate cache at method create or remove time causing re-compute and cache at menu request time.")
-
-            (IL:* IL:|;;| 
-   ":eager (not implemented) for re-compute and cache menu whenever a method is created or removed")
-
-            )))
-
-(XCL:DEFGLOBALPARAMETER CLOS-BROWSER:CLOS-ICON (MAKE-INSTANCE 'CLOS-BROWSER:CLOS-ICON))
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;;| "CLOS-BROWSER CLASS")
-
-
-(DEFUN CLOS-BROWSER:BROWSE-CLASS (&OPTIONAL CLOS-BROWSER::CLASS-NAME-OR-LIST &KEY (
-                                                                              CLOS-BROWSER::DIRECTION
-                                                                                       :SUB)
-                                            (CLOS-BROWSER::WINDOW-OR-TITLE "CLOS-browser")
-                                            CLOS-BROWSER::GOOD-CLASSES POSITION)
-   (LET* ((CLOS-BROWSER::ROOT-CLASSES (WHEN CLOS-BROWSER::CLASS-NAME-OR-LIST
-                                          (IF (LISTP CLOS-BROWSER::CLASS-NAME-OR-LIST)
-                                              (MAPCAR #'FIND-CLASS CLOS-BROWSER::CLASS-NAME-OR-LIST)
-                                              (CONS (FIND-CLASS CLOS-BROWSER::CLASS-NAME-OR-LIST)))))
-          (CLOS-BROWSER::NODES (CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::COLLECT-FAMILY NIL 
-                                                                    CLOS-BROWSER::ROOT-CLASSES)))
-          (CLOS-BROWSER::CLOS-BROWSER (MAKE-INSTANCE 'CLOS-BROWSER::CLOS-BROWSER)))
-         (WEB:INITIALIZE-EDITOR CLOS-BROWSER::CLOS-BROWSER)
-         (SETF (SLOT-VALUE CLOS-BROWSER::CLOS-BROWSER 'CLOS-BROWSER::ROOT-CLASSES)
-               CLOS-BROWSER::ROOT-CLASSES)
-         (SETF (SLOT-VALUE CLOS-BROWSER::CLOS-BROWSER 'CLOS-BROWSER::TITLE)
-               CLOS-BROWSER::CLASS-NAME-OR-LIST)
-         (WEB:BROWSE CLOS-BROWSER::CLOS-BROWSER CLOS-BROWSER::NODES CLOS-BROWSER::WINDOW-OR-TITLE 
-                CLOS-BROWSER::GOOD-CLASSES POSITION)
-         (UNLESS CLOS-BROWSER::NODES (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::CLOS-BROWSER))
-         CLOS-BROWSER::CLOS-BROWSER))
-
-(DEFUN CLOS-BROWSER::COLLECT-FAMILY (CLOS-BROWSER::FAMILY CLOS-BROWSER::CLASS-LIST)
-   "gather all of the sub-classes of the class passed as family"
-
-   (IL:* IL:|;;| "for efficiency, to avoid gathering and filtering subclasses more than once, we assume family only contains classes whose family has already been gathered.")
-
-   (IF CLOS-BROWSER::CLASS-LIST
-       (LET ((CLOS-BROWSER::FIRST-CLASS (CAR CLOS-BROWSER::CLASS-LIST))
-             (REST (CDR CLOS-BROWSER::CLASS-LIST)))
-            (IF (MEMBER CLOS-BROWSER::FIRST-CLASS CLOS-BROWSER::FAMILY)
-                (PROGN 
-                       (IL:* IL:|;;| "skip gathering class-direct-subclasses ")
-
-                       (CLOS-BROWSER::COLLECT-FAMILY CLOS-BROWSER::FAMILY REST))
-                (PROGN (PUSH CLOS-BROWSER::FIRST-CLASS CLOS-BROWSER::FAMILY)
-                       (CLOS-BROWSER::COLLECT-FAMILY CLOS-BROWSER::FAMILY (APPEND REST
-                                                                                     (
-                                                                        CLOS::CLASS-DIRECT-SUBCLASSES
-                                                                                      
-                                                                            CLOS-BROWSER::FIRST-CLASS
-                                                                                      ))))))
-       CLOS-BROWSER::FAMILY))
-
-(DEFUN CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::CLASS-LIST)
-   (LET* ((CLOS-BROWSER::NODE-HASH (MAKE-HASH-TABLE))
-          (CLOS-BROWSER::NODE-LIST (MAP 'LIST #'(LAMBDA (CLOS-BROWSER::CLASS
-                                                         &AUX
-                                                         (CLOS-BROWSER::NODE (MAKE-INSTANCE
-                                                                              
-                                                                              '
-                                                                      CLOS-BROWSER::CLOS-BROWSER-NODE
-                                                                              )))
-                                                       (SETF (SLOT-VALUE CLOS-BROWSER::NODE
-                                                                    'CLOS-BROWSER::CLASS)
-                                                             CLOS-BROWSER::CLASS)
-                                                       (SETF (WEB:NODE-NAME CLOS-BROWSER::NODE)
-                                                             (CLASS-NAME CLOS-BROWSER::CLASS))
-                                                       (SETF (GETHASH CLOS-BROWSER::CLASS 
-                                                                    CLOS-BROWSER::NODE-HASH)
-                                                             CLOS-BROWSER::NODE)
-                                                       CLOS-BROWSER::NODE)
-                                        CLOS-BROWSER::CLASS-LIST)))
-         (DOLIST (CLOS-BROWSER::NODE CLOS-BROWSER::NODE-LIST)
-             (SETF (WEB:NODE-LINKS CLOS-BROWSER::NODE)
-                   (MAP 'LIST #'(LAMBDA (CLOS-BROWSER::SUB)
-                                       (GETHASH CLOS-BROWSER::SUB CLOS-BROWSER::NODE-HASH))
-                        (CLOS::CLASS-DIRECT-SUBCLASSES (SLOT-VALUE CLOS-BROWSER::NODE 
-                                                              'CLOS-BROWSER::CLASS)))))
-         CLOS-BROWSER::NODE-LIST))
-
-(DEFUN CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN (CLOS-BROWSER::WINDOW)
-   (LET ((CLOS-BROWSER::BROWSER (IL:WINDOWPROP CLOS-BROWSER::WINDOW 'WEB:WEB-EDITOR)))
-        (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS)
-              (REMOVE CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
-                                                   'CLOS-BROWSER::CLASS-BROWSERS)))
-        (WHEN (EQ CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
-                                               'CLOS-BROWSER::DESTINATION-BROWSER))
-            (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)
-                  NIL))))
-
-(DEFUN CLOS-BROWSER::BROWSER-CONTAINS-P (CLOS-BROWSER::CLASS CLOS-BROWSER::BROWSER)
-   "created because too slow to call contains-p method inside a tight loop"
-   (LET ((CLOS-BROWSER::NODE (CAR (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::BROWSER
-                                                                     'WEB::STARTING-LIST)
-                                         :TEST
-                                         #'CLOS-BROWSER::THIS-CLASS-NODE-P))))
-        (WHEN (AND CLOS-BROWSER::NODE (NOT (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE 
-                                                                              CLOS-BROWSER::BROWSER
-                                                                              'WEB::BAD-LIST)
-                                                  :TEST
-                                                  #'CLOS-BROWSER::THIS-CLASS-NODE-P)))
-              CLOS-BROWSER::NODE)))
-
-(DEFCLASS CLOS-BROWSER::CLOS-BROWSER (WEB:WEB-EDITOR)
-    ((CLOS-BROWSER::ROOT-CLASSES)
-     (WEB:TITLE-ITEMS :ALLOCATION :INSTANCE 
-
-            (IL:* IL:|;;| "Items for menu of selections in title of window")
-
-            :INITFORM
-            '(("Recompute" WEB:RECOMPUTE "Recompute lattice from starting objects"
-                     (IL:SUBITEMS ("Recompute" WEB:RECOMPUTE 
-                                         "Recompute lattice from starting objects")
-                            ("Recompute labels" WEB:RECOMPUTE-LABELS "Recomputes the labels")
-                            ("Recompute in place" WEB:RECOMPUTE-IN-PLACE 
-                                   "Recompute keeping current view in window")
-                            ("Clear caches" CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES 
-                                   "Clear cached menues of methods.")))
-              ("Browser looks" NIL "" (IL:SUBITEMS ("Shape to hold" WEB:SHAPE-TO-HOLD 
-                                               "Make window large or small enough to just hold graph"
-                                                          )
-                                             ("Change font size" WEB:CHANGE-FONT-SIZE 
-                                                    "Choose a new size Font")
-                                             ("Change format" WEB:CHANGE-FORMAT 
-                                                    "Change format between lattice and tree")))
-              ("Add root " CLOS-BROWSER::ADD-ROOT "Add named item to startingList for browser."
-                     (IL:SUBITEMS ("all in a package" CLOS-BROWSER::ADD-ROOTS 
-                                         "Add all the classes in a package to this browser.")))
-
-              (IL:* IL:|;;| 
-         "(\"Unhide class\" remove-from-bad-list \"Restore item previously deleted from browser\")")
-
-              ))
-     (WEB:LEFT-BUTTON-ITEMS :ALLOCATION :CLASS 
-
-            (IL:* IL:|;;| "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see local-commands")
-
-            :INITFORM
-            'WEB:BOX-NODE)
-     (WEB:MIDDLE-BUTTON-ITEMS :ALLOCATION :INSTANCE 
-
-            (IL:* IL:|;;| "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see local-commands")
-
-            :INITFORM
-            '(("Edit" CLOS-BROWSER::EDIT-CLASS "Edit the class." (IL:SUBITEMS ("Edit" 
-                                                                             CLOS-BROWSER::EDIT-CLASS
-                                                                                     
-                                                                                    "Edit the class."
-                                                                                     )
-                                                                        ("Inspect" 
-                                                                          CLOS-BROWSER::INSPECT-CLASS
-                                                                               
-                                                                "Bring up an inspector on the class."
-                                                                               )))
-              ("Add method" CLOS-BROWSER:ADD-BROWSER-METHOD "Add a method to the class.")
-              ("Browse" CLOS-BROWSER::BROWSE-SUBS "Bring up a browser on this class."
-                     (WHEN NIL                               (IL:* IL:\; 
-                                                           "superclasses not implemented")
-                         (IL:SUBITEMS ("sub classes" CLOS-BROWSER::BROWSE-SUBS 
-                                             "Bring up a browser on this class.")
-                                ("super classes" CLOS-BROWSER::BROWSE-SUPERS "Not Implemented"))))
-              ("Print" CLOS-BROWSER::PRINT-CLASS "Print the form defining the class."
-                     (IL:SUBITEMS ("Print" CLOS-BROWSER::PRINT-CLASS 
-                                         "Print the form defining the class.")
-                            ("Describe" CLOS-BROWSER::DESCRIBE-CLASS 
-                                   "Print a description of the class.")
-                            ("Documentation" CLOS-BROWSER::DOCUMENTATION-CLASS 
-                                   "Display the documentation for the class.")))
-              ("Specialize" CLOS-BROWSER::SPECIALIZE-CLASS "Create a new sub-class of this class.")
-              ("------" CLOS-BROWSER::EDIT-CLASS 
-   "Above this line operates on the class.
-Below this line operates on individual slots and methods.")
-              ("slots" CLOS-BROWSER::EDIT-CLASS "Edit the defclass definition.")
-              ("methods" (CLOS-BROWSER::MENU-METHODS)
-                     "Build a menu of methods local to this class."
-                     (IL:SUBITEMS ("local" (CLOS-BROWSER::MENU-METHODS)
-                                         "Show a menu of methods specialized on this class.."
-                                         (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS)
-                                                             "Do not recompute the menu of methods")
-                                                ("Recompute menu" (CLOS-BROWSER::MENU-METHODS NIL NIL
-                                                                         NIL T)
-                                                       "Recompute the menu of methods")))
-                            ("inherited" (CLOS-BROWSER::MENU-METHODS :INHERITED)
-                                   "Show only methods inherited by this class."
-                                   (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS 
-                                                                          :INHERITED)
-                                                       "Do not recompute the menu of methods")
-                                          ("Recompute menu" (CLOS-BROWSER::MENU-METHODS :INHERITED 
-                                                                   NIL NIL T)
-                                                 "Recompute the menu of methods")))
-                            ("all" (CLOS-BROWSER::MENU-METHODS :ALL)
-                                   "Show all methods understood by this class."
-                                   (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS :ALL)
-                                                       "Do not recompute the menu of methods")
-                                          ("Recompute menu" (CLOS-BROWSER::MENU-METHODS :ALL NIL NIL
-                                                                   T)
-                                                 "Recompute the menu of methods")))))))
-     (CLOS-BROWSER::TITLE :INITFORM "CLOS Browser"           (IL:* IL:\; 
-                                                           "Title passed to GRAPHER package"))))
-
-(DEFMETHOD CLOS-BROWSER::ADD-ROOT ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER)
-                                       &OPTIONAL
-                                       (CLOS-BROWSER::NEW-ITEM (CLOS-BROWSER::NEW-ITEM 
-                                                                      CLOS-BROWSER::BROWSER)))
-   "Add a named item to the starting list of the browser "
-   (IF (CLOS-BROWSER::REAL-ADD-ROOT CLOS-BROWSER::BROWSER CLOS-BROWSER::NEW-ITEM)
-       (WEB:RECOMPUTE CLOS-BROWSER::BROWSER)
-
-       (IL:* IL:|;;| "otherwise warn the user")
-
-       (WEB:PROMPT-PRINT CLOS-BROWSER::BROWSER (FORMAT NIL "~A not added to browser." 
-                                                      CLOS-BROWSER::NEW-ITEM))))
-
-(DEFMETHOD CLOS-BROWSER::ADD-ROOTS ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER)
-                                        &OPTIONAL
-                                        (CLOS-BROWSER::NEW-ITEMS (CLOS-BROWSER::CLASSES-IN-PACKAGE
-                                                                  (CLOS-BROWSER::IN-SELECT-PACKAGE
-                                                                   ))))
-   "Add all classes in a package to the starting list of the browser"
-   (DOLIST (CLOS-BROWSER::CLASS CLOS-BROWSER::NEW-ITEMS)
-       (UNLESS (CLOS-BROWSER::REAL-ADD-ROOT CLOS-BROWSER::BROWSER CLOS-BROWSER::CLASS)
-           (WEB:PROMPT-PRINT CLOS-BROWSER::BROWSER (FORMAT NIL "~A not added to browser." 
-                                                          CLOS-BROWSER::CLASS))))
-   (WEB:RECOMPUTE CLOS-BROWSER::BROWSER))
-
-(DEFMETHOD WEB:BOX-NODE ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER)
-                             CLOS-BROWSER::OBJECT &OPTIONAL CLOS-BROWSER::KEEP-PREVIOUS-BOX)
-   (CALL-NEXT-METHOD)
-   (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)
-         CLOS-BROWSER::BROWSER))
-
-(DEFMETHOD WEB:BROWSE ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER)
-                           &OPTIONAL CLOS-BROWSER::BROWSE-LIST CLOS-BROWSER::WINDOW-OR-TITLE 
-                           CLOS-BROWSER::GOOD-LIST POSITION)
-   (LET ((CLOS-BROWSER::BROWSER (CALL-NEXT-METHOD)))
-        (PUSHNEW CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
-                                              'CLOS-BROWSER::CLASS-BROWSERS))))
-
-(DEFMETHOD CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER
-                                                              ))
-   (DOLIST (CLOS-BROWSER::NODE (SLOT-VALUE CLOS-BROWSER::SELF 'WEB::STARTING-LIST 
-                                                             (IL:* IL:\; 
-                                            "starting-list is really all the nodes in the browser.")
-                                      ))
-       (SETF (SLOT-VALUE CLOS-BROWSER::NODE WEB::MENU-CACHE)
-             NIL)))
-
-(DEFMETHOD WEB:ICON-TITLE ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER))
-   (WEB:NODE-NAME (CAR (LAST (SLOT-VALUE CLOS-BROWSER::SELF `WEB::STARTING-LIST)))))
-
-(DEFMETHOD WEB:INITIALIZE-EDITOR ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER))
-   "initialize and setup closefn"
-   (CALL-NEXT-METHOD)
-   (PUSHNEW CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS))
-   (LET ((CLOS-BROWSER::WINDOW (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::WINDOW)))
-        (IL:WINDOWADDPROP CLOS-BROWSER::WINDOW 'IL:CLOSEFN 'CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN T))
-   CLOS-BROWSER::BROWSER)
-
-(DEFMETHOD CLOS-BROWSER::NEW-ITEM ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER)
-                                       &OPTIONAL CLOS-BROWSER::NEW-ITEM)
-   (UNLESS CLOS-BROWSER::NEW-ITEM
-       (SETQ CLOS-BROWSER::NEW-ITEM (WEB:PROMPT-READ CLOS-BROWSER::SELF "Class"))))
-
-(DEFMETHOD WEB:RECOMPUTE ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER)
-                              &OPTIONAL CLOS-BROWSER::DONT-RESHAPE-FLG)
-
-   (IL:* IL:|;;| "this should be moved to a more intelligent recompute-nodes function that does not have to re-build every single node.")
-
-   (SETF (SLOT-VALUE CLOS-BROWSER::SELF 'WEB::STARTING-LIST)
-         (CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::COLLECT-FAMILY
-                                        NIL
-                                        (IL:FOR CLOS-BROWSER::EACH
-                                           IL:IN (REVERSE 
-                                                             (IL:* IL:\; 
-                                                           "so they come out in the original order")
-                                                            (SLOT-VALUE CLOS-BROWSER::SELF
-                                                                   'WEB::STARTING-LIST)) IL:WHEN
-                                                                                         
-                                                                                   CLOS-BROWSER::EACH
-                                           IL:COLLECT (SLOT-VALUE CLOS-BROWSER::EACH 
-                                                                 `CLOS-BROWSER::CLASS)))))
-   (CALL-NEXT-METHOD)
-   (WHEN (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)
-
-       (IL:* IL:|;;| "Node has been invalidated, so get rid of this pointer to it. ")
-
-       (SETF (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)
-                    'WEB:BOXED-NODE)
-             NIL)
-       (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER)
-             NIL)))
-
-(DEFMETHOD CLOS-BROWSER::REAL-ADD-ROOT ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER)
-                                            CLOS-BROWSER::CLASS)
-   "Add a class to the starting list of the browser"
-   (WHEN CLOS-BROWSER::CLASS
-       (LET* ((CLOS-BROWSER::CLASS (IF (TYPEP CLOS-BROWSER::CLASS 'STANDARD-CLASS)
-                                       CLOS-BROWSER::CLASS
-                                       (FIND-CLASS CLOS-BROWSER::CLASS)))
-              (CLOS-BROWSER::NEW-NODE (CAR (CLOS-BROWSER::MAKE-NODES (LIST CLOS-BROWSER::CLASS)))
-                     ))
-             (IF CLOS-BROWSER::NEW-NODE
-                 (PROGN (PUSHNEW CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER
-                                                               'WEB::STARTING-LIST))
-                        (IF (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::GOOD-LIST)
-                            (PUSHNEW CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER
-                                                                   'WEB::GOOD-LIST)))
-                        (SETF (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::BAD-LIST)
-                              (IL:DREMOVE CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER
-                                                                        'WEB::BAD-LIST)))
-                        CLOS-BROWSER::BROWSER)
-
-                 (IL:* IL:|;;| "otherwise return nil")
-
-                 NIL))))
-
-(DEFMETHOD WEB:SHAPE-TO-HOLD ((WEB::SELF CLOS-BROWSER::CLOS-BROWSER))
-   "give a larger width for empty browsers so add-node will have room"
-   (LET* ((WEB::WINDOW (SLOT-VALUE WEB::SELF 'WEB::WINDOW))
-          (WEB::NODES (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP WEB::WINDOW
-                                                                       'IL:GRAPH))))
-         (IF WEB::NODES
-             (CALL-NEXT-METHOD)
-             (LET ((WEB::REGION (IL:WINDOWPROP WEB::WINDOW 'IL:REGION))
-                   (WEB::MIN-HEIGHT (IL:FONTHEIGHT (IL:DSPFONT NIL WEB::WINDOW)))
-                   (WEB::MIN-WIDTH (MAX 250 (IL:IPLUS 5 (IL:STRINGWIDTH (SLOT-VALUE WEB::SELF
-                                                                               'WEB::TITLE)
-                                                               (IL:DSPFONT NIL 
-                                                                      IL:|WindowTitleDisplayStream|))
-                                                   ))))
-                  (WEB::SET-REGION WEB::SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of|
-                                                                                      WEB::REGION)
-                                                    (IL:|fetch| IL:BOTTOM IL:|of| WEB::REGION
-                                                           )
-                                                    WEB::MIN-WIDTH WEB::MIN-HEIGHT))))))
-
-(DEFMETHOD CLOS-BROWSER::SUBCLASSES-OF ((CLOS-BROWSER::CLASS T))
-   (APPEND (LIST CLOS-BROWSER::CLASS)
-          (IL:FOR CLOS-BROWSER::SUBCLASS IL:IN (SLOT-VALUE CLOS-BROWSER::CLASS 
-                                                              'CLOS::DIRECT-SUBCLASSES)
-             IL:JOIN (IF (SLOT-VALUE CLOS-BROWSER::SUBCLASS 'CLOS::DIRECT-SUBCLASSES)
-                             (CLOS-BROWSER::SUBCLASSES-OF CLOS-BROWSER::SUBCLASS)
-                             (LIST CLOS-BROWSER::SUBCLASS)))))
-
-(DEFMETHOD CLOS-BROWSER::CONTAINS-P ((CLOS-BROWSER::CLASS T)
-                                         (CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER))
-   (LET ((CLOS-BROWSER::NODE (CAR (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::BROWSER
-                                                                     'WEB::STARTING-LIST)
-                                         :TEST
-                                         #'CLOS-BROWSER::THIS-CLASS-NODE-P))))
-        (WHEN (AND CLOS-BROWSER::NODE (NOT (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE 
-                                                                              CLOS-BROWSER::BROWSER
-                                                                              'WEB::BAD-LIST)
-                                                  :TEST
-                                                  #'CLOS-BROWSER::THIS-CLASS-NODE-P)))
-              CLOS-BROWSER::NODE)))
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;;| "CLOS-BROWSER-NODE CLASS")
-
-
-(DEFCLASS CLOS-BROWSER::CLOS-BROWSER-NODE (WEB:WEB-NODE)
-    ((CLOS-BROWSER::CLASS                                    (IL:* IL:\; 
-                                                           "The class represented by this node")
-            )
-     (CLOS-BROWSER::MENU-CACHE :INITFORM NIL)                (IL:* IL:\; 
-  "Menus of methods and slots.  See clos-icon for the switch that controls when this gets updated.")
-     (CLOS-BROWSER::LARGE-MENU-SIZE :ALLOCATION :CLASS :INITFORM 22)
-     (CLOS-BROWSER::LARGE-MENU-FONT :ALLOCATION :INSTANCE :INITFORM (IL:FONTCREATE
-                                                                     `(IL:HELVETICA 8)))
-     (CLOS-BROWSER::LOCAL-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM
-            '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition."
-                     (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method")))
-              ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition."
-                     (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.")
-                            ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.")
-                            ("Documentation" 'DOCUMENTATION "Print this method's documentation.")))
-              ("Delete" 'CLOS-BROWSER::DELETE-METHOD "Remove this method.")
-              ("Copy" 'CLOS-BROWSER::COPY "Copy this method to boxed class.")
-              ("Move" 'CLOS-BROWSER::MOVE "Move this method to boxed class.")
-              ("Rename" 'CLOS-BROWSER::RENAME 
-                     "Change the name of this method to new name you specify")
-              ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.")
-              ("Trace" 'CLOS::TRACE-METHOD "Trace this method.")
-              ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.")
-              ("Who owns" 'CLOS-BROWSER::WHO-OWNS 
-                     "Show the classes on which this method is specialized.")))
-     (CLOS-BROWSER::INHERITED-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM
-            '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition."
-                     (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method")))
-              ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition."
-                     (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.")
-                            ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.")
-                            ("Documentation" 'DOCUMENTATION "Print this method's documentation.")))
-              ("Override" 'CLOS-BROWSER::OVERRIDE "Create a local method with this name.")
-              ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.")
-              ("Trace" 'CLOS::TRACE-METHOD "Trace this method.")
-              ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.")
-              ("Who owns" 'CLOS-BROWSER::WHO-OWNS 
-                     "Show the classes on which this method is specialized.")))
-     (CLOS-BROWSER::ALL-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM
-            '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition."
-                     (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method")))
-              ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition."
-                     (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.")
-                            ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.")
-                            ("Documentation" 'DOCUMENTATION "Print this method's documentation.")))
-              ("Delete" 'DELETE "Remove this method.")
-              ("Copy" 'CLOS-BROWSER::COPY "Copy this method to boxed class.")
-              ("Move" 'CLOS-BROWSER::MOVE "Move this method to boxed class.")
-              ("Rename" 'CLOS-BROWSER::RENAME 
-                     "Change the name of this method to new name you specify")
-              ("Override" 'CLOS-BROWSER::OVERRIDE "Create a local method with this name.")
-              ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.")
-              ("Trace" 'CLOS::TRACE-METHOD "Trace this method.")
-              ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.")
-              ("Who owns" 'CLOS-BROWSER::WHO-OWNS 
-                     "Show the classes on which this method is specialized.")))))
-
-(DEFMETHOD CLOS-BROWSER::OBJECT-NAME ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE))
-   (WEB:NODE-NAME CLOS-BROWSER::SELF))
-
-(DEFMETHOD CLOS-BROWSER::OVERRIDE ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)
-                                       CLOS-BROWSER::METHOD)
-   "Create a method specialized on the class."
-   (ADD-METHOD CLOS-BROWSER::NODE NIL (SLOT-VALUE (CLOS::METHOD-GENERIC-FUNCTION CLOS-BROWSER::METHOD
-                                                         )
-                                             'CLOS::NAME)))
-
-(DEFMETHOD CLOS-BROWSER::CACHE (CLOS-BROWSER::MENU (CLOS-BROWSER::NODE 
-                                                              CLOS-BROWSER::CLOS-BROWSER-NODE)
-                                          &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL)
-   (LET ((CLOS-BROWSER::MENU-TYPE (CASE CLOS-BROWSER::INHERITED-OR-ALL
-                                      ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU)
-                                      (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU)
-                                      (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU))))
-        (IF (NOT (ASSOC CLOS-BROWSER::MENU-TYPE (SLOT-VALUE CLOS-BROWSER::NODE 
-                                                       'CLOS-BROWSER::MENU-CACHE)))
-
-            (IL:* IL:|;;| "then initialize alist")
-
-            (SETF (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE)
-                  (ACONS CLOS-BROWSER::MENU-TYPE CLOS-BROWSER::MENU (SLOT-VALUE CLOS-BROWSER::NODE
-                                                                           'CLOS-BROWSER::MENU-CACHE)
-                         ))
-
-            (IL:* IL:|;;| "otherwise replace what is already there")
-
-            (RPLACD (ASSOC CLOS-BROWSER::MENU-TYPE (SLOT-VALUE CLOS-BROWSER::NODE 
-                                                          'CLOS-BROWSER::MENU-CACHE))
-                   CLOS-BROWSER::MENU))))
-
-(DEFMETHOD CLOS-BROWSER::UNCACHE ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)
-                                      &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL)
-   (RPLACD (ASSOC (CASE CLOS-BROWSER::INHERITED-OR-ALL
-                      ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU)
-                      (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU)
-                      (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU))
-                  (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE))
-          NIL))
-
-(IL:RPAQ CLOS-BROWSER::*METHOD-PROMPT-STRING* (CONCATENATE 'STRING 
-                                                         "Left button to edit the method." "
-" "Middle button provides a menu of operations."))
-
-(DEFUN CLOS-BROWSER::EDIT (CLOS-BROWSER::METHOD)
-   (LET ((*PACKAGE* (SYMBOL-PACKAGE (CLOS::GENERIC-FUNCTION-NAME (CLOS::METHOD-GENERIC-FUNCTION
-                                                                  CLOS-BROWSER::METHOD)))))
-        (ED (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD)
-            ':DONTWAIT)))
-
-(DEFUN CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS (CLOS::METHODS CLOS-BROWSER::CLASS &OPTIONAL 
-                                                       CLOS-BROWSER::INHERITED-OR-ALL)
-   "gather method-list into menu items list"
-   (LET ((CLOS-BROWSER::METHOD-MENU-ITEMS (CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS 
-                                                 CLOS::METHODS CLOS-BROWSER::INHERITED-OR-ALL))
-         (CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS))
-        (LET ((CLOS-BROWSER::PREVIOUS.ITEM NIL)
-              (CLOS-BROWSER::THIS.POSITION 0)
-              CLOS-BROWSER::GF-NAME)
-             (DOLIST (CLOS-BROWSER::THIS.ITEM CLOS-BROWSER::METHOD-MENU-ITEMS)
-                 (SETQ CLOS-BROWSER::GF-NAME (CAR CLOS-BROWSER::THIS.ITEM))
-                 (INCF CLOS-BROWSER::THIS.POSITION)
-                 (IF (NOT (AND CLOS-BROWSER::PREVIOUS.ITEM (IF (NOT (FIRST CLOS-BROWSER::THIS.ITEM))
-
-                                                               (IL:* IL:|;;| 
-                                                 "then look for different gf objects with nil name")
-
-                                                               (EQ (CLOS::METHOD-GENERIC-FUNCTION
-                                                                    (SECOND 
-                                                                          CLOS-BROWSER::PREVIOUS.ITEM
-                                                                           ))
-                                                                   (CLOS::METHOD-GENERIC-FUNCTION
-                                                                    (SECOND CLOS-BROWSER::THIS.ITEM))
-                                                                   )
-
-                                                               (IL:* IL:|;;| 
-                                           "otherwise use slightly more efficient test for same gf")
-
-                                                               (EQ (FIRST CLOS-BROWSER::PREVIOUS.ITEM
-                                                                          )
-                                                                   (FIRST CLOS-BROWSER::THIS.ITEM))))
-                          )
-
-                     (IL:* IL:|;;| "then go on to the next")
-
-                     (SETQ CLOS-BROWSER::PREVIOUS.ITEM CLOS-BROWSER::THIS.ITEM)
-
-                     (IL:* IL:|;;| "otherwise we have multi-methods")
-
-                     (PROGN 
-                            (IL:* IL:|;;| "build a sub-menu of all the multi-methods")
-
-                            (IF (NOT (FOURTH CLOS-BROWSER::PREVIOUS.ITEM))
-
-                                (IL:* IL:|;;| "then create the sub-menu")
-
-                                (NCONC CLOS-BROWSER::PREVIOUS.ITEM (LIST (LIST 'IL:SUBITEMS
-                                                                               (
-                                                           CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU
-                                                                                (SECOND 
-                                                                          CLOS-BROWSER::PREVIOUS.ITEM
-                                                                                       )
-                                                                                CLOS-BROWSER::CLASS)
-                                                                               (
-                                                           CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU
-                                                                                (SECOND 
-                                                                              CLOS-BROWSER::THIS.ITEM
-                                                                                       )
-                                                                                CLOS-BROWSER::CLASS))
-                                                                         ))
-
-                                (IL:* IL:|;;| "otherwise add another item to the sub-menu")
-
-                                (NCONC (FOURTH CLOS-BROWSER::PREVIOUS.ITEM)
-                                       (LIST (CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU
-                                              (SECOND CLOS-BROWSER::THIS.ITEM)
-                                              CLOS-BROWSER::CLASS))))
-
-                            (IL:* IL:|;;| 
-                          "collect the position of the extra multi-method menu item")
-
-                            (PUSH CLOS-BROWSER::THIS.POSITION CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS
-                                  )))))
-
-        (IL:* IL:|;;| "remove extra multi-method menu items last first.")
-
-        (DOLIST (CLOS-BROWSER::EACH.POSITION CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS)
-            (SETQ CLOS-BROWSER::METHOD-MENU-ITEMS (DELETE-IF #'XCL:TRUE 
-                                                         CLOS-BROWSER::METHOD-MENU-ITEMS :START
-                                                         (- CLOS-BROWSER::EACH.POSITION 1)
-                                                         :END CLOS-BROWSER::EACH.POSITION)))
-
-        (IL:* IL:|;;| "prepend the Add method item")
-
-        (APPEND '(("Add method" NIL 
-                         "Bring up an editor containing a template for a new method on this class."))
-               CLOS-BROWSER::METHOD-MENU-ITEMS)))
-
-(DEFUN CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS (CLOS::METHODS &OPTIONAL 
-                                                                 CLOS-BROWSER::INHERITED-OR-ALL)
-   "gather local-methods into menu items list"
-   (DECLARE (SPECIAL CLOS-BROWSER::*METHOD-PROMPT-STRING*))
-   (SORT (IL:FOR CLOS-BROWSER::EACH.METHOD IL:IN CLOS::METHODS IL:BIND 
-                                                                            CLOS-BROWSER::METHOD-NAME
-            IL:UNLESS (AND (NOT (EQL CLOS-BROWSER::INHERITED-OR-ALL :ALL))
-                               (CLOS::*TYPEP CLOS-BROWSER::EACH.METHOD 
-                                      'CLOS::STANDARD-ACCESSOR-METHOD)) 
-
-                  (IL:* IL:|;;| "weed out auto-generated slot access methods ")
- IL:|eachtime| (SETQ CLOS-BROWSER::METHOD-NAME (CAR (CLOS::FULL-METHOD-NAME 
-                                                               CLOS-BROWSER::EACH.METHOD NIL)))
-            IL:|collect| (LIST CLOS-BROWSER::METHOD-NAME CLOS-BROWSER::EACH.METHOD 
-                                   CLOS-BROWSER::*METHOD-PROMPT-STRING*))
-         #'IL:ALPHORDER :KEY #'CAR))
-
-(DEFUN CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU (CLOS-BROWSER::METHOD CLOS-BROWSER::CLASS)
-   "make a menu item to distinguish methods on the same gf"
-   (LET (CLOS-BROWSER::SUB-ITEM-NAME)
-        (DECLARE (SPECIAL CLOS-BROWSER::*METHOD-PROMPT-STRING*))
-
-        (IL:* IL:|;;| "first put out the qualifiers if any")
-
-        (DOLIST (CLOS-BROWSER::QUALIFIER (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::SPECIALIZERS))
-            (SETQ CLOS-BROWSER::SUB-ITEM-NAME (CONCATENATE 'STRING CLOS-BROWSER::SUB-ITEM-NAME
-                                                     (WHEN CLOS-BROWSER::SUB-ITEM-NAME " ")
-                                                     (PRIN1-TO-STRING CLOS-BROWSER::QUALIFIER))))
-
-        (IL:* IL:|;;| "then do the specializers ")
-
-        (IL:* IL:|;;| "(DOLIST (TYPE-SPECIFIER (SLOT-VALUE METHOD 'CLOS::TYPE-SPECIFIERS)) (SETQ SUB-ITEM-NAME (CONCATENATE 'STRING SUB-ITEM-NAME (WHEN SUB-ITEM-NAME \" \") (IF (EQ CLASS TYPE-SPECIFIER) ;; then lets just do a plus sign \"+\" ;; else print the name (PRIN1-TO-STRING ;; test until class-name works properly (IF (TYPEP TYPE-SPECIFIER 'STANDARD-CLASS) (CLASS-NAME TYPE-SPECIFIER) TYPE-SPECIFIER))))))")
-
-        (LIST CLOS-BROWSER::SUB-ITEM-NAME CLOS-BROWSER::METHOD CLOS-BROWSER::*METHOD-PROMPT-STRING*)))
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;| "OPERATORS (via CLOS-BROWSER-NODE) ON CLOS::STANDARD-CLASS")
-
-
-(DEFMETHOD CLOS-BROWSER:ADD-BROWSER-METHOD ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)
-                                                &OPTIONAL CLOS-BROWSER::FORM 
-                                                CLOS-BROWSER::METHOD-NAME)
-   "bring up sedit on a template to add a method to this class"
-   (DECLARE (SPECIAL SEDIT::BASIC-GAP SEDIT::BODY-GAP SEDIT::ARGS-GAP))
-   (LET* ((CLASS-NAME (CLASS-NAME (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)))
-          CLOS-BROWSER::CONTEXT
-          (CLOS-BROWSER::NAME (FORMAT NIL "New method on ~A" CLASS-NAME))
-          (*PACKAGE* (SYMBOL-PACKAGE CLASS-NAME)))
-         (UNLESS CLOS-BROWSER::FORM
-             (SETQ CLOS-BROWSER::FORM (LIST 'DEFMETHOD (OR CLOS-BROWSER::METHOD-NAME SEDIT::BASIC-GAP
-                                                           )
-                                            (LIST (LIST (INTERN "SELF")
-                                                        CLASS-NAME)
-                                                  SEDIT::ARGS-GAP)
-                                            SEDIT::BODY-GAP)))
-         (SEDIT:SEDIT CLOS-BROWSER::FORM (LIST :NAME CLOS-BROWSER::NAME :COMPLETION-FN 
-                                               #'CLOS-BROWSER::COMPLETE-ADD-METHOD)
-                :DONTWAIT)))
-
-(DEFMETHOD CLOS-BROWSER::BROWSE-SUBS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE))
-   (CLOS-BROWSER:BROWSE-CLASS (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)
-                                         'CLOS::NAME)))
-
-(DEFMETHOD CLOS-BROWSER::EDIT-CLASS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE))
-   (LET* ((CLOS-BROWSER::CLASS (CLASS-NAME (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)))
-          (*PACKAGE* (SYMBOL-PACKAGE CLOS-BROWSER::CLASS)))
-         (ED CLOS-BROWSER::CLASS '(CLOS-BROWSER::CLASSES :DONTWAIT))))
-
-(DEFMETHOD CLOS-BROWSER::INSPECT-CLASS ((CLOS::OBJECT CLOS-BROWSER::CLOS-BROWSER-NODE))
-   (INSPECT (SLOT-VALUE CLOS::OBJECT 'CLOS-BROWSER::CLASS)))
-
-(DEFMETHOD CLOS-BROWSER::MENU-METHODS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)
-                                           &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL 
-                                           CLOS-BROWSER::ITEMS CLOS-BROWSER::FIX-FLAG 
-                                           CLOS-BROWSER::RECOMPUTE-FLAG)
-   "pops up a menu of the methods for the class representing the node."
-
-   (IL:* IL:|;;| "If INHERITED-OR-ALL is NIL or :local only local methods are menued.")
-
-   (IL:* IL:|;;| "If INHERITED-OR-ALL is :inherited only inherited methods are menued.")
-
-   (IL:* IL:|;;| "If INHERITED-OR-ALL is :all all methods are menued.")
-
-   (IL:* IL:|;;| "If items are present, the list of methods is not re-generated.")
-
-   (IL:* IL:|;;| 
- "If the fix-flag is t, the user is asked to position the menu and no \"Fix menu\" item appears.")
-
-   (IL:* IL:|;;| "The whenselectedfn can call this again to generate a fixed menu.")
-
-   (LET* ((CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))
-          (*PACKAGE* (SYMBOL-PACKAGE (SLOT-VALUE CLOS-BROWSER::CLASS 'CLOS::NAME)))
-          (CLOS-BROWSER::MENU (UNLESS (OR CLOS-BROWSER::RECOMPUTE-FLAG (EQ (SLOT-VALUE 
-                                                                               CLOS-BROWSER:CLOS-ICON
-                                                                                  
-                                                                                  '
-                                                                      CLOS-BROWSER::MENU-CACHE-SWITCH
-                                                                                  )
-                                                                           :NONE))
-                                  (REST                      (IL:* IL:\; "use the cached menu")
-                                        (ASSOC (CASE CLOS-BROWSER::INHERITED-OR-ALL
-                                                   ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU)
-                                                   (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU)
-                                                   (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU))
-                                               (SLOT-VALUE CLOS-BROWSER::NODE 
-                                                      'CLOS-BROWSER::MENU-CACHE))))))
-
-         (IL:* IL:|;;| "unless it was cached, make the menu")
-
-         (UNLESS (AND CLOS-BROWSER::MENU (IL:TYPE? IL:MENU CLOS-BROWSER::MENU))
-
-             (IL:* IL:|;;| "unless the menu items were passed in, compute them")
-
-             (UNLESS CLOS-BROWSER::ITEMS
-                 (SETQ CLOS-BROWSER::ITEMS (CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS
-                                            (CASE CLOS-BROWSER::INHERITED-OR-ALL
-                                                ((NIL :LOCAL) (CAR (SLOT-VALUE CLOS-BROWSER::CLASS
-                                                                          'CLOS::DIRECT-METHODS)))
-                                                (:INHERITED (CLOS::COMPUTE-INHERITED-METHODS 
-                                                                   CLOS-BROWSER::CLASS))
-                                                (:ALL (CLOS::COMPUTE-INHERITED-METHODS 
-                                                             CLOS-BROWSER::CLASS :ALL)))
-                                            CLOS-BROWSER::CLASS)))
-
-             (IL:* IL:|;;| "create the menu using whenselectedfn")
-
-             (SETQ CLOS-BROWSER::MENU (IL:CREATE IL:MENU
-                                             IL:TITLE IL:_ (IF CLOS-BROWSER::FIX-FLAG
-                                                               (CLASS-NAME CLOS-BROWSER::CLASS)
-                                                               "methods")
-                                             IL:MENUFONT IL:_ (WHEN (> (LENGTH CLOS-BROWSER::ITEMS)
-                                                                       (SLOT-VALUE CLOS-BROWSER::NODE
-                                                                              
-                                                                              '
-                                                                        CLOS-BROWSER::LARGE-MENU-SIZE
-                                                                              ))
-                                                                  (SLOT-VALUE CLOS-BROWSER::NODE
-                                                                         
-                                                                         '
-                                                                        CLOS-BROWSER::LARGE-MENU-FONT
-                                                                         ))
-                                             IL:MENUUSERDATA IL:_ '(:ESCAPE T)
-                                                             (IL:* IL:\; 
-                                   "cause symbols to print in mouse process's read-table & package")
-                                             IL:WHENSELECTEDFN IL:_ (
-                                                                    CLOS-BROWSER::MAKE-WHENSELECTEDFN
-                                                                     CLOS-BROWSER::NODE 
-                                                                     CLOS-BROWSER::INHERITED-OR-ALL 
-                                                                     CLOS-BROWSER::ITEMS)
-                                             IL:ITEMS IL:_ (APPEND CLOS-BROWSER::ITEMS
-                                                                  (UNLESS CLOS-BROWSER::FIX-FLAG
-                                                                      '(("Fix menu" NIL 
-                     "Place this menu on the screen.  WARNING: cached menues are not kept up-to-date"
-                                                                               ))))))
-
-             (IL:* IL:|;;| "cache the menu on the node")
-
-             (CLOS-BROWSER::CACHE CLOS-BROWSER::MENU CLOS-BROWSER::NODE 
-                    CLOS-BROWSER::INHERITED-OR-ALL))
-         (IF CLOS-BROWSER::FIX-FLAG
-
-             (IL:* IL:|;;| "ask user to position menu")
-
-             (IL:MOVEW (IL:ADDMENU CLOS-BROWSER::MENU))
-
-             (IL:* IL:|;;| "otherwise just pop it up")
-
-             (IL:MENU CLOS-BROWSER::MENU))))
-
-(DEFMETHOD CLOS-BROWSER::MAKE-WHENSELECTEDFN ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE
-                                                         )
-                                                  &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL 
-                                                  CLOS-BROWSER::ITEMS)
-   `(LAMBDA
-     (CLOS-BROWSER::MENU-ITEM IGNORE CLOS-BROWSER::MOUSE-KEY)
-     (LET
-      ((CLOS-BROWSER::METHOD-NAME (FIRST CLOS-BROWSER::MENU-ITEM))
-       (CLOS-BROWSER::METHOD (SECOND CLOS-BROWSER::MENU-ITEM)))
-      (IF (NULL CLOS-BROWSER::METHOD)
-
-          (IL:* IL:|;;| "do the non-method items")
-
-          (COND
-             ((STRING= CLOS-BROWSER::METHOD-NAME "Add method")
-              (CLOS-BROWSER:ADD-BROWSER-METHOD ',CLOS-BROWSER::NODE NIL))
-             ((STRING= CLOS-BROWSER::METHOD-NAME "Fix menu")
-
-              (IL:* IL:|;;| "call MENU-LOCAL-METHODS again to create fixed menu ")
-
-              (CLOS-BROWSER::MENU-METHODS ',CLOS-BROWSER::NODE ',CLOS-BROWSER::INHERITED-OR-ALL
-                     ',CLOS-BROWSER::ITEMS T))
-             (T CLOS-BROWSER::OPERATION))
-
-          (IL:* IL:|;;| "got a method, lets get an operation")
-
-          (LET ((CLOS-BROWSER::OPERATION
-                 (CASE CLOS-BROWSER::MOUSE-KEY
-                     (IL:LEFT 'CLOS-BROWSER::EDIT)
-                     (IL:MIDDLE (IL:MENU (IL:CREATE
-                                          IL:MENU
-                                          IL:TITLE IL:_ CLOS-BROWSER::METHOD-NAME
-                                          IL:ITEMS IL:_
-                                          (SLOT-VALUE ',CLOS-BROWSER::NODE
-                                                 ',(CASE CLOS-BROWSER::INHERITED-OR-ALL
-                                                       ((NIL :LOCAL) 
-                                                                     '
-                                                                CLOS-BROWSER::LOCAL-METHOD-OPERATIONS)
-                                                       (:INHERITED 
-                                                                   '
-                                                            CLOS-BROWSER::INHERITED-METHOD-OPERATIONS)
-                                                       (:ALL 'CLOS-BROWSER::ALL-METHOD-OPERATIONS))))
-                                       )))))
-
-               (IL:* IL:|;;| "got an operation, lets use it on the method")
-
-               (CASE CLOS-BROWSER::OPERATION
-                   ((NIL) NIL)
-                   ((CLOS-BROWSER::COPY CLOS-BROWSER::MOVE)  (IL:* IL:\; 
-                                                           "need to supply destination")
-                      (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD 
-
-                             (IL:* IL:|;;| "to class")
-
-                             (PROGN (UNLESS (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
-                                                   'CLOS-BROWSER::DESTINATION-BROWSER)
-                                           (ERROR "Please box a destination class, then say OK."))
-                                    (SLOT-VALUE (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER:CLOS-ICON
-                                                                   
-                                                                   'CLOS-BROWSER::DESTINATION-BROWSER
-                                                                   )
-                                                       `WEB:BOXED-NODE)
-                                           `CLOS-BROWSER::CLASS))
-
-                             (IL:* IL:|;;| "from class")
-
-                             (SLOT-VALUE ',CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)))
-                   ((DELETE)                                 (IL:* IL:\; 
-                                                           "need to supply extra confirm")
-                      (WHEN (IL:MOUSECONFIRM (FORMAT NIL 
-                                                    "Are you sure you wish to delete the ~A method?"
-                                                    (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD)))
-                            (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD)))
-                   ((CLOS-BROWSER::OVERRIDE)                 (IL:* IL:\; "use add-method ")
-                      (FUNCALL CLOS-BROWSER::OPERATION ',CLOS-BROWSER::NODE CLOS-BROWSER::METHOD))
-                   (OTHERWISE (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD))))))))
-
-(DEFMETHOD CLOS-BROWSER::DESCRIBE-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE))
-   (CLOS::DESCRIBE-OBJECT (SLOT-VALUE CLOS-BROWSER::SELF 'CLOS-BROWSER::CLASS)
-          *TRACE-OUTPUT*))
-
-(DEFMETHOD CLOS-BROWSER::DOCUMENTATION-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE
-                                                         ))
-   (DOCUMENTATION (SLOT-VALUE CLOS-BROWSER::SELF 'CLOS-BROWSER::CLASS)))
-
-(DEFMETHOD CLOS-BROWSER::PRINT-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE))
-   (PPRINT (IL:GETDEF (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER::SELF `CLOS-BROWSER::CLASS)
-                             'CLOS::NAME)
-                  'CLOS-BROWSER::CLASSES)))
-
-(DEFMETHOD CLOS-BROWSER::SPECIALIZE-CLASS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)
-                                               &OPTIONAL CLOS-BROWSER::FORM 
-                                               CLOS-BROWSER::NEW-CLASS-NAME)
-   (CLOS-BROWSER::SPECIALIZE (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)
-          CLOS-BROWSER::FORM CLOS-BROWSER::NEW-CLASS-NAME))
-
-(DEFUN CLOS-BROWSER::COMPLETE-ADD-METHOD (CLOS-BROWSER::CONTEXT STRUCTURE &OPTIONAL (
-                                                                               CLOS-BROWSER::CHANGED?
-                                                                                         T))
-   (DECLARE (IGNORE CLOS-BROWSER::CONTEXT))
-   (CASE CLOS-BROWSER::CHANGED?
-       ((:ABORT NIL) NIL)
-       (OTHERWISE (EVAL (COPY-TREE                           (IL:* IL:\; 
-                                 "to ensure the original list does not get destructively clobbered")
-                               STRUCTURE)))))
-
-(DEFUN CLOS-BROWSER::COMPLETE-SPECIALIZE (IGNORE STRUCTURE CLOS-BROWSER::CHANGED?)
-   (DECLARE (IGNORE CLOS-BROWSER::CONTEXT))
-   (CASE CLOS-BROWSER::CHANGED?
-       ((:ABORT NIL) NIL)
-       (T (LET ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR)))
-               (UNWIND-PROTECT
-                   (PROGN (IL:SETCURSOR IL:WAITINGCURSOR)
-                          (LET ((CLOS-BROWSER::SUB-CLASS (EVAL (COPY-TREE 
-                                                             (IL:* IL:\; 
-                             "so original list does not get clobbered if this class's name changes")
-                                                                      STRUCTURE)))
-                                CLOS-BROWSER::SUPER-CLASS)
-
-                               (IL:* IL:|;;| "check for bug")
-
-                               (WHEN (SYMBOLP CLOS-BROWSER::SUB-CLASS)
-                                   (SETQ CLOS-BROWSER::SUB-CLASS (FIND-CLASS CLOS-BROWSER::SUB-CLASS)
-                                         ))
-                               (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON
-                                                                     'CLOS-BROWSER::CLASS-BROWSERS))
-                                   (DOLIST (CLOS-BROWSER::SUPER-CLASS (SLOT-VALUE 
-                                                                             CLOS-BROWSER::SUB-CLASS
-                                                                             
-                                                                             '
-                                                                            CLOS::DIRECT-SUPERCLASSES
-                                                                             ))
-                                       (WHEN (CLOS-BROWSER::CONTAINS-P CLOS-BROWSER::SUPER-CLASS 
-                                                    CLOS-BROWSER::BROWSER)
-                                           (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::BROWSER 
-                                                  CLOS-BROWSER::SUB-CLASS)
-                                           (RETURN))))))
-                   (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR))))))
-
-(DEFUN CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE (IGNORE STRUCTURE)
-   (LET ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR)))
-        (UNWIND-PROTECT
-            (PROGN (IL:SETCURSOR IL:WAITINGCURSOR)
-                   (LET ((CLOS-BROWSER::SUB-CLASS (EVAL (COPY-TREE 
-                                                             (IL:* IL:\; 
-                             "so original list does not get clobbered if this class's name changes")
-                                                               STRUCTURE)))
-                         CLOS-BROWSER::SUPER-CLASS)
-
-                        (IL:* IL:|;;| "check for bug")
-
-                        (WHEN (SYMBOLP CLOS-BROWSER::SUB-CLASS)
-                            (SETQ CLOS-BROWSER::SUB-CLASS (CLOS::SYMBOL-CLASS CLOS-BROWSER::SUB-CLASS
-                                                                 )))
-                        (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON
-                                                              'CLOS-BROWSER::CLASS-BROWSERS))
-                            (DOLIST (CLOS-BROWSER::SUPER-CLASS (SLOT-VALUE CLOS-BROWSER::SUB-CLASS
-                                                                      'CLOS::LOCAL-SUPERS))
-                                (WHEN (CLOS-BROWSER::CONTAINS-P CLOS-BROWSER::SUPER-CLASS 
-                                             CLOS-BROWSER::BROWSER)
-                                    (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::BROWSER 
-                                           CLOS-BROWSER::SUB-CLASS)
-                                    (RETURN))))))
-            (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR))))
-
-(DEFUN CLOS-BROWSER::THIS-CLASS-NODE-P (CLOS-BROWSER::CLASS CLOS-BROWSER::NODE)
-   (EQ CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)))
-
-(DEFUN CLOS::CLASS-DIRECT-METHODS (CLOS::CLASS)
-   (SLOT-VALUE CLOS::CLASS 'CLOS::DIRECT-METHODS))
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-CLASS (directly)")
-
-
-(DEFMETHOD CLOS::COMPUTE-INHERITED-METHODS ((CLOS::SELF STANDARD-CLASS)
-                                                &OPTIONAL CLOS::ALL-FLAG)
-   "Compute and return all inherited methods of a class.  If all-flag eq :all then methods on t and the passed class are included."
-
-   (IL:* IL:|;;| "The following does not use generic function dispatch-orders, discriminating-functions, or classical-method-tables.")
-
-   (IL:* IL:|;;| "For each method in the direct-methods of each inherited class in the class-precedence-list for the class of interest, in class precedence order check to see if we have already analyzed its generic function.")
-
-   (IL:* IL:|;;| "If it is a new gf then if there is exactly one type specifier then add the direct method to the list of inherited methods.")
-
-   (IL:* IL:|;;| "If there is more than one type specifier then for every method in the gf for each specializer if the specializing class is equal to or later than the current class in the class precedence list, ignoring t, pushnew the method on the list of inherited methods.ÿÿ")
-
-   (LET
-    ((CLOS::FILTERED-CLASSES NIL)
-     (CLOS::MY-GFS NIL)
-     (CLOS::CLASS-PRECEDENCE-LIST (SLOT-VALUE CLOS::SELF 'CLOS::CLASS-PRECEDENCE-LIST))
-     (CLOS::INHERITED-METHODS NIL)
-     (CLOS::DIRECT-METHODS (CAR (SLOT-VALUE CLOS::SELF 'CLOS::DIRECT-METHODS)))
-     (CLOS::T-CLASS (FIND-CLASS 'T)))
-    (UNLESS (EQ CLOS::ALL-FLAG :ALL)                         (IL:* IL:\; 
-                                                           "ignore t and the bottom class ")
-        (PUSH CLOS::T-CLASS CLOS::FILTERED-CLASSES)
-        (PUSH CLOS::SELF CLOS::FILTERED-CLASSES)
-        (SETQ CLOS::MY-GFS (MAPCAR #'CLOS::METHOD-GENERIC-FUNCTION CLOS::DIRECT-METHODS)))
-    (DOLIST (CLOS::CLASS CLOS::CLASS-PRECEDENCE-LIST)
-        (UNLESS (MEMBER CLOS::CLASS CLOS::FILTERED-CLASSES)
-            (DOLIST (CLOS::DIRECT-METHOD (CAR (CLOS::CLASS-DIRECT-METHODS CLOS::CLASS)))
-                (LET ((CLOS::GF (CLOS::METHOD-GENERIC-FUNCTION CLOS::DIRECT-METHOD)))
-                     (UNLESS (MEMBER CLOS::GF CLOS::MY-GFS :TEST #'EQ)
-                         (IF (= 1 (LENGTH (SLOT-VALUE CLOS::DIRECT-METHOD 'CLOS::SPECIALIZERS))
-                                                             (IL:* IL:\; "Note: this check relies on guaranteed congruent lambda lists.  There should be some way to query the gf directly.")
-                                )
-
-                             (IL:* IL:|;;| 
-                           "then only one specializer so this method must be inherited. ")
-
-                             (PUSH CLOS::DIRECT-METHOD CLOS::INHERITED-METHODS)
-
-                             (IL:* IL:|;;| "otherwise more than one so must look at specializers ")
-
-                             (DOLIST (CLOS::GF-METHOD (SLOT-VALUE CLOS::GF 'CLOS::METHODS))
-                                 (DOLIST (CLOS::SPECIFIER (SLOT-VALUE CLOS::GF-METHOD 
-                                                                 'CLOS::SPECIALIZERS))
-                                     (UNLESS (OR (EQ CLOS::T-CLASS CLOS::SPECIFIER)
-                                                 (NOT (MEMBER CLOS::SPECIFIER 
-                                                             CLOS::CLASS-PRECEDENCE-LIST :TEST
-                                                             #'EQ)))
-                                         (PUSHNEW CLOS::GF-METHOD CLOS::INHERITED-METHODS)
-                                         (RETURN))))))
-                     (PUSH CLOS::GF CLOS::MY-GFS)))))
-    CLOS::INHERITED-METHODS))
-
-(DEFMETHOD CLOS-BROWSER::SPECIALIZE ((CLOS-BROWSER::CLASS STANDARD-CLASS)
-                                         &OPTIONAL CLOS-BROWSER::FORM CLOS-BROWSER::NEW-CLASS-NAME)
-   (DECLARE (SPECIAL SEDIT::BASIC-GAP))
-   (LET* ((CLASS-NAME (CLASS-NAME CLOS-BROWSER::CLASS))
-          CLOS-BROWSER::CONTEXT
-          (CLOS-BROWSER::NAME (FORMAT NIL "New sub-class of ~A" CLASS-NAME))
-          (*PACKAGE* (SYMBOL-PACKAGE CLASS-NAME)))
-         (UNLESS CLOS-BROWSER::FORM
-             (SETQ CLOS-BROWSER::FORM (LIST 'DEFCLASS (OR CLOS-BROWSER::NEW-CLASS-NAME 
-                                                          SEDIT::BASIC-GAP)
-                                            (LIST CLASS-NAME)
-                                            (LIST SEDIT::BODY-GAP))))
-
-         (IL:* IL:|;;| "call sedit")
-
-         (SEDIT:SEDIT CLOS-BROWSER::FORM (LIST :NAME CLOS-BROWSER::NAME :COMPLETION-FN 
-                                               #'CLOS-BROWSER::COMPLETE-SPECIALIZE)
-                :DONTWAIT)))
-
-(DEFMETHOD CLOS-BROWSER::SUBCLASSES-OF ((CLOS-BROWSER::CLASS STANDARD-CLASS))
-   (APPEND (LIST CLOS-BROWSER::CLASS)
-          (IL:FOR CLOS-BROWSER::SUBCLASS IL:IN (SLOT-VALUE CLOS-BROWSER::CLASS 
-                                                              'CLOS::DIRECT-SUBCLASSES)
-             IL:JOIN (IF (SLOT-VALUE CLOS-BROWSER::SUBCLASS 'CLOS::DIRECT-SUBCLASSES)
-                             (CLOS-BROWSER::SUBCLASSES-OF CLOS-BROWSER::SUBCLASS)
-                             (LIST CLOS-BROWSER::SUBCLASS)))))
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-METHOD")
-
-
-(DEFMETHOD CLOS-BROWSER::DELETE-METHOD ((CLOS-BROWSER::METHOD STANDARD-METHOD))
-   (REMOVE-METHOD (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::GENERIC-FUNCTION)
-          CLOS-BROWSER::METHOD))
-
-(DEFMETHOD CLOS-BROWSER::COPY ((CLOS-BROWSER::METHOD STANDARD-METHOD)
-                                   (CLOS-BROWSER::TO-CLASS STANDARD-CLASS)
-                                   &OPTIONAL CLOS-BROWSER::FROM-CLASS)
-   (WHEN (EQ CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS)
-         (RETURN-FROM CLOS-BROWSER::COPY))
-
-   (IL:* IL:|;;| "if we have the source code, find all the references to the from class, change them to the to-class, and evaluate the new form.   If from-class is not provided, if method is specialized on just one class, use it, otherwise ask the user.")
-
-   (IL:* IL:|;;| "If we dont have source code, we could ask if you want to just move the method object, but instead we print a complaint and punt.")
-
-   (LET ((CLOS-BROWSER::METHOD-DEFINITION (COPY-TREE (XCL:IGNORE-ERRORS (IL:GETDEF (
-                                                                               CLOS::FULL-METHOD-NAME
-                                                                                    
-                                                                                 CLOS-BROWSER::METHOD
-                                                                                    )
-                                                                               
-                                                                               'CLOS-BROWSER::METHODS
-                                                                               ))))
-         (CLOS-BROWSER::NON-T-CLASSES (MAPCAR #'(LAMBDA (CLOS-BROWSER::CLASS)
-                                                       (UNLESS (EQ CLOS-BROWSER::CLASS 'T)
-                                                              CLOS-BROWSER::CLASS))
-                                             (CLOS::METHOD-SPECIALIZERS CLOS-BROWSER::METHOD))))
-        (UNLESS CLOS-BROWSER::METHOD-DEFINITION
-            (FORMAT T "The definition for ~A is not loaded" (CLOS::FULL-METHOD-NAME 
-                                                                   CLOS-BROWSER::METHOD NIL))
-            (RETURN-FROM CLOS-BROWSER::COPY NIL))
-        (IF CLOS-BROWSER::FROM-CLASS
-
-            (IL:* IL:|;;| "method should be specialized on from-class.")
-
-            (UNLESS (MEMBER CLOS-BROWSER::FROM-CLASS CLOS-BROWSER::NON-T-CLASSES)
-                (ERROR "The ~A method is not specialized on the ~A class" (CLOS::FULL-METHOD-NAME
-                                                                           CLOS-BROWSER::METHOD NIL)
-                       (CLASS-NAME CLOS-BROWSER::FROM-CLASS)))
-
-            (IL:* IL:|;;| "otherwise see if we can deduce FROM-CLASS ")
-
-            (CASE (LENGTH CLOS-BROWSER::NON-T-CLASSES)
-                (0 (FORMAT T "Unspecialized methods cannot be copied. ~A" (CLOS::FULL-METHOD-NAME
-                                                                           CLOS-BROWSER::METHOD NIL)))
-                (1 (SETQ CLOS-BROWSER::FROM-CLASS (CAR CLOS-BROWSER::NON-T-CLASSES)))
-                (OTHERWISE (SETQ CLOS-BROWSER::FROM-CLASS (CLOS::SYMBOL-CLASS
-                                                           (IL:PROMPTFORWORD (FORMAT NIL 
-                                                        "Which class in ~A do you wish to move from?"
-                                                                                    (
-                                                                               CLOS::FULL-METHOD-NAME
-                                                                                     
-                                                                                 CLOS-BROWSER::METHOD
-                                                                                     NIL))))))))
-
-        (IL:* IL:|;;| "should contain from-class.  If it is not the same, abort.")
-
-        (CLOS-BROWSER::REPLACE-SPECIALIZERS CLOS-BROWSER::METHOD-DEFINITION (CLASS-NAME 
-                                                                             CLOS-BROWSER::FROM-CLASS
-                                                                                       )
-               (CLASS-NAME CLOS-BROWSER::TO-CLASS))
-        (PRINT (EVAL CLOS-BROWSER::METHOD-DEFINITION))))
-
-(DEFMETHOD CLOS-BROWSER::MOVE ((CLOS-BROWSER::METHOD STANDARD-METHOD)
-                                   (CLOS-BROWSER::TO-CLASS STANDARD-CLASS)
-                                   &OPTIONAL CLOS-BROWSER::FROM-CLASS)
-   (WHEN (EQ CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS)
-         (RETURN-FROM CLOS-BROWSER::MOVE))
-   (IF (CLOS-BROWSER::COPY CLOS-BROWSER::METHOD CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS)
-       (CLOS-BROWSER::DELETE-METHOD CLOS-BROWSER::METHOD)
-       (FORMAT T "copy of ~A to ~A failed" (XCL:IGNORE-ERRORS (CLOS::FULL-METHOD-NAME 
-                                                                     CLOS-BROWSER::METHOD))
-              (XCL:IGNORE-ERRORS (CLASS-NAME CLOS-BROWSER::TO-CLASS)))))
-
-(DEFMETHOD CLOS-BROWSER::PRINT-DEFINITION ((CLOS-BROWSER::SELF STANDARD-METHOD))
-   (PPRINT (IL:GETDEF (CLOS::FULL-METHOD-NAME CLOS-BROWSER::SELF)
-                  'CLOS-BROWSER::METHODS)))
-
-(DEFMETHOD CLOS-BROWSER::DESCRIBE-METHOD ((CLOS-BROWSER::METHOD CLOS::METHOD))
-   (CLOS::DESCRIBE-OBJECT CLOS-BROWSER::METHOD *TRACE-OUTPUT*))
-
-(DEFMETHOD CLOS-BROWSER::RENAME ((CLOS-BROWSER::METHOD STANDARD-METHOD)
-                                     &OPTIONAL CLOS-BROWSER::NEW-NAME)
-   (UNLESS CLOS-BROWSER::NEW-NAME
-       (SETQ CLOS-BROWSER::NEW-NAME (READ (MAKE-STRING-INPUT-STREAM (IL:PROMPTFORWORD
-                                                                     (FORMAT NIL "~%New name for ~A"
-                                                                            (CLOS::FULL-METHOD-NAME
-                                                                             CLOS-BROWSER::METHOD))))
-                                          )))
-   (LET ((CLOS-BROWSER::METHOD-DEFINITION (XCL:IGNORE-ERRORS (IL:GETDEF CLOS-BROWSER::METHOD))))
-        (UNLESS CLOS-BROWSER::METHOD-DEFINITION
-            (FORMAT T "The definition for ~A is not loaded" (CLOS::FULL-METHOD-NAME 
-                                                                   CLOS-BROWSER::METHOD NIL))
-            (RETURN-FROM CLOS-BROWSER::RENAME NIL))
-        (IF (AND (SETF (SECOND CLOS-BROWSER::METHOD-DEFINITION)
-                       CLOS-BROWSER::NEW-NAME)
-                 (PRINT (EVAL CLOS-BROWSER::METHOD-DEFINITION)))
-            (DELETE CLOS-BROWSER::METHOD)
-            (FORMAT T "~%Rename of ~A to ~A failed" (XCL:IGNORE-ERRORS (CLOS::FULL-METHOD-NAME 
-                                                                              CLOS-BROWSER::METHOD))
-                   CLOS-BROWSER::NEW-NAME))))
-
-(DEFMETHOD CLOS-BROWSER::UPDATE-CACHED-MENUES ((CLOS-BROWSER::METHOD STANDARD-METHOD)
-                                                   &OPTIONAL
-                                                   (CLOS-BROWSER::CACHE-SWITCH (SLOT-VALUE
-                                                                                
-                                                                               CLOS-BROWSER:CLOS-ICON
-                                                                                
-                                                                                '
-                                                                      CLOS-BROWSER::MENU-CACHE-SWITCH
-                                                                                )))
-   "set cached menues for this method's class to nil"
-   (LET
-    ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR)))
-    (UNWIND-PROTECT
-        (PROGN (IL:SETCURSOR IL:WAITINGCURSOR)
-               (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
-                                                     'CLOS-BROWSER::CLASS-BROWSERS))
-                   (DOLIST (CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::SPECIALIZERS)
-                                  )
-
-                       (IL:* IL:|;;| 
-    "fix bug in the inconsistent way CLOS objects store T class specializers and do method lookup.")
-
-                       (WHEN (EQ CLOS-BROWSER::CLASS T)
-                           (SETQ CLOS-BROWSER::CLASS (CLOS::SYMBOL-CLASS T)))
-                       (LET ((CLOS-BROWSER::NODE (CLOS-BROWSER::BROWSER-CONTAINS-P 
-                                                        CLOS-BROWSER::CLASS CLOS-BROWSER::BROWSER)))
-                            (WHEN CLOS-BROWSER::NODE
-                                (CASE CLOS-BROWSER::CACHE-SWITCH
-                                    (:LAZY 
-                                       (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE)
-                                       (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :ALL)
-                                       (DOLIST (CLOS-BROWSER::SUB-CLASS (CLOS-BROWSER::SUBCLASSES-OF
-                                                                         (SLOT-VALUE 
-                                                                                CLOS-BROWSER::NODE
-                                                                                'CLOS-BROWSER::CLASS)
-                                                                         ))
-                                           (WHEN (SETQ CLOS-BROWSER::NODE (CLOS-BROWSER::CONTAINS-P
-                                                                           CLOS-BROWSER::SUB-CLASS 
-                                                                           CLOS-BROWSER::BROWSER))
-                                               (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :INHERITED)
-                                               (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :ALL))))
-                                    (:EAGER (PRINT ":eager method menu cacheing not yet implemented."
-                                                   ))
-                                    (OTHERWISE 
-                                       NIL                   (IL:* IL:\; "do nothing")
-                                       )))))))
-        (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR))))
-
-(DEFMETHOD CLOS-BROWSER::WHO-OWNS ((CLOS-BROWSER::METHOD STANDARD-METHOD))
-   (PRINT (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD)))
-
-(DEFMETHOD ADD-METHOD :AFTER
-   ((CLOS-BROWSER::GENERIC-FUNCTION STANDARD-GENERIC-FUNCTION)
-    (CLOS-BROWSER::METHOD STANDARD-METHOD))
-   "Update cached menues."
-   (LET (CLOS-BROWSER::CACHE-SWITCH)
-        (WHEN (AND CLOS-BROWSER::METHOD (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 
-                                               'CLOS-BROWSER::CLASS-BROWSERS)
-                                                             (IL:* IL:\; "there are some browsers")
-                   (NOT (EQ (SETQ CLOS-BROWSER::CACHE-SWITCH (SLOT-VALUE CLOS-BROWSER:CLOS-ICON
-                                                                    'CLOS-BROWSER::MENU-CACHE-SWITCH)
-                                  )
-                            :NONE))                          (IL:* IL:\; 
-                                                           "we want auto cache updating")
-                   )
-              (CLOS-BROWSER::UPDATE-CACHED-MENUES CLOS-BROWSER::METHOD CLOS-BROWSER::CACHE-SWITCH))
-        CLOS-BROWSER::GENERIC-FUNCTION))
-
-(DEFUN CLOS-BROWSER::REPLACE-SPECIALIZERS (CLOS-BROWSER::METHOD-DEFINITION 
-                                                     CLOS-BROWSER::FROM-CLASS-NAME 
-                                                     CLOS-BROWSER::TO-CLASS-NAME &KEY 
-                                                     CLOS-BROWSER::IN-LAMDA-LIST-ONLY-FLAG)
-   (NSUBST CLOS-BROWSER::TO-CLASS-NAME CLOS-BROWSER::FROM-CLASS-NAME
-          (IF CLOS-BROWSER::IN-LAMDA-LIST-ONLY-FLAG
-
-              (IL:* IL:|;;| "get the lamba list")
-
-              (THIRD (MULTIPLE-VALUE-LIST (CLOS::PARSE-DEFMETHOD (CDR CLOS-BROWSER::METHOD-DEFINITION
-                                                                      ))))
-                                                             (IL:* IL:\; "note this gets argument names as well as specializers.  Usually not what you want.  Needs to be made smarter to just get specializers.")
-
-              (IL:* IL:|;;| "otherwise do the whole method")
-
-              CLOS-BROWSER::METHOD-DEFINITION)))
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;;| "SETUP RELEASE INFO")
-
-
-(IL:RPAQ CLOS-BROWSER::RELEASE-ID "0.02")
-
-(IL:RPAQ CLOS-BROWSER::SYSTEM-DATE (CAAR (IL:GETPROP 'IL:CLOS-BROWSER 'IL:FILEDATES)))
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;| "SETUP BACKGROUND MENU")
-
-
-(DEFUN CLOS-BROWSER::IN-SELECT-PACKAGE ()
-   "pops up a menu of packages"                     (IL:* IL:\; "Edited 18-Mar-87 13:13 by smL")
-                                                             (IL:* IL:\; "")
-
-   (IL:* IL:|;;| "kirk: 16Mar88 modified for clos-browser")
-
-   (LET ((PACKAGE (IL:MENU
-                   (IL:|create|
-                    IL:MENU
-                    IL:TITLE IL:_ "Select package"
-                    IL:ITEMS IL:_
-                    (IL:SORT (IL:|for| PACKAGE IL:|in| (LIST-ALL-PACKAGES) IL:|bind|
-                                                                                   IL:PACKAGE-NAME
-                                IL:|collect| (IL:SETQ IL:PACKAGE-NAME (PACKAGE-NAME PACKAGE))
-                                      `(,(IL:CONCAT (OR (CAR (PACKAGE-NICKNAMES PACKAGE))
-                                                        IL:PACKAGE-NAME)
-                                                ":")
-                                        ',IL:PACKAGE-NAME
-                                        ,(IL:CONCAT "Set the current package to " IL:PACKAGE-NAME ":"
-                                                )))
-                           (IL:FUNCTION (IL:LAMBDA (IL:X IL:Y)
-                                          (IL:ALPHORDER (CAR IL:X)
-                                                 (CAR IL:Y)))))
-                    IL:CENTERFLG IL:_ T))))
-        (IL:|if| PACKAGE
-            IL:|then| (IN-PACKAGE PACKAGE))))
-
-(DEFUN CLOS-BROWSER::CLASSES-IN-PACKAGE (PACKAGE &OPTIONAL CLOS-BROWSER::MAP-ON-PACKAGE)
-   "Retrieves a list of all the classes for a given package.  When map-on-package is t this can be very slow."
-
-   (IL:* IL:|;;| "The maphash is always fast, whereas for some strange reason map-on-package varys among packages greatly.")
-
-   (LET ((CLOS-BROWSER::CLASSES))
-        (UNLESS (TYPEP PACKAGE 'PACKAGE)
-            (SETQ PACKAGE (FIND-PACKAGE PACKAGE)))
-        (IF CLOS-BROWSER::MAP-ON-PACKAGE
-            (DO-SYMBOLS (CLOS-BROWSER::SYM PACKAGE)
-                   (IF (AND (EQ (SYMBOL-PACKAGE CLOS-BROWSER::SYM)
-                                PACKAGE)
-                            (CLOS::SYMBOL-CLASS CLOS-BROWSER::SYM T))
-                       (PUSH CLOS-BROWSER::SYM CLOS-BROWSER::CLASSES)))
-            (MAPHASH #'(LAMBDA (CLOS-BROWSER::KEY CLOS-BROWSER::VAL)
-                              (IF (EQ (SYMBOL-PACKAGE CLOS-BROWSER::KEY)
-                                      PACKAGE)
-                                  (PUSH CLOS-BROWSER::KEY CLOS-BROWSER::CLASSES)))
-                   CLOS::*FIND-CLASS*))
-        CLOS-BROWSER::CLASSES))
-
-
-(IL:* IL:|;;| "pushnew should eliminate this")
-
-
-(SETQ IL:|BackgroundMenuCommands| (REMOVE 'IL:|BrowseClass| IL:|BackgroundMenuCommands| :KEY
-                                         #'CAR))
-
-(PUSH '(IL:|BrowseClass| (CLOS-BROWSER:BROWSE-CLASS)
-              "Bring up a class browser."
-              (IL:SUBITEMS (IL:|all in a package| (CLOS-BROWSER:BROWSE-CLASS (
-                                                                   CLOS-BROWSER::CLASSES-IN-PACKAGE
-                                                                                  (
-                                                                    CLOS-BROWSER::IN-SELECT-PACKAGE
-                                                                                   )))
-                                  
-                               "Select a package and browse all the classes defined in that package."
-                                  )))
-      IL:|BackgroundMenuCommands|)
-
-(SETQ IL:|BackgroundMenu| NIL)
-(IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:COPYRIGHT ("Venue" 1991))
-(IL:DECLARE\: IL:DONTCOPY
-  (IL:FILEMAP (NIL)))
-IL:STOP
diff --git a/obsolete/clos/2.0/WEB-EDITOR b/obsolete/clos/2.0/WEB-EDITOR
deleted file mode 100644
index 581d6cf7..00000000
--- a/obsolete/clos/2.0/WEB-EDITOR
+++ /dev/null
@@ -1,2338 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE (LET ((*PACKAGE*)) (* ;; 
-"Put IN Seven EXtremely Random USEr Interface COmmands ") (CLPROVIDE "WEB-EDITOR") (CLIN-PACKAGE 
-"WEB" NICKNAMES (QUOTE ("WEB-EDITOR"))) (* ;; "EXPORT") (CLFLET ((XCL-USEREXPORT-FROM-WEB (&REST 
-XCL-USERSYMBOL-NAMES) (LET ((XCL-USERPKG (CLFIND-PACKAGE "WEB"))) (CLDOLIST (XCL-USERNAME 
-XCL-USERSYMBOL-NAMES) (EXPORT (CLINTERN XCL-USERNAME XCL-USERPKG) XCL-USERPKG))))) (* ;; 
-"Class Definitions and Slot Access") (XCL-USEREXPORT-FROM-WEB "WEB-EDITOR" "WEB-NODE" "NODE-NAME" 
-"NODE-LINKS" "NODE-BACK-LINKS" "LOCAL-COMMANDS" "NODE-MOVER-P" "TITLE-ITEMS" "LEFT-BUTTON-ITEMS" 
-"MIDDLE-BUTTON-ITEMS" "RIGHT-BUTTON-ITEMS" "BROWSE-FONT") (* ;; "For Subclassing") (XCL-USEREXPORT-FROM-WEB
- "GET-LABEL" "GET-SUBS" "ICON-TITLE" "NODE-MENU-ITEMS" "REORDER-TREE" "MOVE-NODE") (* ;; "Top Level") 
-(XCL-USEREXPORT-FROM-WEB "MAKE-WEB-EDITOR" "INITIALIZE-EDITOR" "BROWSE" "DISPLAY-BROWSER" "DESTROY" 
-"ADD-NODE" "NOTICE-NODE" "REMOVE-NODE" "RENAME-NODE") (* ;; "Window Operations") (XCL-USEREXPORT-FROM-WEB
- "SHRINK" "MOVE" "CLEAR" "PROMPT-PRINT" "PROMPT-READ" "PROMPT-FOR-LIST" "PROMPT-FOR-STRING" 
-"PROMPT-FOR-WORD") (* ;; "Recomputing and Changing parameters") (XCL-USEREXPORT-FROM-WEB "RECOMPUTE"
- "RECOMPUTE-IN-PLACE" "RECOMPUTE-LABELS" "RECOMPUTE-IF-OPEN" "CLEAR-LABEL-CACHE" "CHANGE-FONT-SIZE" 
-"CHANGE-FORMAT" "SHAPE-TO-HOLD") (* ;; "For CLOS-BROWSER???") (XCL-USEREXPORT-FROM-WEB "BOXED-NODE" 
-"BOX-NODE")) (* ;; "USE") (CLUSE-PACKAGE (QUOTE ("CLOS" "LISP" "XCL")) "WEB") (* ;; "IMPORT") (CLFLET
- ((XCL-USERIMPORT-FROM-PACKAGE (XCL-USERNAMES XCL-USERFROM &OPTIONAL XCL-USERSHADOW-P) (LET ((
-XCL-USERFROM-PACKAGE (CLFIND-PACKAGE XCL-USERFROM))) (CLFUNCALL (CLIF XCL-USERSHADOW-P (
-CLFUNCTION CLSHADOWING-IMPORT) (CLFUNCTION IMPORT)) (CLMAPCAR (CLFUNCTION (CLLAMBDA (XCL-USERNAME
-) (CLINTERN XCL-USERNAME XCL-USERFROM-PACKAGE))) XCL-USERNAMES))))) (XCL-USERIMPORT-FROM-PACKAGE
- (QUOTE ("CLASSES" "METHODS")) "CLOS") (XCL-USERIMPORT-FROM-PACKAGE (QUOTE ("FALSE")) "XCL") (
-XCL-USERIMPORT-FROM-PACKAGE (QUOTE ("FUNCTIONS" "FNS" "VARIABLES" "VARS" "BITMAPS" "COMS")) "IL")) (
-CLFIND-PACKAGE "WEB")) READTABLE "XCL" BASE 10)
-(IL:FILECREATED " 5-Nov-91 08:07:23" 
-IL:|{DSK}<usr>local>users>welch>lisp>clos>browser>WEB-EDITOR.;8| 132667 
-
-      IL:|changes| IL:|to:|  (IL:TYPES WEB-NODE WEB-EDITOR)
-
-      IL:|previous| IL:|date:| "30-Sep-91 23:36:34" 
-IL:|{DSK}<usr>local>users>welch>lisp>clos>browser>WEB-EDITOR.;6|)
-
-
-; Copyright (c) 1987, 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.
-
-(IL:PRETTYCOMPRINT IL:WEB-EDITORCOMS)
-
-(IL:RPAQQ IL:WEB-EDITORCOMS ((COMS IL:* FILE-HEADER-COMS)
-                                 
-                                 (IL:* IL:|;;| "")
-
-                                 
-
-(IL:* IL:|;;;| "WEB EDITOR ")
-
-                                 
-                                 (IL:* IL:|;;| "")
-
-                                 
-                                 (IL:* IL:|;;| "Package Setup")
-
-                                 (IL:DECLARE\: IL:DONTCOPY (IL:PROPS (IL:WEB-EDITOR 
-                                                                            IL:MAKEFILE-ENVIRONMENT)
-                                                                  (IL:WEB-EDITOR IL:FILETYPE)))
-                                 
-                                 (IL:* IL:|;;| "Global Variables")
-
-                                 
-                                 (IL:* IL:|;;| "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)")
-
-                                 (VARIABLES DESTINATION-BROWSER)
-                                 (COMS                       (IL:* IL:\; "Client Interface")
-                                       
-                                       (IL:* IL:|;;| "Web Node Class")
-
-                                       (CLASSES WEB-NODE)
-                                       
-                                       (IL:* IL:|;;| " Web Editor  Class")
-
-                                       (CLASSES WEB-EDITOR)
-                                       
-                                       (IL:* IL:|;;| "Top Level")
-
-                                       (FUNCTIONS MAKE-WEB-EDITOR)
-                                       (METHODS (INITIALIZE-EDITOR (WEB-EDITOR))
-                                              (DESTROY (WEB-EDITOR))
-                                              (BROWSE (WEB-EDITOR)))
-                                       (METHODS 
-
-                                              (IL:* IL:|;;| "For Subclassing")
-
-                                              (GET-LABEL (WEB-EDITOR WEB-NODE))
-                                              (GET-SUBS (WEB-EDITOR WEB-NODE))
-                                              (ICON-TITLE (WEB-EDITOR))
-                                              
-                                              (IL:* IL:|;;| "Adding, Removing, Hiding Nodes.")
-
-                                              (ADD-NODE (WEB-EDITOR WEB-NODE))
-                                              (NOTICE-NODE (WEB-EDITOR WEB-NODE WEB-NODE))
-                                              (REMOVE-NODE (WEB-EDITOR WEB-NODE))
-                                              (DELETE-FROM-BROWSER (WEB-EDITOR))
-                                              (REMOVE-FROM-BAD-LIST (WEB-EDITOR))
-                                              
-                                              (IL:* IL:|;;| "")
-
-                                              (RENAME-NODE (WEB-EDITOR WEB-NODE)))
-                                                             (IL:* IL:\; ""))
-                                 (COMS                       (IL:* IL:\; "Window System Interface")
-                                       (METHODS (UPDATE (WEB-EDITOR))
-                                              (CREATE-WINDOW (WEB-EDITOR))
-                                              (SETUP-WINDOW (WEB-EDITOR))
-                                              (DETACH-LISP-WINDOW (WEB-EDITOR))
-                                              (SHRINK (WEB-EDITOR))
-                                              (SET-OUTER-REGION (WEB-EDITOR))
-                                              (SET-REGION (WEB-EDITOR))
-                                              (MOVE (WEB-EDITOR))
-                                              (MOVE1 (WEB-EDITOR))
-                                              (AFTER-MOVE (WEB-EDITOR))
-                                              (AFTER-RESHAPE (WEB-EDITOR))
-                                              (SCROLL-WINDOW (WEB-EDITOR))
-                                              (CLEAR (WEB-EDITOR))
-                                              
-                                              (IL:* IL:|;;| "Prompt Window Interactions ")
-
-                                              (GET-PROMPT-WINDOW (WEB-EDITOR))
-                                              (REMOVE-PROMPT-WINDOW (WEB-EDITOR))
-                                              (PROMPT-PRINT (WEB-EDITOR))
-                                              (PROMPT-READ (WEB-EDITOR))
-                                              (PROMPT-FOR-LIST (WEB-EDITOR))
-                                              (PROMPT-FOR-STRING (WEB-EDITOR))
-                                              (PROMPT-FOR-WORD (WEB-EDITOR)))
-                                       (FUNCTIONS MOVE-DOWN-P)
-                                       (FNS WEB-WINDOW-AFTER-MOVE-FN WEB-WINDOW-BUTTON-EVENT-FN 
-                                            WEB-WINDOW-RESHAPE-FN WEB-WINDOW-CLOSE-FN IL:|PromptRead|
-                                            )
-                                       (FNS WEB-WINDOW-EXPAND-FN)
-                                       (FUNCTIONS WEB-WINDOW-ICON-FN)
-                                       (BITMAPS *WEB-EDITOR-ICON-BM* *WEB-EDITOR-ICON-MASK*)
-                                       (VARIABLES *WEB-EDITOR-TEMPLATE*)
-                                       (VARS (IL:*D-WINDOW-DEFAULT-STREAM* IL:PROMPTWINDOW)
-                                             (WEB-STREAM IL:PROMPTWINDOW)))
-                                 (COMS                       (IL:* IL:\; 
-                                                           "Layout and Display Engine")
-                                       (VARS IL:|BrowserMargin| IL:|MaxLatticeHeight| 
-                                             IL:|MaxLatticeWidth|)
-                                       (IL:SPECVARS IL:|MaxLatticeHeight| IL:|MaxLatticeWidth|)
-                                       (VARS IL:GRAYSHADE1 IL:GRAYSHADE2 IL:GRAYSHADE3 IL:GRAYSHADE4)
-                                       (FNS TREE-ROOTS CHILD-NODES REACHABLE-NODES!)
-                                       (METHODS (DISPLAY-BROWSER (WEB-EDITOR))
-                                              (BROWSER-OBJECTS (WEB-EDITOR))
-                                              (GET-NODE-LIST (WEB-EDITOR))
-                                              (OBJ-NAME-PAIR (WEB-EDITOR))
-                                              (GRAPH-FITS (WEB-EDITOR))
-                                              (NODE-REGION (WEB-EDITOR))
-                                                             (IL:* IL:\; "")
-                                              (RECOMPUTE (WEB-EDITOR))
-                                              (RECOMPUTE-IN-PLACE (WEB-EDITOR))
-                                              (RECOMPUTE-LABELS (WEB-EDITOR))
-                                              (RECOMPUTE-IF-OPEN (WEB-EDITOR))
-                                              (CLEAR-LABEL-CACHE (WEB-EDITOR))
-                                              (OBJECT-FROM-LABEL (WEB-EDITOR))
-                                              (CHANGE-FONT-SIZE (WEB-EDITOR))
-                                              (CHANGE-FORMAT (WEB-EDITOR))
-                                              (CHANGE-MAX-LABEL-SIZE (WEB-EDITOR))
-                                              (SHAPE-TO-HOLD (WEB-EDITOR))
-                                                             (IL:* IL:\; "")
-                                                             (IL:* IL:\; 
-                                                           "Node Marking and Selecting")
-                                              (GET-DISPLAY-LABEL (WEB-EDITOR))
-                                              (BOX-NODE (WEB-EDITOR))
-                                              (UNMARK-NODES (WEB-EDITOR))
-                                              (HIGHLIGHT-NODE (WEB-EDITOR))
-                                              (SHADE-NODE (WEB-EDITOR))
-                                              (DISPLAY-NODE-HIGHTLIGHTS (WEB-EDITOR))
-                                              (DISPLAY-NODE-SHADING (WEB-EDITOR))
-                                              (REMOVE-HIGHLIGHTS (WEB-EDITOR))
-                                              (REMOVE-SHADING (WEB-EDITOR))
-                                              (FLASH-NODE (WEB-EDITOR))
-                                              (FLIP-NODE (WEB-EDITOR))
-                                              (POSITION-NODE (WEB-EDITOR)))
-                                       (FNS BOX-PRINT-STRING BREAK-STRING-FOR-BOXING BOX-WINDOW-NODE)
-                                       )
-                                 (COMS                       (IL:* IL:\; "Button Events")
-                                       (FNS FIND-SELECTED-NODE)
-                                       (METHODS (BUTTON-EVENT-FN (WEB-EDITOR))
-                                              (LEFT-SELECTION (WEB-EDITOR))
-                                              (MIDDLE-SELECTION (WEB-EDITOR))
-                                              (RIGHT-SELECTION (WEB-EDITOR))
-                                              (TITLE-SELECTION (WEB-EDITOR))
-                                              (NODE-SELECTION (WEB-EDITOR))
-                                              (NODE-ACTION (WEB-EDITOR))
-                                              (NODE-MENU-ITEMS (WEB-NODE))
-                                              
-                                              (IL:* IL:|;;| "")
-
-                                              (CHOICE-MENU (WEB-EDITOR))
-                                              (DO-SELECTED-COMMAND (WEB-EDITOR))
-                                              (WHEN-MENU-ITEM-HELD (WEB-EDITOR))
-                                              (ITEM-MENU (WEB-EDITOR))
-                                              (GET-MENU-ITEMS (WEB-EDITOR))
-                                              (CLEAR-MENU-CACHE (WEB-EDITOR)))
-                                       (FNS WEB-MENU-WHENSELECTEDFN WINDOW-WHEN-HELD-FN)
-                                       (FNS SUB-ITEM-SELECTION DUAL-SUB-ITEMS WINDOW-WHEN-HELD-FN 
-                                            DO-MENU-METHOD DUAL-MENU DUAL-SELECTION)
-                                                             (IL:* IL:\; "Node Moving Protocol")
-                                       (METHODS (NODE-MOVE (WEB-EDITOR))
-                                              (NODE-MOVE-SHALLOW (WEB-EDITOR))
-                                              (SCIONS (WEB-NODE))
-                                              (MAKE-REG-ASSOC (WEB-EDITOR))
-                                              (REORDER-TREE (WEB-EDITOR))
-                                              (MOVE-NODE (WEB-NODE))))
-                                                             (IL:* IL:\; "")
-                                 
-                                 (IL:* IL:|;;| "")
-
-                                 (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY 
-                                        IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA)
-                                                               (IL:NLAML)
-                                                               (IL:LAMA WINDOW-WHEN-HELD-FN 
-                                                                      WINDOW-WHEN-HELD-FN)))))
-
-(IL:RPAQQ FILE-HEADER-COMS ((IL:P (FORMAT T 
-                       "~&;WEB-EDITOR Copyright (c) 1987, VENUE Corporation.  All rights reserved.~%"
-                                             )
-                                      (PROVIDE "WEB-EDITOR"))))
-
-(FORMAT T "~&;WEB-EDITOR Copyright (c) 1987, VENUE Corporation.  All rights reserved.~%")
-
-(PROVIDE "WEB-EDITOR")
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;;| "WEB EDITOR ")
-
-
-
-
-(IL:* IL:|;;| "")
-
-
-
-
-(IL:* IL:|;;| "Package Setup")
-
-(IL:DECLARE\: IL:DONTCOPY 
-
-(IL:PUTPROPS IL:WEB-EDITOR IL:MAKEFILE-ENVIRONMENT 
-             (:PACKAGE (LET ((*PACKAGE*))
-                            
-                            (IL:* IL:|;;| "Put IN Seven EXtremely Random USEr Interface COmmands ")
-
-                            (PROVIDE "WEB-EDITOR")
-                            (IN-PACKAGE "WEB" :NICKNAMES '("WEB-EDITOR"))
-                            
-                            (IL:* IL:|;;| "EXPORT")
-
-                            (FLET ((XCL-USER::EXPORT-FROM-WEB (&REST XCL-USER::SYMBOL-NAMES)
-                                          (LET ((XCL-USER::PKG (FIND-PACKAGE "WEB")))
-                                               (DOLIST (XCL-USER::NAME XCL-USER::SYMBOL-NAMES)
-                                                   (EXPORT (INTERN XCL-USER::NAME XCL-USER::PKG)
-                                                          XCL-USER::PKG)))))
-                                  
-                                  (IL:* IL:|;;| "Class Definitions and Slot Access")
-
-                                  (XCL-USER::EXPORT-FROM-WEB "WEB-EDITOR" "WEB-NODE" "NODE-NAME" 
-                                         "NODE-LINKS" "NODE-BACK-LINKS" "LOCAL-COMMANDS" 
-                                         "NODE-MOVER-P" "TITLE-ITEMS" "LEFT-BUTTON-ITEMS" 
-                                         "MIDDLE-BUTTON-ITEMS" "RIGHT-BUTTON-ITEMS" "BROWSE-FONT")
-                                  
-                                  (IL:* IL:|;;| "For Subclassing")
-
-                                  (XCL-USER::EXPORT-FROM-WEB "GET-LABEL" "GET-SUBS" "ICON-TITLE" 
-                                         "NODE-MENU-ITEMS" "REORDER-TREE" "MOVE-NODE")
-                                  
-                                  (IL:* IL:|;;| "Top Level")
-
-                                  (XCL-USER::EXPORT-FROM-WEB "MAKE-WEB-EDITOR" "INITIALIZE-EDITOR" 
-                                         "BROWSE" "DISPLAY-BROWSER" "DESTROY" "ADD-NODE" 
-                                         "NOTICE-NODE" "REMOVE-NODE" "RENAME-NODE")
-                                  
-                                  (IL:* IL:|;;| "Window Operations")
-
-                                  (XCL-USER::EXPORT-FROM-WEB "SHRINK" "MOVE" "CLEAR" "PROMPT-PRINT" 
-                                         "PROMPT-READ" "PROMPT-FOR-LIST" "PROMPT-FOR-STRING" 
-                                         "PROMPT-FOR-WORD")
-                                  
-                                  (IL:* IL:|;;| "Recomputing and Changing parameters")
-
-                                  (XCL-USER::EXPORT-FROM-WEB "RECOMPUTE" "RECOMPUTE-IN-PLACE" 
-                                         "RECOMPUTE-LABELS" "RECOMPUTE-IF-OPEN" "CLEAR-LABEL-CACHE" 
-                                         "CHANGE-FONT-SIZE" "CHANGE-FORMAT" "SHAPE-TO-HOLD")
-                                  
-                                  (IL:* IL:|;;| "For CLOS-BROWSER???")
-
-                                  (XCL-USER::EXPORT-FROM-WEB "BOXED-NODE" "BOX-NODE"))
-                            
-                            (IL:* IL:|;;| "USE")
-
-                            (USE-PACKAGE '("CLOS" "LISP" "XCL")
-                                   "WEB")
-                            
-                            (IL:* IL:|;;| "IMPORT")
-
-                            (FLET ((XCL-USER::IMPORT-FROM-PACKAGE
-                                    (XCL-USER::NAMES XCL-USER::FROM &OPTIONAL XCL-USER::SHADOW-P)
-                                    (LET ((XCL-USER::FROM-PACKAGE (FIND-PACKAGE XCL-USER::FROM)))
-                                         (FUNCALL (IF XCL-USER::SHADOW-P
-                                                      #'SHADOWING-IMPORT
-                                                      #'IMPORT)
-                                                (MAPCAR #'(LAMBDA (XCL-USER::NAME)
-                                                                 (INTERN XCL-USER::NAME 
-                                                                        XCL-USER::FROM-PACKAGE))
-                                                       XCL-USER::NAMES)))))
-                                  (XCL-USER::IMPORT-FROM-PACKAGE '("CLASSES" "METHODS")
-                                         "CLOS")
-                                  (XCL-USER::IMPORT-FROM-PACKAGE '("FALSE")
-                                         "XCL")
-                                  (XCL-USER::IMPORT-FROM-PACKAGE '("FUNCTIONS" "FNS" "VARIABLES" 
-                                                                         "VARS" "BITMAPS" "COMS")
-                                         "IL"))
-                            (FIND-PACKAGE "WEB"))
-                    :READTABLE "XCL" :BASE 10))
-
-(IL:PUTPROPS IL:WEB-EDITOR IL:FILETYPE :COMPILE-FILE)
-)
-
-
-
-(IL:* IL:|;;| "Global Variables")
-
-
-
-
-(IL:* IL:|;;| 
-"global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)"
-)
-
-
-(DEFGLOBALPARAMETER DESTINATION-BROWSER NIL
-   "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)"
-)
-
-
-
-(IL:* IL:\; "Client Interface")
-
-
-
-
-(IL:* IL:|;;| "Web Node Class")
-
-
-(DEFCLASS WEB-NODE ()
-    ((NAME :INITFORM NIL                                     (IL:* IL:\; "Name of Node")
-           :ACCESSOR NODE-NAME)
-     (TO-LINKS :INITFORM NIL                                 (IL:* IL:\; 
-                                                           "Nodes that this Node has Links TO")
-            :ACCESSOR GET-TO-LINKS :ACCESSOR NODE-LINKS)
-     (PARENT :INITFORM NIL :ACCESSOR NODE-BACK-LINKS)))
-
-
-
-(IL:* IL:|;;| " Web Editor  Class")
-
-
-(DEFCLASS WEB-EDITOR ()
-    (
-     (IL:* IL:|;;| "NODES ")
-
-     (STARTING-LIST :INITFORM NIL                            (IL:* IL:\; 
-                                                     "list of objects used to compute this browser")
-            )
-     (GOOD-LIST :INITFORM NIL                                (IL:* IL:\; 
-                                                           "limit choices to this set"))
-     (BAD-LIST :INITFORM NIL                                 (IL:* IL:\; 
-                                                           "Don't put in any items on this set")
-            )
-
-     (IL:* IL:|;;| "GRAPHER FORMAT")
-
-     (TOP-ALIGN :INITFORM NIL)
-     (BROWSE-FONT :INITFORM (IL:FONTCREATE '(IL:HELVETICA 10 IL:BOLD)))
-     (BROWSE-FONT-FAMILY :INITFORM 'IL:HELVETICA)
-     (BROWSE-FONT-FACE :INITFORM 'IL:BOLD)
-     (GRAPH-FORMAT :INITFORM '(IL:LATTICE))
-     (GRAPH-FORMAT-CHOICES :ALLOCATION :CLASS :INITFORM '((IL:HORIZONTAL/LATTICE '(IL:LATTICE))
-                                                          (IL:VERTICAL/LATTICE '(IL:VERTICAL 
-                                                                                       IL:LATTICE))
-                                                          (IL:HORIZONTAL/TREE '(IL:COPIES/ONLY))
-                                                          (IL:VERTICAL/TREE '(IL:VERTICAL 
-                                                                                    IL:COPIES/ONLY)))
-            )
-
-     (IL:* IL:|;;| "WINDOW Interface")
-
-     (WINDOW :INITFORM NIL)
-     (TITLE :INITFORM "Web Editor"                           (IL:* IL:\; 
-                                                        "If not NIL will be put in title of window")
-            )
-     (LEFT :INITFORM 0                                       (IL:* IL:\; "left position of window")
-           )
-     (BOTTOM :INITFORM 0                                     (IL:* IL:\; 
-                                                           "bottom position of window"))
-     (WIDTH :INITFORM 64)
-     (HEIGHT :INITFORM 32)
-
-     (IL:* IL:|;;| "NODE Labels")
-
-     (LABEL-CACHE :INITFORM NIL)
-     (LABEL-MAX-LINES :INITFORM NIL 
-
-            (IL:* IL:|;;| "the maximum number of lines to use in 'boxed' labels -- note that if the label wont fit within the LabelMaxLines and LabelMaxCharsWidth restrictions, it will be truncated")
-)
-     (LABEL-MAX-CHARS-WIDTH :INITFORM NIL 
-
-            (IL:* IL:|;;| "the maximum width for labels -- if label is too big, it will be 'boxed'")
-)
-     (IL:* IL:|;;| "NODE Operations")
-
-     (LAST-SELECTED-OBJECT :INITFORM NIL                     (IL:* IL:\; "last object selected"))
-     (BOXED-NODE :INITFORM NIL                               (IL:* IL:\; "last item Boxed, if any")
-            )
-     (BOX-LINE-WIDTH :ALLOCATION :CLASS 
-
-            (IL:* IL:|;;| "width to make box for BoxNode")
-
-            :INITFORM 1)
-     (NODE-MOVER-P :ALLOCATION :CLASS :INITFORM NIL)
-
-     (IL:* IL:|;;| "MENUS")
-
-     (CACHE-MENU-P :INITFORM T)
-     (MENU-CACHE :INITFORM NIL                               (IL:* IL:\; 
-                                                       "Will Cache Menus only if CACHE-MENU-P is T")
-            )
-     (LOCAL-COMMANDS :ALLOCATION :CLASS 
-
-            (IL:* IL:|;;| "messages that should be sent to browser when item seleted in menu, even if object does understand them")
-
-            :INITFORM
-            '(BOX-NODE RECOMPUTE ADD-ROOT))
-     (TITLE-ITEMS :ALLOCATION :CLASS 
-
-            (IL:* IL:|;;| "Items for menu of selections in title of window")
-
-            :INITFORM
-            '(("Recompute" RECOMPUTE "" (IL:SUBITEMS ("Recompute" RECOMPUTE 
-                                                            "Recompute lattice from starting objects"
-                                                            )
-                                               ("Recompute Labels" RECOMPUTE-LABELS 
-                                                      "Recomputes the labels")
-                                               ("Recompute In Place" RECOMPUTE-IN-PLACE 
-                                                      "Recompute keeping current view in window")))
-              ("Shape To Hold" SHAPE-TO-HOLD "Make window large or small enough to just hold graph")
-              ("Change Font Size" CHANGE-FONT-SIZE "Choose a new size Font")
-              ("Change Format" CHANGE-FORMAT "Change format between lattice and tree")))
-     (LEFT-BUTTON-ITEMS :ALLOCATION :CLASS 
-
-            (IL:* IL:|;;| "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see LocalCommands")
-
-            :INITFORM
-            '(("Box Node" BOX-NODE "Draw box around selected node.
-Unboxed by another BoxNode")
-              ("Pretty Print" PP "Prettyprint selected item")))
-     (MIDDLE-BUTTON-ITEMS :ALLOCATION :CLASS 
-
-            (IL:* IL:|;;| "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see LocalCommands")
-
-            :INITFORM
-            '(("Inspect" IL:|Inspect| INSPECT "Inspect selected item")
-              ("Edit" EDIT-OBJECT "Edit selected item")
-              ("Delete From Browser" DELETE-FROM-BROWSER "Do not show item or its subs")))
-     (RIGHT-BUTTON-ITEMS :ALLOCATION :CLASS :INITFORM '(("Close" (CLOSEW (("Close" CLOSEW)
-                                                                          ("Destroy" DESTROY))))
-                                                        ("Snap" SNAP)
-                                                        ("Paint" PAINT)
-                                                        ("Clear" CLEAR)
-                                                        ("Bury" BURY)
-                                                        ("Repaint" REPAINT)
-                                                        ("Hardcopy" (HARDCOPY (("Hardcopy to File"
-                                                                                HARDCOPY-TO-FILE)
-                                                                               ("Hardcopy to Printer"
-                                                                                HARDCOPY-TO-PRINTER))
-                                                                           ))
-                                                        ("Move" MOVE)
-                                                        ("Shape" SHAPE)
-                                                        ("Shrink" SHRINK))
-                                                             (IL:* IL:\; 
-                                                     "Items to be done if Right button is selected")
-            )))
-
-
-
-(IL:* IL:|;;| "Top Level")
-
-
-(DEFUN MAKE-WEB-EDITOR ()
-   (LET ((EDITOR (MAKE-INSTANCE 'WEB-EDITOR)))
-        (INITIALIZE-EDITOR EDITOR)))
-
-(DEFMETHOD INITIALIZE-EDITOR ((SELF WEB-EDITOR))
-   (LET NIL (CREATE-WINDOW SELF)
-        SELF))
-
-(DEFMETHOD DESTROY ((SELF WEB-EDITOR))
-   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))
-          (ICON-WINDOW (IL:WINDOWPROP WINDOW 'IL:ICONWINDOW)))
-         (IL:CLOSEW WINDOW)
-         (IF ICON-WINDOW (IL:CLOSEW ICON-WINDOW))
-         (DETACH-LISP-WINDOW SELF)))
-
-(DEFMETHOD BROWSE ((SELF WEB-EDITOR)
-                       &OPTIONAL BROWSE-LIST WINDOW-OR-TITLE GOOD-LIST POSITION)
-                                                             (IL:* IL:\; "11-Sep-84 07:24")
-                                                             (IL:* IL:\; 
-                                         "Call Show and then shape to hold and move for first time")
-   (COND
-      ((IL:WINDOWP WINDOW-OR-TITLE)
-       (SETF (SLOT-VALUE SELF 'WINDOW)
-             WINDOW-OR-TITLE))
-      (WINDOW-OR-TITLE (SETF (SLOT-VALUE SELF 'TITLE)
-                             WINDOW-OR-TITLE)))
-   (COND
-      ((AND BROWSE-LIST (IL:NLISTP BROWSE-LIST))
-       (IL:SETQ BROWSE-LIST (LIST BROWSE-LIST))))
-   (SETF (SLOT-VALUE SELF 'STARTING-LIST)
-         BROWSE-LIST)
-   (SETF (SLOT-VALUE SELF 'GOOD-LIST)
-         GOOD-LIST)
-   (DISPLAY-BROWSER SELF)
-   (SHAPE-TO-HOLD SELF)
-   (MOVE SELF POSITION)
-   SELF)
-
-(DEFMETHOD GET-LABEL ((WEB-EDITOR WEB-EDITOR)
-                          (NODE WEB-NODE))                   (IL:* IL:\; 
-                                        "Get a label for an object to be displayed in the browser.")
-   (NODE-NAME NODE))
-
-(DEFMETHOD GET-SUBS ((EDITOR WEB-EDITOR)
-                         (NODE WEB-NODE))                    (IL:* IL:\; 
-                                                   "Gets a set of subs from an object for browsing")
-   (NODE-LINKS NODE))
-
-(DEFMETHOD ICON-TITLE ((SELF WEB-EDITOR))                (IL:* IL:\; "18-Jan-85 15:35")
-
-   (IL:* IL:|;;| "Compute the icont title for this browser")
-
-   '|Web Editor|)
-
-(DEFMETHOD ADD-NODE ((WEB-EDITOR WEB-EDITOR)
-                         (NEW-NODE WEB-NODE))                (IL:* IL:\; "11-Dec-86 10:23")
-
-   (IL:* IL:|;;| "Add a new node to the browser.")
-
-   (PUSHNEW NEW-NODE (SLOT-VALUE WEB-EDITOR 'STARTING-LIST))
-   (IF (SLOT-VALUE WEB-EDITOR 'GOOD-LIST)
-       (PUSHNEW NEW-NODE (SLOT-VALUE WEB-EDITOR 'GOOD-LIST))))
-
-(DEFMETHOD NOTICE-NODE ((WEB-EDITOR WEB-EDITOR)
-                            (WEB-NODE WEB-NODE)
-                            (PARENT-NODE WEB-NODE))
-   (PUSH WEB-NODE (SLOT-VALUE PARENT-NODE 'TO-LINKS))
-   (ADD-NODE WEB-EDITOR WEB-NODE))
-
-(DEFMETHOD REMOVE-NODE ((WEB-EDITOR WEB-EDITOR)
-                            (BYE-NODE WEB-NODE))
-   (WITH-SLOTS (STARTING-LIST GOOD-LIST BAD-LIST)
-       WEB-EDITOR
-
-     (IL:* IL:|;;| "")
-
-     (SETF STARTING-LIST (DELETE BYE-NODE STARTING-LIST))
-     (IF GOOD-LIST
-         (SETF GOOD-LIST (DELETE BYE-NODE GOOD-LIST)))
-     (IF BAD-LIST
-         (SETF BAD-LIST (DELETE BYE-NODE BAD-LIST)))
-     (SETF (NODE-LINKS (NODE-BACK-LINKS BYE-NODE))
-           (DELETE BYE-NODE (NODE-LINKS (NODE-BACK-LINKS BYE-NODE))))))
-
-(DEFMETHOD DELETE-FROM-BROWSER ((SELF WEB-EDITOR)
-                                    OBJ OBJ-NAME)            (IL:* IL:\; " 5-Aug-86 16:50")
-
-   (IL:* IL:|;;| "Place on badList for Browser")
-
-   (PUSHNEW OBJ (SLOT-VALUE SELF 'BAD-LIST))
-   (RECOMPUTE SELF))
-
-(DEFMETHOD REMOVE-FROM-BAD-LIST ((SELF WEB-EDITOR))      (IL:* IL:\; "28-Dec-85 10:04")
-                                                             (IL:* IL:\; 
-                               "Remove an item from BadList to allow it to be displayed once again")
-   (COND
-      ((NULL (SLOT-VALUE SELF 'BAD-LIST))
-       (IL:CLRPROMPT)
-       (IL:PROMPTPRINT "No BadList items."))
-      (T (PROG ((IL:|item| (IL:MENU (IL:|create| IL:MENU
-                                           IL:TITLE IL:_ "BadList Items"
-                                           IL:ITEMS IL:_ (SLOT-VALUE SELF 'BAD-LIST)))))
-               (COND
-                  (IL:|item| (SETF (SLOT-VALUE SELF 'BAD-LIST)
-                                   '(IL:DREMOVE IL:|item| (SLOT-VALUE SELF 'BAD-LIST)))
-                         (RECOMPUTE SELF))
-                  (T (IL:CLRPROMPT)
-                     (IL:PROMPTPRINT "Nothing Selected")))))))
-
-(DEFMETHOD RENAME-NODE ((WEB-EDITOR WEB-EDITOR)
-                            (WEB-NODE WEB-NODE)
-                            NEW-NAME)
-   (SETF (NODE-NAME WEB-NODE)
-         NEW-NAME)
-   (CLEAR-LABEL-CACHE WEB-EDITOR WEB-NODE))
-
-
-
-(IL:* IL:\; "")
-
-
-
-
-(IL:* IL:\; "Window System Interface")
-
-
-(DEFMETHOD UPDATE ((SELF WEB-EDITOR))                    (IL:* IL:\; "29-Sep-86 11:56")
-
-   (IL:* IL:|;;| "make the Lisp window be consistent with ivs")
-
-   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))
-          (REGION (AND (SLOT-VALUE SELF 'WIDTH)
-                       (SLOT-VALUE SELF 'HEIGHT)
-                       (IL:|create| IL:REGION
-                              IL:LEFT IL:_ (OR (SLOT-VALUE SELF 'LEFT)
-                                               (SETF (SLOT-VALUE SELF 'LEFT)
-                                                     IL:LASTMOUSEX))
-                              IL:BOTTOM IL:_ (OR (SLOT-VALUE SELF 'BOTTOM)
-                                                 (SETF (SLOT-VALUE SELF 'BOTTOM)
-                                                       IL:LASTMOUSEY))
-                              IL:WIDTH IL:_ (SLOT-VALUE SELF 'WIDTH)
-                              IL:HEIGHT IL:_ (SLOT-VALUE SELF 'HEIGHT)))))
-         (COND
-            ((AND REGION (NOT (IL:EQUAL REGION (IL:WINDOWPROP WINDOW 'IL:REGION))))
-                                                             (IL:* IL:\; 
-                      "The shape has changed.  --- This is complicated because of ATTACHEDWINDOWS.")
-             (LET* ((ATTACHED-WINDOWS (IL:WINDOWPROP WINDOW 'IL:ATTACHEDWINDOWS))
-                    (ATTACHMENT-SPECS (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS
-                                         IL:|collect| (LIST (IL:WINDOWPROP IL:\w 
-                                                                       'IL:DOWINDOWCOMFN)
-                                                                (IL:WINDOWPROP IL:\w 
-                                                                       'IL:WHEREATTACHED)
-                                                                (IL:WINDOWPROP IL:\w 
-                                                                       'IL:PASSTOMAINCOMS)))))
-                   (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS IL:|do| (IL:DETACHWINDOW
-                                                                                 IL:\w))
-                   (IL:SHAPEW WINDOW REGION)
-                   (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS IL:|as| IL:|spec|
-                      IL:|in| ATTACHMENT-SPECS IL:|do| (IL:ATTACHWINDOW IL:\w WINDOW
-                                                                      (CAADR IL:|spec|)
-                                                                      (CDADR IL:|spec|))
-                                                         (IL:WINDOWPROP IL:\w 'IL:DOWINDOWCOMFN
-                                                                (CAR IL:|spec|))
-                                                         (IL:WINDOWPROP IL:\w 'IL:PASSTOMAINCOMS
-                                                                (CADDR IL:|spec|))))))
-         (AND (NOT (IL:EQUAL (SLOT-VALUE SELF 'TITLE)
-                          (IL:WINDOWPROP WINDOW 'IL:TITLE)))
-              (IL:WINDOWPROP WINDOW 'IL:TITLE (SLOT-VALUE SELF 'TITLE)))))
-
-(DEFMETHOD CREATE-WINDOW ((SELF WEB-EDITOR))             (IL:* IL:\; "10-Apr-86 14:32")
-                                                             (IL:* IL:\; 
-                                        "Create the Lisp window for this window but don't open it.")
-   (LET ((WINDOW (IL:CREATEW (IL:CREATEREGION IL:LASTMOUSEX IL:LASTMOUSEY 25 25)
-                        (SLOT-VALUE SELF 'TITLE)
-                        NIL T)))
-        (SETF (SLOT-VALUE SELF 'WINDOW)
-              WINDOW)
-        (SETUP-WINDOW SELF)
-        WINDOW))
-
-(DEFMETHOD SETUP-WINDOW ((SELF WEB-EDITOR))              (IL:* IL:\; "10-Apr-86 14:32")
-                                                             (IL:* IL:\; 
-                                        "Create the Lisp window for this window but don't open it.")
-   (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW)))
-        (IL:WINDOWPROP WINDOW 'WEB-EDITOR SELF)
-        (IL:WINDOWPROP WINDOW 'IL:ICONFN 'WEB-WINDOW-ICON-FN)
-        (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'WEB-WINDOW-BUTTON-EVENT-FN)
-        (IL:WINDOWADDPROP WINDOW 'IL:AFTERMOVEFN 'WEB-WINDOW-AFTER-MOVE-FN)
-        (IL:WINDOWADDPROP WINDOW 'IL:RESHAPEFN 'WEB-WINDOW-RESHAPE-FN)
-        (IL:WINDOWADDPROP WINDOW 'IL:CLOSEFN 'WEB-WINDOW-CLOSE-FN)
-        (IL:WINDOWPROP WINDOW 'IL:ICONFN 'WEB-WINDOW-ICON-FN)(IL:* IL:\; 
-                                        "window should be invert so that links etc.  can be erased")
-        (IL:DSPOPERATION 'IL:INVERT WINDOW)                  (IL:* IL:\; 
-                                           "kludge: because GRAPHER adds its own COPYBUTTONEVENTFN")
-        (IL:WINDOWPROP WINDOW 'IL:COPYBUTTONEVENTFN NIL)
-        (IL:WINDOWPROP WINDOW 'IL:TITLE (SLOT-VALUE SELF 'TITLE))
-        WINDOW))
-
-(DEFMETHOD DETACH-LISP-WINDOW ((SELF WEB-EDITOR))        (IL:* IL:\; " 8-Apr-87 17:25")
-
-(IL:* IL:|;;;| "Forget about the current lisp window")
-
-   (LET ((VAL (SLOT-VALUE SELF 'WINDOW)))
-        (IL:|if| (IL:WINDOWP VAL)
-            IL:|then| (SETF (SLOT-VALUE SELF 'WINDOW)
-                                NIL)
-                  (IL:WINDOWPROP VAL 'WEB-EDITOR NIL)
-                  (IL:WINDOWPROP VAL 'IL:RIGHTBUTTONFN NIL)
-                  (IL:WINDOWPROP VAL 'IL:BUTTONEVENTFN NIL)
-                  NIL
-          IL:|else| NIL)))
-
-(DEFMETHOD SHRINK ((SELF WEB-EDITOR)
-                       &OPTIONAL TOWHAT POS EXPANDFN)
-   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)))
-         (IF (IL:WINDOWP WINDOW)
-             (IL:SHRINKW WINDOW TOWHAT POS EXPANDFN))))
-
-(DEFMETHOD SET-OUTER-REGION ((SELF WEB-EDITOR)
-                                 REGION NO-UPDATE-FLG)       (IL:* IL:\; "16-Apr-86 13:21")
-
-(IL:* IL:|;;;| "Make Loops Window have region parameters")
-
-   (SETF (SLOT-VALUE SELF 'LEFT)
-         (IL:|fetch| IL:LEFT IL:|of| REGION))
-   (SETF (SLOT-VALUE SELF 'BOTTOM)
-         (IL:|fetch| IL:BOTTOM IL:|of| REGION))
-   (SETF (SLOT-VALUE SELF 'WIDTH)
-         (IL:|fetch| IL:WIDTH IL:|of| REGION))
-   (SETF (SLOT-VALUE SELF 'HEIGHT)
-         (IL:|fetch| IL:HEIGHT IL:|of| REGION))
-   (IL:|if| (NOT NO-UPDATE-FLG)
-       IL:|then| (UPDATE SELF))
-   REGION)
-
-(DEFMETHOD SET-REGION ((SELF WEB-EDITOR)
-                           REGION &OPTIONAL NO-UPDATE-FLG)   (IL:* IL:\; "16-Apr-86 13:22")
-
-(IL:* IL:|;;;| "Make Loops Window have region parameters")
-
-   (SET-OUTER-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION)
-                                 (IL:|fetch| IL:BOTTOM IL:|of| REGION)
-                                 (IL:WIDTHIFWINDOW (IL:|fetch| IL:WIDTH IL:|of| REGION)
-                                        (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW)
-                                               'IL:BORDER))
-                                 (IL:HEIGHTIFWINDOW (IL:|fetch| IL:HEIGHT IL:|of| REGION)
-                                        (SLOT-VALUE SELF 'TITLE)
-                                        (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW)
-                                               'IL:BORDER)))
-          NO-UPDATE-FLG))
-
-(DEFMETHOD MOVE ((SELF WEB-EDITOR)
-                     X-OR-POS &OPTIONAL Y)                   (IL:* IL:\; "11-Sep-86 13:24")
-
-(IL:* IL:|;;;| "Move the window")
-
-   (MOVE1 SELF (OR X-OR-POS (LET* ((ENTIRE-REGION (IL:WINDOWREGION (SLOT-VALUE SELF 'WINDOW)))
-                                   (POS (IL:GETBOXPOSITION (IL:|fetch| IL:WIDTH IL:|of|
-                                                                                    ENTIRE-REGION)
-                                               (IL:|fetch| IL:HEIGHT IL:|of| ENTIRE-REGION)
-                                               (IL:|fetch| IL:LEFT IL:|of| ENTIRE-REGION)
-                                               (IL:|fetch| IL:BOTTOM IL:|of| ENTIRE-REGION)))
-                                   )
-                                  (IL:|create| IL:POSITION
-                                         IL:XCOORD IL:_ (IL:PLUS (IL:|fetch| IL:XCOORD
-                                                                    IL:|of| POS)
-                                                               (IL:DIFFERENCE (SLOT-VALUE
-                                                                               SELF
-                                                                               'LEFT)
-                                                                      (IL:|fetch| IL:LEFT
-                                                                         IL:|of| ENTIRE-REGION)))
-                                         IL:YCOORD IL:_ (IL:PLUS (IL:|fetch| IL:YCOORD
-                                                                    IL:|of| POS)
-                                                               (IL:DIFFERENCE (SLOT-VALUE
-                                                                               SELF
-                                                                               'BOTTOM)
-                                                                      (IL:|fetch| IL:BOTTOM
-                                                                         IL:|of| ENTIRE-REGION)))
-                                         )))
-          Y))
-
-(DEFMETHOD MOVE1 ((SELF WEB-EDITOR)
-                      X-OR-POS &OPTIONAL Y)                  (IL:* IL:\; "13-Aug-86 19:10")
-
-   (IL:* IL:|;;| "Move the window")
-
-   (LET ((NEEDS-UPDATE? (NOT (IL:SUBREGIONP (IL:CONSTANT (IL:CREATEREGION 0 0 IL:SCREENWIDTH 
-                                                                IL:SCREENHEIGHT))
-                                    (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW)
-                                           'IL:REGION)))))
-        (PROG1 (IL:MOVEW (SLOT-VALUE SELF 'WINDOW)
-                      X-OR-POS Y)                            (IL:* IL:\; 
-                                      "The left and right IVs are updated by the message AfterMove")
-            (COND
-               (NEEDS-UPDATE? (UPDATE SELF))))))
-
-(DEFMETHOD AFTER-MOVE ((SELF WEB-EDITOR))                (IL:* IL:\; "10-Apr-86 16:10")
-
-(IL:* IL:|;;;| "The window has been moved.  Update the left and bottom")
-
-   (LET ((REGION (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW)
-                        'IL:REGION)))
-        (SETF (SLOT-VALUE SELF 'LEFT)
-              (IL:|fetch| IL:LEFT IL:|of| REGION))
-        (SETF (SLOT-VALUE SELF 'BOTTOM)
-              (IL:|fetch| IL:BOTTOM IL:|of| REGION))))
-
-(DEFMETHOD AFTER-RESHAPE ((SELF WEB-EDITOR)
-                              OLD-BITMAP-IMAGE OLD-REGION OLD-SCREEN-REGION)
-                                                             (IL:* IL:\; "10-Apr-86 16:12")
-
-(IL:* IL:|;;;| "The window has been reshaped")
-
-   (LET ((REGION (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW)
-                        'IL:REGION)))
-        (SETF (SLOT-VALUE SELF 'LEFT)
-              (IL:|fetch| IL:LEFT IL:|of| REGION))
-        (SETF (SLOT-VALUE SELF 'BOTTOM)
-              (IL:|fetch| IL:BOTTOM IL:|of| REGION))
-        (SETF (SLOT-VALUE SELF 'WIDTH)
-              (IL:|fetch| IL:WIDTH IL:|of| REGION))
-        (SETF (SLOT-VALUE SELF 'HEIGHT)
-              (IL:|fetch| IL:HEIGHT IL:|of| REGION))
-        (IL:RESHAPEBYREPAINTFN (SLOT-VALUE SELF 'WINDOW)
-               OLD-BITMAP-IMAGE OLD-REGION OLD-SCREEN-REGION)))
-
-(DEFMETHOD SCROLL-WINDOW ((SELF WEB-EDITOR)
-                              DSP-X DSP-Y WINDOW-X WINDOW-Y) (IL:* IL:\; "10-Apr-86 14:58")
-
-(IL:* IL:|;;;| "scroll the window to set the point dspX,dspY in the given window position -- default is the lower left corner.  If any x or y is a FIXP, it is treated as a absolute position.  If FLOATP, it is treated as a relative position.  Return the position of the new lower left corner.")
-
-   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))
-          (VISIBLE-REGION (IL:DSPCLIPPINGREGION NIL WINDOW))
-          (EXTENT (IL:WINDOWPROP WINDOW 'IL:EXTENT)))        (IL:* IL:\; 
-                                          "figure out what to do with default and relative offsets")
-         (IL:SETQ WINDOW-X (IL:|if| (NULL WINDOW-X)
-                               IL:|then| 0
-                             IL:|elseif| (IL:FLOATP WINDOW-X)
-                               IL:|then| (IL:FIX (IL:TIMES WINDOW-X (IL:WINDOWPROP WINDOW
-                                                                               'IL:WIDTH)))
-                             IL:|else| WINDOW-X))
-         (IL:SETQ WINDOW-Y (IL:|if| (NULL WINDOW-Y)
-                               IL:|then| 0
-                             IL:|elseif| (IL:FLOATP WINDOW-Y)
-                               IL:|then| (IL:FIX (IL:TIMES WINDOW-Y (IL:WINDOWPROP WINDOW
-                                                                               'IL:HEIGHT)))
-                             IL:|else| WINDOW-Y))
-         (IL:SETQ DSP-X (IL:|if| (NULL DSP-X)
-                            IL:|then| (IL:|fetch| IL:LEFT IL:|of| VISIBLE-REGION)
-                          IL:|elseif| (IL:FLOATP DSP-X)
-                            IL:|then| (IL:FIX (IL:TIMES DSP-X (IL:|fetch| IL:WIDTH
-                                                                     IL:|of| EXTENT)))
-                          IL:|else| DSP-X))
-         (IL:SETQ DSP-Y (IL:|if| (NULL DSP-Y)
-                            IL:|then| (IL:IMINUS (IL:|fetch| IL:BOTTOM IL:|of| 
-                                                                                     VISIBLE-REGION))
-                          IL:|elseif| (IL:FLOATP DSP-Y)
-                            IL:|then| (IL:FIX (IL:TIMES DSP-Y (IL:|fetch| IL:HEIGHT
-                                                                     IL:|of| EXTENT)))
-                          IL:|else| DSP-Y))
-         (IL:SCROLLW WINDOW (IL:IPLUS WINDOW-X (IL:IDIFFERENCE (IL:|fetch| IL:LEFT IL:|of|
-                                                                                       VISIBLE-REGION
-                                                                      )
-                                                      DSP-X))
-                (IL:IPLUS WINDOW-Y (IL:IDIFFERENCE (IL:|fetch| IL:BOTTOM IL:|of| 
-                                                                                   VISIBLE-REGION)
-                                          DSP-Y)))           (IL:* IL:\; 
-                                                           "return the resulting position")
-         (IL:SETQ VISIBLE-REGION (IL:DSPCLIPPINGREGION NIL WINDOW))
-         (IL:|create| IL:POSITION
-                IL:XCOORD IL:_ (IL:|fetch| IL:LEFT IL:|of| VISIBLE-REGION)
-                IL:YCOORD IL:_ (IL:|fetch| IL:BOTTOM IL:|of| VISIBLE-REGION))))
-
-(DEFMETHOD CLEAR ((SELF WEB-EDITOR))                     (IL:* IL:\; 
-                                            "empty the window of active regions, return the window")
-   (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW)))
-        (IL:WINDOWPROP WINDOW 'IL:GRAPH NIL)
-        (IL:CLEARW WINDOW)
-        WINDOW))
-
-(DEFMETHOD GET-PROMPT-WINDOW ((SELF WEB-EDITOR)
-                                  &OPTIONAL LINES FONT-DEF)  (IL:* IL:\; " 8-Apr-87 15:43")
-
-   (IL:* IL:|;;| "Return the current prompt window")
-
-   (LET ((W (IL:GETPROMPTWINDOW (SLOT-VALUE SELF 'WINDOW)
-                   (OR LINES 2)
-                   (OR (IL:FONTCREATE FONT-DEF)))))
-        (IF FONT-DEF
-            (IL:DSPFONT (IL:FONTCREATE FONT-DEF)
-                   W))
-        W))
-
-(DEFMETHOD REMOVE-PROMPT-WINDOW ((SELF WEB-EDITOR))      (IL:* IL:\; " 8-Apr-87 15:43")
-   (IL:REMOVEPROMPTWINDOW (SLOT-VALUE SELF 'WINDOW)))
-
-(DEFMETHOD PROMPT-PRINT ((SELF WEB-EDITOR)
-                             PROMPT)                         (IL:* IL:\; "13-Aug-86 18:46")
-
-   (IL:* IL:|;;| "Prints out a prompt in an attached prompt window")
-
-   (IL:PRIN1 PROMPT (GET-PROMPT-WINDOW SELF)))
-
-(DEFMETHOD PROMPT-READ ((SELF WEB-EDITOR)
-                            MSG)                             (IL:* IL:\; "13-Aug-86 19:15")
-
-   (IL:* IL:|;;| "Prompt the user for some input, using an attached prompt window")
-
-   (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF)))
-        (IL:CLEARW P-WINDOW)
-        (PROG1 (IL:|PromptRead| MSG P-WINDOW T)
-            (IL:CLEARW P-WINDOW)
-            (IL:DETACHWINDOW P-WINDOW)
-            (IL:CLOSEW P-WINDOW))))
-
-(DEFMETHOD PROMPT-FOR-LIST ((SELF WEB-EDITOR)
-                                PROMPT-STR INITIAL-STRING)   (IL:* IL:\; " 8-Apr-87 16:44")
-
-(IL:* IL:|;;;| "Prompt user in prompt window for a list of words.")
-
-   (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF)))
-        (IL:RESETFORM (IL:TTYDISPLAYSTREAM P-WINDOW)
-               (IL:CLEARW P-WINDOW)
-               (IL:TTYIN PROMPT-STR NIL NIL '(IL:NORAISE)
-                      NIL NIL INITIAL-STRING))))
-
-(DEFMETHOD PROMPT-FOR-STRING ((SELF WEB-EDITOR)
-                                  PROMPT-STR INITIAL-STR)    (IL:* IL:\; "13-Aug-86 18:42")
-
-(IL:* IL:|;;;| "Prompt user in prompt window for a string.")
-
-   (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF))
-         VALUE)
-        (IL:RESETFORM (IL:TTYDISPLAYSTREAM P-WINDOW)
-               (IL:CLEARW P-WINDOW)
-               (SETQ VALUE (IL:TTYIN PROMPT-STR NIL NIL '(STRING IL:NORAISE)
-                                  NIL NIL INITIAL-STR))
-               (IL:CLEARW P-WINDOW))
-        (REMOVE-PROMPT-WINDOW SELF)
-        VALUE))
-
-(DEFMETHOD PROMPT-FOR-WORD ((SELF WEB-EDITOR)
-                                &OPTIONAL PROMPT-STR INITIAL-WORD)
-                                                             (IL:* IL:\; " 8-Apr-87 16:43")
-
-(IL:* IL:|;;;| "Prompt user in prompt window for a word.")
-
-   (CAR (PROMPT-FOR-LIST SELF PROMPT-STR INITIAL-WORD)))
-
-(DEFMACRO MOVE-DOWN-P ()
-   '(OR (IL:KEYDOWNP 'IL:MOVE)
-        (IL:SHIFTDOWNP 'IL:CTRL)))
-(IL:DEFINEQ
-
-(WEB-WINDOW-AFTER-MOVE-FN
-  (LAMBDA (WINDOW)                                  (IL:* IL:\; "Edited 13-Jul-87 15:59 by Rao")
-                                                             (IL:* IL:\; "10-Apr-86 16:16")
-
-(IL:* IL:|;;;| "The SimpleWindow AFTERMOVEFN")
-
-         (LET ((W (IL:WINDOWPROP WINDOW 'WEB-EDITOR)))
-              (AND W (AFTER-MOVE W)))))
-
-(WEB-WINDOW-BUTTON-EVENT-FN
-  (LAMBDA (WINDOW)                                  (IL:* IL:\; "Edited 13-Jul-87 13:38 by Rao")
-                                                             (IL:* IL:\; "11-Sep-86 13:50")
-         (LET ((WINDOW-FOR-MENU (IL:WINDOWPROP WINDOW 'WEB-EDITOR)))
-              (DECLARE (IL:SPECVARS WINDOW-FOR-MENU))
-              (IL:TOTOPW WINDOW)
-              (BUTTON-EVENT-FN WINDOW-FOR-MENU))))
-
-(WEB-WINDOW-RESHAPE-FN
-  (LAMBDA (WINDOW IL:|oldBitmapImage| IL:|oldRegion| IL:|oldScreenRegion|)
-                                                        (IL:* IL:\; "Edited 12-Jun-87 15:56 by Rao")
-                                                             (IL:* IL:\; " 9-May-86 10:07")
-
-(IL:* IL:|;;;| "The RESHAPEFN for a Window")
-
-         (LET ((IL:\w (IL:WINDOWPROP WINDOW 'WEB-EDITOR)))
-              (AND IL:\w (AFTER-RESHAPE IL:\w IL:|oldBitmapImage| IL:|oldRegion| IL:|oldScreenRegion|
-                                )))))
-
-(WEB-WINDOW-CLOSE-FN
-  (IL:LAMBDA (WINDOW)                               (IL:* IL:\; "Edited 12-Jun-87 11:42 by Rao")
-                                                             (IL:* IL:\; 
-                                                           "Remove link back to LoopsWindow")
-    (IL:WINDOWPROP WINDOW 'WEB-EDITOR NIL)))
-
-(IL:|PromptRead|
-  (IL:LAMBDA (PROMPT-STRING WINDOW SAME-LINE?)      (IL:* IL:\; "Edited 20-Jul-87 16:20 by Rao")
-                                                             (IL:* IL:\; 
-                  "Printout promptString in promptwindow and return value of expression read there")
-    (PROG (NEWVALUE)
-          (IL:RESETLST
-              (IL:RESETSAVE (IL:TTYDISPLAYSTREAM (OR WINDOW IL:PROMPTWINDOW)))
-              (IL:RESETSAVE (IL:TTY.PROCESS (IL:THIS.PROCESS)))
-              (IL:CLRPROMPT)
-              (IL:RESETSAVE (IL:PRINTLEVEL 4 3))
-              (IL:|printout| T PROMPT-STRING)
-              (IL:|if| SAME-LINE?
-                  IL:|then| (IL:|printout| T "> ")
-                IL:|else| (IL:|printout| T T "> "))
-              (IL:CLEARBUF T T)                              (IL:* IL:\; 
-                                            "clear tty buffer because it sometimes has stuff left.")
-              (IL:ALLOW.BUTTON.EVENTS)
-              (IL:SETQ NEWVALUE (CAR (IL:ERSETQ (IL:TTYINREAD T T)))))
-          (RETURN NEWVALUE))))
-)
-(IL:DEFINEQ
-
-(WEB-WINDOW-EXPAND-FN
-  (LAMBDA (WINDOW)                                  (IL:* IL:\; "Edited 13-Nov-87 12:58 by Rao")
-                                                             (IL:* IL:\; "19-Feb-85 13:58")
-
-         (IL:* IL:|;;| "When a browser window is expanded, it should be recomputed")
-
-         (LET ((SELF (IL:WINDOWPROP WINDOW 'WEB-EDITOR)))
-              (RECOMPUTE-IN-PLACE SELF))))
-)
-
-(DEFUN WEB-WINDOW-ICON-FN (WINDOW ICON DUMMY)
-   (LET NIL (OR ICON (IL:TITLEDICONW *WEB-EDITOR-TEMPLATE* (ICON-TITLE (IL:WINDOWPROP WINDOW
-                                                                              'WEB-EDITOR))
-                            NIL
-                            '(0 . 0)
-                            T
-                            'IL:BOTTOM
-                            (IL:CONSTANT (LIST (IL:CHARCODE "-")
-                                               (IL:CHARCODE IL:SPACE)
-                                               (IL:CHARCODE IL:EOL)))))))
-
-(IL:RPAQQ *WEB-EDITOR-ICON-BM* #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@L@@@@@@@@@@AL@@@L@@@@@@@@@@AF@@@L@@@@@@@@@@AC@@@L@@@@@@@@@@AAH@@L@@@@@@@@@@A@L@@L@@@@@@@@@@A@F@@LOON@@@@@@OO@C@@LOON@@@@@@OO@AH@LOOO@@@@@@OO@@L@LOONH@@@@AOO@@F@LOOND@@@@BOOOOO@L@@@B@@@@DOOOHC@L@@@ACOOLH@@@@C@L@@@@KOOM@@@@@C@L@@@@GOON@@@@@C@L@@@@KOOM@@@@@C@L@@@ACOOLH@@@@C@LOOOB@@@@DOOOHC@LOOOD@@@@BOOOHC@LOOOH@@@@AOOOHC@LOOOD@@@@@OOOHC@LOOOB@@@@@OOOHC@L@@@ACOOO@@@@@C@L@@@@KOOO@@@@@C@L@@@@GOOO@@@@@C@L@@@@COOO@@@@@C@L@@@@COOO@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@
-)
-
-(IL:RPAQQ *WEB-EDITOR-ICON-MASK* #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOON@@@OOOOOOOOOOOOO@@@OOOOOOOOOOOOOH@@OOOOOOOOOOOOOL@@OOOOOOOOOOOOON@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOL@OOOOOOOOOOOOOON@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@
-)
-
-(DEFVAR *WEB-EDITOR-TEMPLATE* (IL:|create| IL:TITLEDICON
-                                         IL:ICON IL:_ *WEB-EDITOR-ICON-BM*
-                                         IL:MASK IL:_ *WEB-EDITOR-ICON-MASK*
-                                         IL:TITLEREG IL:_ (IL:CREATEREGION 5 2 50 30)))
-
-(IL:RPAQ IL:*D-WINDOW-DEFAULT-STREAM* IL:PROMPTWINDOW)
-
-(IL:RPAQ WEB-STREAM IL:PROMPTWINDOW)
-
-
-
-(IL:* IL:\; "Layout and Display Engine")
-
-
-(IL:RPAQQ IL:|BrowserMargin| 0)
-
-(IL:RPAQQ IL:|MaxLatticeHeight| 750)
-
-(IL:RPAQQ IL:|MaxLatticeWidth| 900)
-(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
-
-(IL:SPECVARS IL:|MaxLatticeHeight| IL:|MaxLatticeWidth|)
-)
-
-(IL:RPAQQ IL:GRAYSHADE1 1)
-
-(IL:RPAQQ IL:GRAYSHADE2 1025)
-
-(IL:RPAQQ IL:GRAYSHADE3 64510)
-
-(IL:RPAQQ IL:GRAYSHADE4 65534)
-(IL:DEFINEQ
-
-(TREE-ROOTS
-  (IL:LAMBDA (NODE-LST)                             (IL:* IL:\; "Edited 10-Jul-87 19:22 by Rao")
-                                                             (IL:* IL:\; "29-Sep-86 19:46")
-
-    (IL:* IL:|;;| "Computes a minimal set of root nodes for a lattice --- those with no connections TO them in list of nodes, or a single node from a cycle of nodes.")
-
-    (PROG ((ROOT-NODES (IL:LDIFFERENCE NODE-LST (IL:|for| IL:|node| IL:|in| NODE-LST
-                                                   IL:|join| (CHILD-NODES IL:|node| NODE-LST)
-                                                       )))
-           REACHABLE-NODES NOT-REACHABLE-NODES)
-          (SETQ REACHABLE-NODES (IL:COPY ROOT-NODES))
-          (SETQ NOT-REACHABLE-NODES (IL:LDIFFERENCE NODE-LST REACHABLE-NODES))
-                                                             (IL:* IL:\; 
-                             "recompute the nodes that can't be reached from the current rootNodes")
-      IL:|RecomputeReachableNodes|
-          
-
-     (IL:* IL:|;;| "Compute the transitive closure of the set of reachableNodes --- updating the notReachableNodes at the same time")
-
-          (IL:|for| IL:|node| IL:|in| REACHABLE-NODES
-             IL:|do| (IL:|for| IL:|childNode| IL:|in| (CHILD-NODES IL:|node| NODE-LST
-                                                                         )
-                            IL:|when| (IL:MEMB IL:|childNode| NOT-REACHABLE-NODES)
-                            IL:|do| 
-
-                                  (IL:* IL:|;;| "put the newly found reachable node at the end of the list, so we will find it later on during this iteration")
-
-                                  (IL:NCONC1 REACHABLE-NODES IL:|childNode|)
-                                  (SETQ NOT-REACHABLE-NODES (IL:DREMOVE IL:|childNode| 
-                                                                   NOT-REACHABLE-NODES))))
-                                                             (IL:* IL:\; 
-                                                           "if we can reach all the nodes, fine...")
-          (IL:|if| (NULL NOT-REACHABLE-NODES)
-              IL:|then|                                  (IL:* IL:\; 
-                                                          "Now need to prune down to a minimal set")
-                    (IL:|bind| (IL:|stable?| IL:_ NIL) IL:|until| IL:|stable?|
-                       IL:|do| (SETQ IL:|stable?| T)
-                             (IL:|for| IL:|node| IL:|in| ROOT-NODES IL:|bind| 
-                                                                                  IL:|extraRoots|
-                                IL:|do| (SETQ IL:|extraRoots| (IL:DREMOVE IL:|node|
-                                                                         (IL:INTERSECTION
-                                                                          ROOT-NODES
-                                                                          (REACHABLE-NODES!
-                                                                           IL:|node| NODE-LST))))
-                                      (IL:|if| IL:|extraRoots|
-                                          IL:|then| (SETQ IL:|stable?| NIL)
-                                                (SETQ ROOT-NODES (IL:LDIFFERENCE ROOT-NODES 
-                                                                        IL:|extraRoots|))
-                                                (RETURN T)) IL:|finally| (RETURN NIL))) 
-                                                             (IL:* IL:\; 
-                                                          "return the node ids, not the GRAPHNODES")
-                    (RETURN (IL:|for| IL:|node| IL:|in| ROOT-NODES
-                               IL:|collect| (IL:|fetch| IL:NODEID IL:|of| IL:|node|)))
-            IL:|else|                                    (IL:* IL:\; 
-            "must be a cycle.  Select the least prolific node in the cycle as the a new root node.")
-                  (IL:|push| ROOT-NODES (LET ((PROLIFIC-NODE (IL:|for| IL:|node| IL:|in|
-                                                                                         
-                                                                                  NOT-REACHABLE-NODES
-                                                                    IL:|smallest|
-                                                                    (IL:LENGTH (IL:|fetch| 
-                                                                                      IL:TONODES
-                                                                                  IL:|of| 
-                                                                                        IL:|node|))))
-                                                  )
-                                                 (SETQ NOT-REACHABLE-NODES (IL:DREMOVE PROLIFIC-NODE
-                                                                                  NOT-REACHABLE-NODES
-                                                                                  ))
-                                                 PROLIFIC-NODE))
-                  (GO IL:|RecomputeReachableNodes|)))))
-
-(CHILD-NODES
-  (IL:LAMBDA (PARENT-NODE NODE-LIST)                (IL:* IL:\; "Edited 10-Jul-87 19:23 by Rao")
-                                                             (IL:* IL:\; " 8-Oct-85 14:15")
-                                                             (IL:* IL:\; 
-                                 "Find all GRAPHNODES that are immediatly reachable from this node")
-    (IL:|for| IL:|label| IL:|in| (IL:|fetch| IL:TONODES IL:|of| PARENT-NODE)
-       IL:|collect| (IL:|for| IL:|node| IL:|in| NODE-LIST
-                           IL:|thereis| (EQ IL:|label| (IL:|fetch| IL:NODEID IL:|of|
-                                                                                     IL:|node|))))))
-
-(REACHABLE-NODES!
-  (IL:LAMBDA (IL:|root| IL:|nodeList|)                       (IL:* IL:\; "30-Sep-86 10:22")
-                                                             (IL:* IL:\; IL:|Return| IL:\a 
-                                                           IL:|list| IL:|of| IL:|all| 
-                                                           IL:|nodes| IL:|that| IL:|are| 
-                                                           IL:|reachable| IL:|from| IL:|the| 
-                                                           IL:|root|)
-    (LET ((IL:|reachableNodes| (LIST IL:|root|)))
-         (IL:|for| IL:|node| IL:|in| IL:|reachableNodes|
-            IL:|do| (IL:|for| IL:|childNode| IL:|in| (CHILD-NODES IL:|node| 
-                                                                        IL:|nodeList|)
-                           IL:|when| (NOT (IL:MEMB IL:|childNode| IL:|reachableNodes|))
-                           IL:|do| 
-
-         (IL:* IL:\; IL:|put| IL:|the| IL:|newly| IL:|found| IL:|reachable| IL:|node| 
-       IL:|at| IL:|the| IL:|end| IL:|of| IL:|the| IL:|list,| IL:|so| IL:|we| IL:|will| 
-       IL:|find| IL:|it| IL:|later| IL:|on| IL:|during| IL:|this| IL:|iteration|)
-
-                                 (IL:NCONC1 IL:|reachableNodes| IL:|childNode|)))
-         IL:|reachableNodes|)))
-)
-
-(DEFMETHOD DISPLAY-BROWSER ((SELF WEB-EDITOR))           (IL:* IL:\; "29-Sep-86 12:15")
-                                                             (IL:* IL:\; "New method template")
-   (LET ((NODELST (AND (SLOT-VALUE SELF 'STARTING-LIST)
-                       (GET-NODE-LIST SELF (SLOT-VALUE SELF 'STARTING-LIST)
-                              (SLOT-VALUE SELF 'GOOD-LIST)))))
-        (COND
-           (NODELST (IL:SHOWGRAPH (IL:LAYOUTGRAPH NODELST (TREE-ROOTS NODELST)
-                                         (SLOT-VALUE SELF 'GRAPH-FORMAT)
-                                         (SLOT-VALUE SELF 'BROWSE-FONT))
-                           (SLOT-VALUE SELF 'WINDOW)
-                           NIL NIL (SLOT-VALUE SELF 'TOP-ALIGN))
-                                                             (IL:* IL:\; 
-                                                           "kludge to reset the window props")
-                  (SETUP-WINDOW SELF))
-           (T (CLEAR SELF)))))
-
-(DEFMETHOD BROWSER-OBJECTS ((IL:|self| WEB-EDITOR))      (IL:* IL:\; "28-May-84 12:58")
-                                                             (IL:* IL:\; 
-                                            "Return a list of all the objects shown in the browser")
-   (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES
-                                          IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self|
-                                                                            'WINDOW)
-                                                             'IL:GRAPH))
-      IL:|when| (IL:NLISTP (CAR IL:|node|)) IL:|collect| (CAR IL:|node|)))
-
-(DEFMETHOD GET-NODE-LIST ((SELF WEB-EDITOR)
-                              BROWSE-LIST GOOD-LIST)         (IL:* IL:\; "21-Mar-85 14:09")
-
-   (IL:* IL:|;;| "Compute the node data structures of the tree starting at browseList.  If goodList is given, only include elements of it.  If goodList=T make it be browseList.")
-
-   (DECLARE (IL:GLOBALVARS IL:WHITESHADE))
-   (COND
-      ((EQ GOOD-LIST T)
-       (IL:SETQ GOOD-LIST BROWSE-LIST)))
-   (PROG (SUBS PAIR NODE (OLD-NODES (IL:|fetch| IL:GRAPHNODES IL:|of|
-                                                                  (IL:WINDOWPROP (SLOT-VALUE
-                                                                                  SELF
-                                                                                  'WINDOW)
-                                                                         'IL:GRAPH)))
-               (OBJ-LIST (CONS)))
-
-    (IL:* IL:|;;| "first make objList which is a list of pairs (object  . objName).  objName will be used as a title for a node in the browser.  This structure will be replaced by a graphNode when it is processed.  The nodeID of the graphNode will be the object, and the label will be the name.")
-
-         (IL:|for| IL:|objOrName| IL:|in| BROWSE-LIST
-            IL:|do| (AND (IL:SETQ PAIR (OBJ-NAME-PAIR SELF IL:|objOrName|))
-                             (NOT (IL:FASSOC (CAR PAIR)
-                                         (CAR OBJ-LIST)))
-                             (IL:TCONC OBJ-LIST PAIR)))
-
-    (IL:* IL:|;;| "Now MAP ON list so pair can be replaced by graphNode")
-
-         (IL:|for| PAIR IL:|name| IL:|obj| IL:|subObjs| IL:|on| (CAR OBJ-LIST)
-            IL:|when| (IL:NLISTP (IL:SETQ IL:|name| (CDAR PAIR)))
-            IL:|do| (IL:SETQ IL:|subObjs| (CONS))
-                  (IL:|for| IL:|sub| IL:|objPair| IL:|obj1| IL:|in| (GET-SUBS SELF
-                                                                                   (IL:SETQ IL:|obj|
-                                                                                    (CAAR PAIR)))
-                     IL:|do| 
-
-                           (IL:* IL:|;;| "ObjNamePair returns NIL for destroyed objects.  include only members of goodList in subs if given.  Add to objList only once")
-
-                           (IL:SETQ IL:|obj1| (COND
-                                                 ((EQ (CAR IL:|sub|)
-                                                      'IL:|Link Parameters|)
-                                                  (CADR IL:|sub|))
-                                                 (T IL:|sub|)))
-                           (COND
-                              ((IL:SETQ IL:|objPair| (OBJ-NAME-PAIR SELF IL:|obj1|))
-                               (COND
-                                  ((NOT (IL:FASSOC IL:|obj1| (CAR OBJ-LIST)))
-                                   (IL:TCONC OBJ-LIST IL:|objPair|)))
-                               (IL:TCONC IL:|subObjs| IL:|sub|))))
-                  (RPLACA PAIR (IL:SETQ NODE (OR (IL:FASSOC IL:|obj| OLD-NODES)
-                                                 (IL:|create| IL:GRAPHNODE
-                                                        IL:NODEID IL:_ IL:|obj|
-                                                        IL:NODEBORDER IL:_
-                                                        (LIST (IL:ADD1 (SLOT-VALUE SELF 
-                                                                              'BOX-LINE-WIDTH))
-                                                              IL:WHITESHADE)))))
-                  (IL:|replace| IL:TONODES IL:|of| NODE IL:|with| (CAR IL:|subObjs|))
-                  (IL:|replace| IL:NODELABEL IL:|of| NODE IL:|with| IL:|name|)
-                  (IL:|replace| IL:NODEFONT IL:|of| NODE IL:|with| (SLOT-VALUE
-                                                                                SELF
-                                                                                'BROWSE-FONT))
-                  (IL:|replace| IL:NODEWIDTH IL:|of| NODE IL:|with| NIL)
-                  (IL:|replace| IL:NODEHEIGHT IL:|of| NODE IL:|with| NIL))
-         (RETURN (CAR OBJ-LIST))))
-
-(DEFMETHOD OBJ-NAME-PAIR ((IL:|self| WEB-EDITOR)
-                              IL:|obj|)
-
-   (IL:* IL:|;;| "Make a pair (object  . objName) where objName is label to be used in browser")
-
-   (LET NIL (IL:|if| (NULL IL:|obj|)
-                IL:|then| NIL
-              IL:|elseif| (AND (SLOT-VALUE IL:|self| 'GOOD-LIST)
-                                   (NOT (IL:FMEMB IL:|obj| (SLOT-VALUE IL:|self| 'GOOD-LIST))))
-                IL:|then| NIL
-              IL:|elseif| (IL:FMEMB IL:|obj| (SLOT-VALUE IL:|self| 'BAD-LIST))
-                IL:|then| NIL
-              IL:|else| (CONS IL:|obj| (GET-DISPLAY-LABEL IL:|self| IL:|obj|)))))
-
-(DEFMETHOD GRAPH-FITS ((|self| WEB-EDITOR))              (IL:* IL:\; "24-Apr-86 15:00")
-
-(IL:* IL:|;;;| "Tests if graph fits in region")
-
-   (LET ((|window| (SLOT-VALUE |self| 'WINDOW)))
-        (LET ((|width| 0)
-              (|height| 0)
-              (|region| (IL:WINDOWPROP |window| 'IL:REGION))
-              (|nodes| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP |window| 'IL:GRAPH)))
-              )
-             (COND
-                (|nodes| (IL:SETQ |width| (IL:WIDTHIFWINDOW (IL:IDIFFERENCE (IL:MAX/RIGHT |nodes|)
-                                                                   (IL:MIN/LEFT |nodes|))
-                                                 (IL:WINDOWPROP |window| 'IL:BORDER)))
-                       (IL:SETQ |height| (IL:HEIGHTIFWINDOW (IL:IDIFFERENCE (IL:MAX/TOP |nodes|)
-                                                                   (IL:MIN/BOTTOM |nodes|))
-                                                (IL:WINDOWPROP |window| 'IL:TITLE)
-                                                (IL:WINDOWPROP |window| 'IL:BORDER)))))
-             (NOT (OR (IL:IGREATERP |width| (IL:|fetch| IL:WIDTH IL:|of| |region|))
-                      (IL:IGREATERP |height| (IL:|fetch| IL:HEIGHT IL:|of| |region|)))))))
-
-(DEFMETHOD NODE-REGION ((IL:|self| WEB-EDITOR)
-                            IL:|object|)                     (IL:* IL:\; "10-Dec-84 18:26")
-
-   (IL:* IL:|;;| "what region does the object occupy in the display stream?")
-
-   (LET ((IL:|node| (IL:FASSOC (COND
-                                  ((IL:LITATOM IL:|object|)
-                                   (IL:SETQ IL:|object| (IL:|GetObjectRec| IL:|object|)))
-                                  (T IL:|object|))
-                           (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
-                                                                      (SLOT-VALUE IL:|self|
-                                                                             'WINDOW)
-                                                                      'IL:GRAPH)))))
-        (IL:|if| IL:|node|
-            IL:|then| (IL:|create| IL:REGION
-                                 IL:LEFT IL:_ (IL:IDIFFERENCE (IL:|fetch| IL:XCOORD
-                                                                 IL:|of| (IL:|fetch| 
-                                                                                    IL:NODEPOSITION
-                                                                                IL:|of| IL:|node|
-                                                                                    ))
-                                                     (IL:IQUOTIENT (IL:|fetch| IL:NODEWIDTH
-                                                                      IL:|of| IL:|node|)
-                                                            2))
-                                 IL:BOTTOM IL:_ (IL:IDIFFERENCE (IL:|fetch| IL:YCOORD
-                                                                   IL:|of| (IL:|fetch| 
-                                                                                      IL:NODEPOSITION
-                                                                                  IL:|of| 
-                                                                                        IL:|node|))
-                                                       (IL:IQUOTIENT (IL:|fetch| IL:NODEHEIGHT
-                                                                        IL:|of| IL:|node|)
-                                                              2))
-                                 IL:WIDTH IL:_ (IL:|fetch| IL:NODEWIDTH IL:|of| IL:|node|)
-                                 IL:HEIGHT IL:_ (IL:|fetch| IL:NODEHEIGHT IL:|of| IL:|node|))
-               )))
-
-(DEFMETHOD RECOMPUTE ((SELF WEB-EDITOR)
-                          &OPTIONAL DONT-RESHAPE-FLG)        (IL:* IL:\; " 8-Apr-87 14:42")
-                                                             (IL:* IL:\; 
-                                                     "Recompute the browseGraph in the same window")
-   (PROG ((GRAPH-FITS (GRAPH-FITS SELF)))
-         (DISPLAY-BROWSER SELF)
-         (COND
-            ((OR DONT-RESHAPE-FLG (NULL GRAPH-FITS))         (IL:* IL:\; 
-                             "Dont Reshape or rescroll.  Assume window wants to stay the same size")
-             )
-            (T (SHAPE-TO-HOLD SELF))))
-   SELF)
-
-(DEFMETHOD RECOMPUTE-IN-PLACE ((IL:|self| WEB-EDITOR))   (IL:* IL:\; "10-Dec-84 18:27")
-
-(IL:* IL:|;;;| "recompute the graph, maintaining the current position")
-
-   (LET* ((IL:|visibleRegion| (IL:DSPCLIPPINGREGION NIL (SLOT-VALUE IL:|self| 'WINDOW)))
-          (IL:\x (IL:|fetch| IL:LEFT IL:|of| IL:|visibleRegion|))
-          (IL:\y (IL:|fetch| IL:BOTTOM IL:|of| IL:|visibleRegion|)))
-                                                             (IL:* IL:\; 
-                      "if we want to RecomputeInPlace, we must want the window to be kept the same")
-         (RECOMPUTE IL:|self| T)                             (IL:* IL:\; 
-               "we had to save x and y because visibleRegion gets clobbered by Recompute! Suprise!")
-         (SCROLL-WINDOW IL:|self| IL:\x IL:\y)))
-
-(DEFMETHOD RECOMPUTE-LABELS ((|self| WEB-EDITOR))        (IL:* IL:\; "27-Feb-85 11:27")
-                                                             (IL:* IL:\; 
-                                                        "recompute the graph, including the labels")
-   (CLEAR-LABEL-CACHE |self| T)
-   (RECOMPUTE |self|))
-
-(DEFMETHOD RECOMPUTE-IF-OPEN ((WEB-EDITOR WEB-EDITOR))   (IL:* IL:\; "27-Aug-86 12:37")
-   (IF (IL:OPENWP (SLOT-VALUE WEB-EDITOR 'WINDOW))
-       (RECOMPUTE WEB-EDITOR)))
-
-(DEFMETHOD CLEAR-LABEL-CACHE ((WEB-EDITOR WEB-EDITOR)
-                                  OBJECTS)                   (IL:* IL:\; " 5-Dec-85 12:02")
-   (LET (CACHED-LABEL)
-
-        (IL:* IL:|;;| "Delete the cached label for these items")
-
-        (COND
-           ((EQ OBJECTS T)
-            (SETF (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE)
-                  NIL))
-           (T (IF (ATOM OBJECTS)
-                  (SETQ OBJECTS (CONS OBJECTS)))
-              (DOLIST (OBJ OBJECTS)
-                  (IF (SETQ CACHED-LABEL (IL:ASSOC OBJ (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE)))
-                      (SETF (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE)
-                            (IL:DREMOVE CACHED-LABEL (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE)))))))))
-
-(DEFMETHOD OBJECT-FROM-LABEL ((SELF WEB-EDITOR)
-                                  LABEL)                     (IL:* IL:\; " 4-Jan-85 18:20")
-
-   (IL:* IL:|;;| "What object has this label?")
-
-   (LET ((OBJECT-NODE (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES
-                                                             IL:|of| (IL:WINDOWPROP
-                                                                          (SLOT-VALUE SELF
-                                                                                 'WINDOW)
-                                                                          'IL:GRAPH))
-                         IL:|thereis| (IL:EQUAL LABEL (IL:|fetch| IL:NODELABEL IL:|of|
-                                                                                       IL:|node|)))))
-        (IL:|if| (IL:NLISTP (CAR OBJECT-NODE))
-            IL:|then| (CAR OBJECT-NODE)
-          IL:|else| NIL)))
-
-(DEFMETHOD CHANGE-FONT-SIZE ((WEB-EDITOR WEB-EDITOR)
-                                 &OPTIONAL SIZE)             (IL:* IL:\; "13-Dec-84 13:04")
-                                                             (IL:* IL:\; 
-                                                 "Change the font size from whatever it is to size")
-   (WHEN (OR SIZE (SETQ SIZE (IL:MENU (IL:|create| IL:MENU
-                                             IL:TITLE IL:_ "Select Desired Size"
-                                             IL:CHANGEOFFSETFLG IL:_ T
-                                             IL:ITEMS IL:_ '(("Abort" NIL)
-                                                             8 10 12 16)))))
-       (SETF (SLOT-VALUE WEB-EDITOR 'BROWSE-FONT)
-             (IL:FONTCREATE `(,(SLOT-VALUE WEB-EDITOR 'BROWSE-FONT-FAMILY)
-                              ,SIZE
-                              ,(SLOT-VALUE WEB-EDITOR 'BROWSE-FONT-FACE))))
-                                                             (IL:* IL:\; 
-                                                           "clear out the label cache!")
-       (RECOMPUTE-LABELS WEB-EDITOR)))
-
-(DEFMETHOD CHANGE-FORMAT ((|self| WEB-EDITOR)
-                              &OPTIONAL |format|)            (IL:* IL:\; "21-Apr-84 19:52")
-                                                             (IL:* IL:\; 
-                                                           "Change format between Lattice and Tree")
-   (COND
-      ((IL:LISTP |format|)
-       (SETF (SLOT-VALUE |self| 'GRAPH-FORMAT)
-             |format|))
-      ((SETQ |format| (IL:MENU (IL:|create| IL:MENU
-                                      IL:ITEMS IL:_ (SLOT-VALUE |self| 'GRAPH-FORMAT-CHOICES))))
-       (SETF (SLOT-VALUE |self| 'GRAPH-FORMAT)
-             |format|)))
-   (RECOMPUTE |self|))
-
-(DEFMETHOD CHANGE-MAX-LABEL-SIZE ((SELF WEB-EDITOR)
-                                      NEW-MAX-WIDTH NEW-MAX-LINES)
-                                                             (IL:* IL:\; "13-Dec-84 13:05")
-                                                             (IL:* IL:\; 
-     "change the max label dimensions and redisplay the nodes -- if new size is NULL, don't change")
-   (IL:|if| NEW-MAX-LINES
-       IL:|then| (SETF (SLOT-VALUE SELF 'LABEL-MAX-LINES)
-                           NEW-MAX-LINES))
-   (IL:|if| NEW-MAX-WIDTH
-       IL:|then| (SETF (SLOT-VALUE SELF 'LABEL-MAX-CHARS-WIDTH)
-                           NEW-MAX-WIDTH))                   (IL:* IL:\; 
-                                                           "clear out the label cache")
-   (RECOMPUTE-LABELS SELF))
-
-(DEFMETHOD SHAPE-TO-HOLD ((SELF WEB-EDITOR))             (IL:* IL:\; "13-Jan-87 16:52")
-
-   (IL:* IL:|;;| "Shape the browse window to just hold the nodes with BrowserMargin to spare")
-
-   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))
-          (REGION (IL:WINDOWPROP WINDOW 'IL:REGION))
-          (NODES (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP WINDOW 'IL:GRAPH)))
-          (MIN-WIDTH (IL:IPLUS 5 (IL:STRINGWIDTH (SLOT-VALUE SELF 'TITLE)
-                                        (IL:DSPFONT NIL IL:|WindowTitleDisplayStream|))))
-          (MIN-HEIGHT (IL:FONTHEIGHT (IL:DSPFONT NIL WINDOW)))
-          LEFT BOTTOM HEIGHT WIDTH RIGHT TOP)
-         (IF NODES
-             (PROGN (SETQ LEFT (IL:MIN/LEFT NODES))
-                    (SETQ BOTTOM (IL:MIN/BOTTOM NODES))
-                    (SETQ RIGHT (IL:MAX/RIGHT NODES))
-                    (SETQ TOP (IL:MAX/TOP NODES))
-                    (SETQ WIDTH (IL:IMAX MIN-WIDTH (IL:IMIN IL:|MaxLatticeWidth|
-                                                          (IL:WIDTHIFWINDOW (IL:PLUS 
-                                                                                   IL:|BrowserMargin|
-                                                                                   (IL:IDIFFERENCE
-                                                                                    RIGHT LEFT))
-                                                                 (IL:WINDOWPROP WINDOW 'IL:BORDER))))
-                          )
-                    (SETQ HEIGHT (IL:IMAX MIN-HEIGHT (IL:IMIN IL:|MaxLatticeHeight|
-                                                            (IL:PLUS IL:|BrowserMargin|
-                                                                   (IL:IDIFFERENCE TOP BOTTOM)))))
-                    (UNLESS (AND (IL:EQP WIDTH (IL:|fetch| IL:WIDTH IL:|of| REGION))
-                                 (IL:EQP (IL:HEIGHTIFWINDOW HEIGHT (IL:WINDOWPROP WINDOW 'IL:TITLE)
-                                                (IL:WINDOWPROP WINDOW 'IL:BORDER))
-                                        (IL:|fetch| IL:HEIGHT IL:|of| REGION)))
-                        (SET-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION)
-                                                (IL:|fetch| IL:BOTTOM IL:|of| REGION)
-                                                WIDTH HEIGHT)
-                               NIL)))
-
-             (IL:* IL:|;;| "ELSE")
-
-             (SET-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION)
-                                     (IL:|fetch| IL:BOTTOM IL:|of| REGION)
-                                     MIN-WIDTH MIN-HEIGHT)))))
-
-(DEFMETHOD GET-DISPLAY-LABEL ((SELF WEB-EDITOR)
-                                  OBJECT)
-
-(IL:* IL:|;;;| "get the display label.  use the cache if it provides the answer;  if not, and maxLabelWidth is set, use it to compute the appropriate bit map and then cache the result.")
-
-   (LET ((CACHED-LABEL (IL:ASSOC OBJECT (SLOT-VALUE SELF 'LABEL-CACHE))))
-        (IF CACHED-LABEL
-            (CDR CACHED-LABEL)
-            (LET ((NEW-LABEL (BOX-PRINT-STRING (GET-LABEL SELF OBJECT)
-                                    (SLOT-VALUE SELF 'LABEL-MAX-CHARS-WIDTH)
-                                    (SLOT-VALUE SELF 'LABEL-MAX-LINES)
-                                    (SLOT-VALUE SELF 'BROWSE-FONT))))
-                 (IL:|if| (IL:LISTP NEW-LABEL)
-                     IL:|then|                           (IL:* IL:\; 
-                                                           "GRAPHER dies if the label is a list")
-                           (IL:SETQ NEW-LABEL (IL:MKSTRING NEW-LABEL)))
-                 (PUSH (CONS OBJECT NEW-LABEL)
-                       (SLOT-VALUE SELF 'LABEL-CACHE))
-                 NEW-LABEL))))
-
-(DEFMETHOD BOX-NODE ((SELF WEB-EDITOR)
-                         OBJECT &OPTIONAL KEEP-PREVIOUS-BOX) (IL:* IL:\; " 8-Apr-87 18:34")
-   "Puts a box around the node in the graph representing the object"
-
-   (IL:* IL:|;;| 
- "If there was a previously boxed node, remove the box from around it and set it to nil")
-
-   (WHEN (AND (NOT KEEP-PREVIOUS-BOX)
-              DESTINATION-BROWSER
-              (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE))
-       (HIGHLIGHT-NODE DESTINATION-BROWSER (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE)
-              (SLOT-VALUE SELF 'BOX-LINE-WIDTH)
-              IL:WHITESHADE)
-       (SETF (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE)
-             NIL))
-   (SETQ DESTINATION-BROWSER SELF)                           (IL:* IL:\; "update the global")
-   (HIGHLIGHT-NODE SELF OBJECT (SLOT-VALUE SELF 'BOX-LINE-WIDTH)
-          IL:BLACKSHADE)
-   (SETF (SLOT-VALUE SELF 'BOXED-NODE)
-         OBJECT))
-
-(DEFMETHOD UNMARK-NODES ((IL:|self| WEB-EDITOR))         (IL:* IL:\; "10-Dec-84 12:27")
-                                                             (IL:* IL:\; 
-                                     "clear the graph nodes, removing all shading and highlighting")
-   (REMOVE-HIGHLIGHTS IL:|self|)
-   (REMOVE-SHADING IL:|self|))
-
-(DEFMETHOD HIGHLIGHT-NODE ((SELF WEB-EDITOR)
-                               OBJECT WIDTH SHADE)           (IL:* IL:\; "13-Dec-85 15:16")
-
-(IL:* IL:|;;;| "highlight a node by surronding it with a shaded box")
-
-   (LET ((NODE (IL:FASSOC OBJECT (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
-                                                                            (SLOT-VALUE SELF
-                                                                                   'WINDOW)
-                                                                            'IL:GRAPH)))))
-        (AND NODE (DISPLAY-NODE-HIGHTLIGHTS SELF NODE SHADE WIDTH))))
-
-(DEFMETHOD SHADE-NODE ((IL:|self| WEB-EDITOR)
-                           IL:|object| IL:|shade|)           (IL:* IL:\; "15-Jan-87 18:34")
-
-   (IL:* IL:|;;| "shade the background of a node")
-
-   (LET ((IL:|node| (IL:FASSOC (COND
-                                  ((IL:LITATOM IL:|object|)
-                                   (IL:SETQ IL:|object| (IL:|GetObjectRec| IL:|object|)))
-                                  (T IL:|object|))
-                           (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
-                                                                      (SLOT-VALUE IL:|self|
-                                                                             'WINDOW)
-                                                                      'IL:GRAPH)))))
-        (IL:|if| IL:|node|
-            IL:|then| (IL:|if| (IL:BITMAPP (IL:|fetch| IL:NODELABEL IL:|of| IL:|node|
-                                                          ))
-                              IL:|then| 
-
-                                 (IL:* IL:|;;| "Need to forget the old bitmap, in case it already has a shade blt'ed into it.  This will fail if the GetDisplayLabel msg returns something different from the previous value, but what can you do?")
-
-                                    (CLEAR-LABEL-CACHE IL:|self| IL:|object|)
-                                    (LET ((IL:|newLabel| (GET-DISPLAY-LABEL IL:|self| IL:|object|)))
-                                         (IL:|replace| IL:NODELABEL IL:|of| IL:|node|
-                                            IL:|with| IL:|newLabel|)
-                                         (IL:|if| (AND IL:|shade| (IL:BITMAPP IL:|newLabel|))
-                                             IL:|then| (IL:BITBLT NIL NIL NIL IL:|newLabel| NIL 
-                                                                  NIL NIL NIL 'IL:TEXTURE
-                                                                  'IL:PAINT IL:|shade|))))
-                  (DISPLAY-NODE-SHADING IL:|self| IL:|node| IL:|shade|))))
-
-(DEFMETHOD DISPLAY-NODE-HIGHTLIGHTS ((SELF WEB-EDITOR)
-                                         NODE SHADE BOX-WIDTH)
-   (IL:RESET/NODE/BORDER NODE (COND
-                                 (SHADE (LIST BOX-WIDTH SHADE))
-                                 (T BOX-WIDTH))
-          (SLOT-VALUE SELF 'WINDOW)))
-
-(DEFMETHOD DISPLAY-NODE-SHADING ((SELF WEB-EDITOR)
-                                     NODE SHADE)             (IL:* IL:\; "13-Dec-85 15:13")
-                                                             (IL:* IL:\; "New method template")
-   (IL:RESET/NODE/LABELSHADE NODE (OR SHADE IL:WHITESHADE)
-          (SLOT-VALUE SELF 'WINDOW)))
-
-(DEFMETHOD REMOVE-HIGHLIGHTS ((IL:|self| WEB-EDITOR))    (IL:* IL:\; "13-Dec-85 15:16")
-
-(IL:* IL:|;;;| "gets rid of all highlighting in the lattice")
-
-   (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES
-                                          IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self|
-                                                                            'WINDOW)
-                                                             'IL:GRAPH))
-      IL:|do| (DISPLAY-NODE-HIGHTLIGHTS IL:|self| IL:|node| NIL))
-   (SETF (SLOT-VALUE IL:|self| 'BOXED-NODE)
-         NIL))
-
-(DEFMETHOD REMOVE-SHADING ((IL:|self| WEB-EDITOR))       (IL:* IL:\; "13-Dec-85 15:14")
-
-(IL:* IL:|;;;| "gets rid of all shading in the lattice")
-
-   (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES
-                                          IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self|
-                                                                            'WINDOW)
-                                                             'IL:GRAPH))
-      IL:|do| (DISPLAY-NODE-SHADING IL:|self| IL:|node| IL:WHITESHADE)))
-
-(DEFMETHOD FLASH-NODE ((IL:|self| WEB-EDITOR)
-                           IL:|node| IL:N IL:|flashTime| IL:|leaveFlipped?|)
-                                                             (IL:* IL:\; "12-Dec-84 16:09")
-                                                             (IL:* IL:\; "Flip node N times")
-   (IL:SETQ IL:|node| (IL:FASSOC (COND
-                                    ((IL:LITATOM IL:|node|)
-                                     (IL:SETQ IL:|node| (IL:|GetObjectRec| IL:|node|)))
-                                    (T IL:|node|))
-                             (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
-                                                                        (SLOT-VALUE IL:|self|
-                                                                               'WINDOW)
-                                                                        'IL:GRAPH))))
-   (IL:|if| IL:|node|
-       IL:|then| (IL:|for| IL:\i IL:|from| 1 IL:|to| (OR IL:N 3)
-                        IL:|do| (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW))
-                              (IL:DISMISS (OR IL:|flashTime| 300))
-                              (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW))
-                              (IL:DISMISS (OR IL:|flashTime| 300)))
-             (IL:|if| IL:|leaveFlipped?|
-                 IL:|then| (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW)))))
-
-(DEFMETHOD FLIP-NODE ((SELF WEB-EDITOR)
-                          OBJECT)                            (IL:* IL:\; "13-Dec-85 15:18")
-                                                             (IL:* IL:\; 
-                           "Inverts the video around the node in the graph representing the object")
-   (LET ((NODE (IL:FASSOC OBJECT (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
-                                                                            (SLOT-VALUE SELF
-                                                                                   'WINDOW)
-                                                                            'IL:GRAPH)))))
-        (AND NODE (DISPLAY-NODE-SHADING SELF NODE (IL:INVERTED/SHADE/FOR/GRAPHER (IL:|fetch|
-                                                                                  IL:NODELABELSHADE
-                                                                                    IL:|of|
-                                                                                    NODE))))))
-
-(DEFMETHOD POSITION-NODE ((SELF WEB-EDITOR)
-                              OBJECT WINDOW-X WINDOW-Y)      (IL:* IL:\; "10-Dec-84 18:24")
-
-(IL:* IL:|;;;| "scrolls the window so that the node is in the given position of the window.  If windowX or windowY is a FLOATP, it it taken to be a window-relative postion;  if a FIXP, it is a window-absolute position.")
-
-   (LET ((REGION (NODE-REGION SELF OBJECT)))
-        (IL:|if| REGION
-            IL:|then| (SCROLL-WINDOW SELF (IL:|fetch| IL:LEFT IL:|of| REGION)
-                                 (IL:|fetch| IL:BOTTOM IL:|of| REGION)
-                                 WINDOW-X WINDOW-Y))))
-(IL:DEFINEQ
-
-(BOX-PRINT-STRING
-  (IL:LAMBDA (STRING MAX-CHARS-WIDTH MAX-LINES FONT OLD-BITMAP)
-                                                        (IL:* IL:\; "Edited 29-Jan-88 15:06 by Rao")
-
-    (IL:* IL:|;;| 
-  "return a bitmap containing the string, in the given font, with MAX-WIDTH at most width")
-                                                             (IL:* IL:\; 
-                                                           "sizes of NULL or 0 mean no max size")
-    (IL:SETQ MAX-CHARS-WIDTH (OR MAX-CHARS-WIDTH 0))
-    (IL:SETQ MAX-LINES (OR MAX-LINES 0))
-    (IL:|if| (IL:ZEROP MAX-CHARS-WIDTH)
-        IL:|then|                                        (IL:* IL:\; 
-                                                        "no max width, then just return the STRING")
-              STRING
-      IL:|else|
-      (PROG ((MAX-WIDTH (IL:ITIMES MAX-CHARS-WIDTH (IL:STRINGWIDTH "A" FONT)))
-             (NCHARS (IL:NCHARS STRING))
-             (NLINES 0)
-             (SPOS 0)
-             (REGION (IL:CONSTANT (IL:|create| IL:REGION)))
-             (TRUE-MAX-WIDTH 0)
-             NEXTPOS DSP SUBSTR)
-            (IL:SETQ STRING (IL:MKSTRING STRING))            (IL:* IL:\; 
-                                                 "we need to find the size of the resultant bitmap")
-        IL:NEXTBREAK
-            (IL:|if| (IL:ILESSP SPOS NCHARS)
-                IL:|then| (IL:|add| NLINES 1)        (IL:* IL:\; 
-                                                 "at least one character, even if exceed MAX-WIDTH")
-                      (IL:SETQ NEXTPOS (IL:IMAX 1 (CAR (BREAK-STRING-FOR-BOXING
-                                                        (IL:SUBSTRING STRING (IL:ADD1 SPOS)
-                                                               -1)
-                                                        MAX-WIDTH FONT))))
-                      (IL:SETQ TRUE-MAX-WIDTH (IL:IMAX TRUE-MAX-WIDTH (IL:STRINGWIDTH
-                                                                       (IL:SUBSTRING STRING
-                                                                              (IL:ADD1 SPOS)
-                                                                              (IL:IPLUS SPOS NEXTPOS)
-                                                                              )
-                                                                       FONT)))
-                      (IL:|add| SPOS NEXTPOS)
-                      (GO IL:NEXTBREAK))
-            (IL:|if| (NOT (IL:ZEROP MAX-LINES))
-                IL:|then| (IL:SETQ NLINES (IL:IMIN MAX-LINES NLINES)))
-                                                             (IL:* IL:\; 
-                                                           "that we have the size, lets build it")
-            (IL:SETQ DSP (IL:DSPCREATE
-                          (IL:|if| (AND OLD-BITMAP
-                                            (NOT (OR (IL:GREATERP TRUE-MAX-WIDTH (IL:BITMAPWIDTH
-                                                                                  OLD-BITMAP))
-                                                     (IL:GREATERP (IL:ITIMES NLINES
-                                                                         (IL:FONTPROP FONT
-                                                                                'IL:HEIGHT))
-                                                            (IL:BITMAPHEIGHT OLD-BITMAP)))))
-                              IL:|then| OLD-BITMAP
-                            IL:|else| (IL:BITMAPCREATE TRUE-MAX-WIDTH (IL:ITIMES
-                                                                           NLINES
-                                                                           (IL:FONTPROP FONT
-                                                                                  'IL:HEIGHT))))))
-            (IL:DSPFONT FONT DSP)
-            (IL:DSPRESET DSP)
-            (IL:SETQ SPOS 0)
-            (IL:|replace| IL:LEFT IL:|of| REGION IL:|with| 0)
-            (IL:|replace| IL:WIDTH IL:|of| REGION IL:|with| TRUE-MAX-WIDTH)
-            (IL:|replace| IL:HEIGHT IL:|of| REGION IL:|with| (IL:FONTPROP FONT
-                                                                                'IL:HEIGHT))
-            (IL:|replace| IL:BOTTOM IL:|of| REGION IL:|with| (IL:ITIMES
-                                                                          NLINES
-                                                                          (IL:FONTPROP FONT
-                                                                                 'IL:HEIGHT)))
-        IL:NEXTPIECE
-            (IL:|add| NLINES -1)
-            (IL:|if| (IL:ILESSP SPOS NCHARS)
-                IL:|then| (IL:SETQ NEXTPOS (IL:IMAX 1 (CAR (BREAK-STRING-FOR-BOXING
-                                                                (IL:SUBSTRING STRING (IL:ADD1 SPOS)
-                                                                       -1)
-                                                                TRUE-MAX-WIDTH FONT))))
-                      (IL:SETQ SUBSTR (IL:SUBSTRING STRING (IL:ADD1 SPOS)
-                                             (IL:IPLUS NEXTPOS SPOS)))
-                      (IL:|replace| IL:BOTTOM IL:|of| REGION
-                         IL:|with| (IL:IDIFFERENCE (IL:|fetch| IL:BOTTOM IL:|of| REGION)
-                                              (IL:|fetch| IL:HEIGHT IL:|of| REGION)))
-                      (IL:|if| (AND (IL:ZEROP NLINES)
-                                        (IL:ILESSP (IL:IPLUS NEXTPOS SPOS)
-                                               NCHARS))
-                          IL:|then|                      (IL:* IL:\; "we need to abbreviate!")
-                                (IL:CENTERPRINTINREGION (IL:CONCAT (IL:SUBSTRING SUBSTR 1 -3)
-                                                               "...")
-                                       REGION DSP)
-                                (GO IL:ALLDONE)
-                        IL:|else|                        (IL:* IL:\; "out this piece")
-                              (IL:CENTERPRINTINREGION SUBSTR REGION DSP)
-                              (IL:|add| SPOS NEXTPOS)
-                              (GO IL:NEXTPIECE)))
-        IL:ALLDONE
-            (RETURN (IL:DSPDESTINATION NIL DSP))))))
-
-(BREAK-STRING-FOR-BOXING
-  (IL:LAMBDA (IL:MSG IL:WIDTH IL:FONT)                       (IL:* IL:\; "11-Dec-84 10:29")
-
-         (IL:* IL:\; IL:|Stolen| IL:|from| IL:|the| IL:|function| IL:ICONW.FORMATLINE 
-       IL:-- IL:|modified| IL:|to| IL:|try| IL:|to| IL:|break| IL:|at| "word" 
-       IL:|boundaries,| IL:|whatever| IL:|they| IL:|are|)
-
-         (IL:* IL:\; IL:\a IL:|list| IL:|of| IL:|the| IL:|char#| IL:|relative| IL:|to| 
-       IL:|char| 1 IL:|of| IL:|where| IL:|to| IL:|break| IL:|next| IL:|line,| IL:|and| 
-       IL:|how| IL:|much| IL:|space| IL:|was| LEFT IL:|over|
-       (IL:|for| IL:|centering| IL:&\c))
-
-    (COND
-       (IL:MSG                                               (IL:* IL:\; IL:|there| IL:|really| 
-                                                           IL:|is| IL:\a IL:|title,| IL:|go| 
-                                                           IL:|ahead| IL:|and| IL:|format| 
-                                                           IL:|the| IL:|next| IL:|line.|)
-              (IL:|bind| (IL:TX IL:_ 0)
-                     (IL:LASTB IL:_ 0)
-                     (IL:CH IL:_ 0)
-                     (IL:TMSG IL:_ (IL:OPENSTRINGSTREAM IL:MSG))
-                     (IL:MSGLEN IL:_ (IL:NCHARS IL:MSG)) IL:|for| IL:I IL:|from| 1
-                 IL:|by| 1
-                 IL:|do|                                 (IL:* IL:\; IL:|thru| IL:|the| 
-                                                           IL:|characters| IL:|one| IL:|by| 
-                                                           IL:|one.|)
-                       (COND
-                          ((IL:IGREATERP IL:TX IL:WIDTH)     (IL:* IL:\; IL:|past| IL:|the| 
-                                                           IL:|right| IL:|margin.|
-                                                           IL:|Time| IL:|to| IL:|stop.|)
-                           (IL:CLOSEF? IL:TMSG)
-                           (RETURN (COND
-                                      ((IL:LISTP IL:LASTB)   (IL:* IL:\; IL:|is| IL:\a IL:|space| 
-                                                           IL:|we| IL:|can| IL:|break| IL:|the| 
-                                                           IL:|line| IL:|at.|
-                                                           IL:|Break| IL:|there.|)
-                                       IL:LASTB)
-                                      (T 
-
-         (IL:* IL:\; IL:|were| IL:|no| IL:|spaces| IL:|on| IL:|this| IL:|line.|
-       IL:|Break| IL:|after| IL:|the| IL:|last| IL:|character| IL:|that| IL:|did| 
-       IL:|fit.|)
-
-                                         (CONS (IL:IDIFFERENCE IL:I 2)
-                                               (IL:IDIFFERENCE IL:WIDTH (IL:IDIFFERENCE IL:TX
-                                                                               (IL:CHARWIDTH IL:CH 
-                                                                                      IL:FONT))))))))
-                          ((IL:EOFP IL:TMSG)                 (IL:* IL:\; IL:|was| IL:|the| 
-                                                           IL:|last| IL:|character.|)
-                           (IL:CLOSEF? IL:TMSG)
-                           (RETURN (CONS (IL:SUB1 IL:I)
-                                         (IL:IDIFFERENCE IL:WIDTH IL:TX))))
-                          (T                                 (IL:* IL:\; IL:|at| IL:|the| 
-                                                           IL:|next| IL:|character.|)
-                             (IL:SETQ IL:CH (IL:BIN IL:TMSG))
-                             (IL:SELCHARQ IL:CH
-                                   ((IL:SPACE IL:\. IL:\: IL:\; IL:\, / IL:\\ IL:* - IL:\#) 
-
-         (IL:* IL:\; IL:|where| IL:|word| IL:|breaks| IL:|are,| IL:|so| IL:|we| IL:|can| 
-       IL:|back| IL:|up| IL:|and| IL:|split| IL:|lines| IL:|there| IL:|if| 
-       IL:|possible.|)
-
-                                          (IL:SETQ IL:LASTB (CONS IL:I (IL:IDIFFERENCE IL:WIDTH IL:TX
-                                                                              ))))
-                                   (IL:CR                    (IL:* IL:\; IL:|forces| IL:\a 
-                                                           IL:|new| IL:|line.|)
-                                          (RETURN (CONS (IL:IMINUS IL:I)
-                                                        (IL:IDIFFERENCE IL:WIDTH IL:TX))))
-                                   (IL:|if| (AND (NOT (IL:U-CASEP (IL:CHARACTER IL:CH)))
-                                                     (NOT (IL:EOFP IL:TMSG))
-                                                     (IL:U-CASEP (IL:PEEKC IL:TMSG)))
-                                       IL:|then|         (IL:* IL:\; IL:|from| IL:|upper| 
-                                                           IL:|to| IL:|lower| IL:|case| IL:|is| 
-                                                           IL:|also| IL:\a IL:|word| IL:|break|)
-                                             (IL:SETQ IL:LASTB (CONS IL:I (IL:IDIFFERENCE IL:WIDTH 
-                                                                                 IL:TX)))))
-                             (IL:SETQ IL:TX (IL:IPLUS IL:TX (IL:CHARWIDTH IL:CH IL:FONT)))))))
-       (T                                                    (IL:* IL:\; IL:|isn't| IL:\a 
-                                                           IL:|title;| IL:|return| IL:\a 
-                                                           IL:|dummy| IL:|entry| IL:|for| 
-                                                           IL:|the| IL:|line| IL:|formatter.|)
-          (CONS 0 IL:WIDTH)))))
-
-(BOX-WINDOW-NODE
-  (IL:LAMBDA (IL:|nodeLabel| WINDOW)                (IL:* IL:\; "Edited 29-Jan-88 11:31 by Rao")
-                                                             (IL:* IL:\; " 7-Sep-84 14:36")
-
-    (IL:* IL:|;;| "a box around the node with nodeLabel in the graph.  A nodeLabel in browsers is an object.  Does nothing if node not found.")
-
-    (PROG (IL:|node| IL:|nodes|)
-          (COND
-             ((AND (IL:WINDOWP WINDOW)
-                   (IL:SETQ IL:|nodes| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP
-                                                                                  WINDOW
-                                                                                  'IL:GRAPH)))
-                   (IL:SETQ IL:|node| (IL:FASSOC IL:|nodeLabel| IL:|nodes|)))
-              (IL:DRAWAREABOX (IL:GN/LEFT IL:|node|)
-                     (IL:GN/BOTTOM IL:|node|)
-                     (IL:|fetch| IL:NODEWIDTH IL:|of| IL:|node|)
-                     (IL:|fetch| IL:NODEHEIGHT IL:|of| IL:|node|)
-                     1
-                     'IL:INVERT WINDOW))))))
-)
-
-
-
-(IL:* IL:\; "Button Events")
-
-(IL:DEFINEQ
-
-(FIND-SELECTED-NODE
-  (IL:LAMBDA (WINDOW)                               (IL:* IL:\; "Edited 12-Nov-87 01:30 by Rao")
-                                                             (IL:* IL:\; "10-Dec-84 17:53")
-
-    (IL:* IL:|;;| "Used in BUTTONEVENTFN and gets called whenever cursor moves or button is down.  Adapted from APPLYTOSELECTEDNODE in GRAPHER package;  returns the selected item rather than applying a function on the inside of the button event fn.")
-
-    (IL:* IL:|;;| 
-  "Also this was modified to pop up the middle button menu on button down rather than button up.")
-
-    (PROG ((LOOPS-WINDOW (IL:WINDOWPROP WINDOW 'WEB-EDITOR))
-           (NODELST (IL:|fetch| (IL:GRAPH IL:GRAPHNODES) IL:|of| (IL:WINDOWPROP WINDOW
-                                                                                'IL:GRAPH)))
-           (DS (IL:WINDOWPROP WINDOW 'IL:DSP))
-           BUTTON OLDPOS REG NOW NEAR)                       (IL:* IL:\; 
-                                                           "note which button is down.")
-                                                             (IL:* IL:\; 
-                                                           "get the region of this window.")
-          (IL:SETQ REG (IL:WINDOWPROP WINDOW 'IL:REGION))
-          (IL:|until| (IL:LASTMOUSESTATE (OR IL:LEFT IL:MIDDLE)) IL:|do| (IL:GETMOUSESTATE))
-          (IL:SETQ NEAR (IL:NODELST/AS/MENU NODELST (IL:SETQ OLDPOS (IL:CURSORPOSITION NIL DS))))
-      IL:FLIP
-          
-
-     (IL:* IL:|;;| "This is kirk's quick hack to get middle button to bring up immediately.")
-
-          (WHEN (IL:LASTMOUSESTATE IL:MIDDLE)
-              (RETURN (IL:|fetch| IL:NODEID IL:|of| NEAR)))
-          (AND NOW (IL:FLIPNODE NOW DS))
-          (AND NEAR (IL:FLIPNODE NEAR DS))
-          (IL:SETQ NOW NEAR)
-      IL:LP
-                                                             (IL:* IL:\; 
-                                                       "wait for a button up or move out of region")
-          (IL:GETMOUSESTATE)
-          (COND
-             ((IL:LASTMOUSESTATE (AND (NOT IL:LEFT)
-                                      (NOT IL:MIDDLE)))      (IL:* IL:\; 
-                                                           "left button up, process it.")
-              (AND NOW (IL:FLIPNODE NOW DS))                 (IL:* IL:\; 
-                                                           "NOW node has been selected.")
-              (RETURN (IL:|fetch| IL:NODEID IL:|of| NOW)))
-             ((NOT (IL:INSIDE? (IL:WINDOWPROP WINDOW 'IL:REGION)
-                          IL:LASTMOUSEX IL:LASTMOUSEY))      (IL:* IL:\; 
-                                                           "outside of region, return")
-              (AND NOW (IL:FLIPNODE NOW DS))
-              (RETURN))
-             ((EQ NOW (IL:SETQ NEAR (IL:NODELST/AS/MENU NODELST (IL:CURSORPOSITION NIL DS OLDPOS))))
-              (GO IL:LP))
-             (T (GO IL:FLIP))))))
-)
-
-(DEFMETHOD BUTTON-EVENT-FN ((SELF WEB-EDITOR))           (IL:* IL:\; " 2-Jan-86 16:41")
-                                                             (IL:* IL:\; 
-                                            "Called when there is a button event in a Loops Window")
-   (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW)))
-        (OR (IL:ERSETQ (COND
-                          ((NULL (IL:INSIDEP (IL:DSPCLIPPINGREGION NIL WINDOW)
-                                        (IL:LASTMOUSEX WINDOW)
-                                        (IL:LASTMOUSEY WINDOW)))
-                           (TITLE-SELECTION SELF))
-                          ((IL:MOUSESTATE IL:LEFT)
-                           (LEFT-SELECTION SELF))
-                          ((IL:MOUSESTATE IL:MIDDLE)
-                           (MIDDLE-SELECTION SELF))
-                          ((IL:MOUSESTATE IL:RIGHT)
-                           (RIGHT-SELECTION SELF)))))))
-
-(DEFMETHOD LEFT-SELECTION ((SELF WEB-EDITOR))
-   (IF (MOVE-DOWN-P)
-       (IF (SLOT-VALUE SELF 'NODE-MOVER-P)
-           (NODE-MOVE SELF)
-           (NODE-MOVE-SHALLOW SELF))
-       (NODE-SELECTION SELF 'IL:LEFT)))
-
-(DEFMETHOD MIDDLE-SELECTION ((SELF WEB-EDITOR))          (IL:* IL:\; "15-May-85 19:04")
-
-   (IL:* IL:|;;| "This function called from the GRAPHER package when a node is selected with the middle mouse button.  If no node is selected then just returns.")
-
-   (PROG (SELECTION OBJECT (WINDOW (SLOT-VALUE SELF 'WINDOW))
-                (WEB-EDITOR SELF))
-         (DECLARE (IL:SPECVARS OBJECT WEB-EDITOR))
-         (COND
-            ((NULL (IL:SETQ OBJECT (FIND-SELECTED-NODE WINDOW)))
-             (RETURN)))
-         (SETF (SLOT-VALUE WEB-EDITOR 'LAST-SELECTED-OBJECT)
-               OBJECT)
-         (IL:GETMOUSESTATE)
-         (FLIP-NODE SELF OBJECT)
-         (IL:SETQ SELECTION (OR (NODE-ACTION SELF OBJECT 'IL:MIDDLE)
-                                (PROGN (FLIP-NODE SELF OBJECT)
-                                       (RETURN NIL))))
-         (FLIP-NODE SELF OBJECT)
-         (DO-SELECTED-COMMAND WEB-EDITOR SELECTION OBJECT)))
-
-(DEFMETHOD RIGHT-SELECTION ((SELF WEB-EDITOR))           (IL:* IL:\; "17-Apr-84 15:46")
-                                                             (IL:* IL:\; 
-                                                           "Do RightButtonItems on selection.")
-   (LET* ((CHOICE (CHOICE-MENU SELF 'RIGHT-BUTTON-ITEMS)))
-         (IF CHOICE (FUNCALL CHOICE SELF))))
-
-(DEFMETHOD TITLE-SELECTION ((SELF WEB-EDITOR))           (IL:* IL:\; "17-Apr-84 15:35")
-
-   (IL:* IL:|;;| " Do TitleItems if selected in title area.  Replaces TitleSelection in Window because this one does evaluation in TTY process, and saves events on history")
-
-   (LET* ((CHOICE (CHOICE-MENU SELF 'TITLE-ITEMS)))
-         (IF CHOICE (FUNCALL CHOICE SELF))))
-
-(DEFMETHOD NODE-SELECTION ((SELF WEB-EDITOR)
-                               BUTTON)
-   (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))
-          (OBJECT (FIND-SELECTED-NODE WINDOW)))
-         (DECLARE (IL:SPECVARS OBJECT))                  (IL:* IL:\; "SPECVARS for whenHeldFn")
-         (IF (LISTP OBJECT)
-             (SETQ OBJECT (CAR OBJECT)))
-         (COND
-            ((NOT (NULL OBJECT))
-             (SETF (SLOT-VALUE SELF 'LAST-SELECTED-OBJECT)
-                   OBJECT)))
-         (IL:GETMOUSESTATE)
-         (WHEN OBJECT
-             (LET ((SELECTOR (NODE-ACTION SELF OBJECT BUTTON)))
-                  (COND
-                     (SELECTOR (DO-SELECTED-COMMAND SELF SELECTOR OBJECT)))))))
-
-(DEFMETHOD NODE-ACTION ((SELF WEB-EDITOR)
-                            NODE BUTTON)                     (IL:* IL:\; " 8-Apr-87 17:11")
-   (DECLARE (IL:SPECVARS WINDOW-FOR-MENU))
-   (LET ((WINDOW-FOR-MENU SELF))
-        (IL:GETMOUSESTATE)
-        (CHOICE-MENU SELF 
-
-               (IL:* IL:|;;| " A Hook for letting nodes tailor menu items.")
-
-               (NODE-MENU-ITEMS NODE BUTTON))))
-
-(DEFMETHOD NODE-MENU-ITEMS ((NODE WEB-NODE)
-                                BUTTON)
-   (CASE BUTTON
-       (IL:LEFT 'LEFT-BUTTON-ITEMS)
-       (IL:MIDDLE 'MIDDLE-BUTTON-ITEMS)))
-
-(DEFMETHOD CHOICE-MENU ((SELF WEB-EDITOR)
-                            ITEM-CV)                         (IL:* IL:\; "29-Dec-85 13:54")
-
-   (IL:* IL:|;;| 
- "Create a menu which allows subitems to be displayed.  Cache it in  the web-editor ")
-
-   (LET (ITEMS MENU)
-        (SETQ MENU (REST (ASSOC ITEM-CV (SLOT-VALUE SELF 'MENU-CACHE))))
-        (COND
-           ((AND MENU (IL:TYPE? IL:MENU MENU))
-            (IL:MENU MENU))
-           ((NOT (LISTP (SETQ ITEMS (GET-MENU-ITEMS SELF ITEM-CV))))
-            ITEMS)
-           (T (IL:SETQ MENU (IL:CREATE IL:MENU
-                                   IL:ITEMS IL:_ ITEMS
-                                   IL:MENUOFFSET IL:_ (IL:CREATEPOSITION -1 0)
-                                   IL:WHENSELECTEDFN IL:_ 'WEB-MENU-WHENSELECTEDFN
-                                   IL:WHENHELDFN IL:_ 'WINDOW-WHEN-HELD-FN
-                                   IL:CHANGEOFFSETFLG IL:_ T
-                                   IL:CENTERFLG IL:_ T))     (IL:* IL:\; "Cache menu if menus is T")
-              (IF (SLOT-VALUE SELF 'CACHE-MENU-P)
-                  (SETF (SLOT-VALUE SELF 'MENU-CACHE)
-                        (ACONS ITEM-CV MENU (SLOT-VALUE SELF 'MENU-CACHE))))
-              (IL:MENU MENU)))))
-
-(DEFMETHOD DO-SELECTED-COMMAND ((WEB-EDITOR WEB-EDITOR)
-                                    COMMAND OBJ &OPTIONAL NODE)
-                                                             (IL:* IL:\; "17-Sep-86 17:49")
-
-   (IL:* IL:|;;| "Do the selected command or forwards it to the object")
-
-   (IF COMMAND
-
-       (IL:* IL:|;;| "Take care of being passed in a dummy node from browser in Lattice mode.  --- Dummy nodes are indicated by having the object in a list")
-
-       (LET ((ARGS (IF (IL:LISTP COMMAND)
-                       (CDR COMMAND)
-                       NIL))
-             (COMMAND (IF (IL:LISTP COMMAND)
-                          (CAR COMMAND)
-                          COMMAND))
-             (OBJ (IF (IL:LISTP OBJ)
-                      (CAR OBJ)
-                      OBJ)))
-            (WHEN (IL:FMEMB COMMAND (SLOT-VALUE WEB-EDITOR 'LOCAL-COMMANDS))
-                (SETQ ARGS (CONS OBJ ARGS))
-                (SETQ OBJ WEB-EDITOR))
-
-            (IL:* IL:|;;| 
-   "Grays out the node at the beginning of the command, and ungrays it when the command completes.")
-
-            (SETQ NODE OBJ)
-            (IF NODE
-                (PROGN (SHADE-NODE WEB-EDITOR NODE IL:GRAYSHADE2)
-                       (IL:BLOCK 500)
-                       (SHADE-NODE WEB-EDITOR NODE IL:WHITESHADE)
-                       (APPLY COMMAND OBJ ARGS))
-                (APPLY COMMAND OBJ ARGS)))))
-
-(DEFMETHOD WHEN-MENU-ITEM-HELD ((SELF WEB-EDITOR)
-                                    ITEM MENU KEY)           (IL:* IL:\; " 8-Apr-87 17:13")
-
-(IL:* IL:|;;;| "What to do when the menu item is held")
-
-   (IL:PROMPTPRINT (OR (COND
-                          ((IL:NLISTP ITEM)
-                           NIL)
-                          (T (CADDR ITEM)))
-                       "When released this item will be selected")))
-
-(DEFMETHOD ITEM-MENU ((SELF WEB-EDITOR)
-                          ITEMS TITLE)                       (IL:* IL:\; "21-Apr-84 09:31")
-                                                             (IL:* IL:\; 
-                       "Create a simnple (one level) menu which will not overflow height of screen")
-   (IL:|create| IL:MENU
-          IL:ITEMS IL:_ ITEMS
-          IL:MENUCOLUMNS IL:_ (IL:ADD1 (IL:IQUOTIENT (IL:ITIMES (IL:FONTHEIGHT IL:MENUFONT)
-                                                            (IL:LENGTH ITEMS))
-                                              750))
-          IL:TITLE IL:_ TITLE
-          IL:CHANGEOFFSETFLG IL:_ T))
-
-(DEFMETHOD GET-MENU-ITEMS ((SELF WEB-EDITOR)
-                               ITEM-CV)                      (IL:* IL:\; "23-Oct-84 12:36")
-                                                             (IL:* IL:\; "Get item list for menu")
-   (SLOT-VALUE SELF ITEM-CV))
-
-(DEFMETHOD CLEAR-MENU-CACHE ((SELF WEB-EDITOR))          (IL:* IL:\; "11-Apr-86 14:46")
-                                                             (IL:* IL:\; 
-                                                           "Delete Menus saved on menus")
-   (SETF (SLOT-VALUE SELF 'MENU-CACHE)
-         NIL)
-   SELF)
-(IL:DEFINEQ
-
-(WEB-MENU-WHENSELECTEDFN
-  (IL:LAMBDA (ITEM MENU BUTTON)                     (IL:* IL:\; "Edited 14-Jul-87 17:43 by Rao")
-                                                             (IL:* IL:\; "13-DEC-83 21:03")
-    (PROG (SECOND-ELEMENT)
-          (RETURN (COND
-                     ((IL:NLISTP ITEM)
-                      ITEM)
-                     ((IL:NLISTP (IL:SETQ SECOND-ELEMENT (CADR ITEM)))
-                      SECOND-ELEMENT)
-                     ((EQ (CAR SECOND-ELEMENT)
-                          'PROGN)
-                      (IL:EVAL SECOND-ELEMENT))
-                     (T SECOND-ELEMENT))))))
-
-(WINDOW-WHEN-HELD-FN
-  (LAMBDA (ITEM MENU KEY)                           (IL:* IL:\; "Edited  9-Jul-87 11:58 by Rao")
-                                                             (IL:* IL:\; "29-Dec-85 15:28")
-                                                             (IL:* IL:\; 
-                                        "Send to window the message to respond to time out on menu")
-         (DECLARE (IL:SPECVARS WINDOW-FOR-MENU))
-         (WHEN-MENU-ITEM-HELD WINDOW-FOR-MENU ITEM MENU KEY)))
-)
-(IL:DEFINEQ
-
-(SUB-ITEM-SELECTION
-  (IL:LAMBDA (ITEM MENU BUTTON)                     (IL:* IL:\; "Edited 14-Jul-87 17:13 by Rao")
-                                                             (IL:* IL:\; "13-DEC-83 21:03")
-
-    (IL:* IL:|;;| "menu WHENSELECTEDFN which allows differential selection on LEFT and middle button.  For such differential selection item should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu")
-
-    (PROG (IT IT1)
-          (RETURN (COND
-                     ((IL:NLISTP ITEM)
-                      ITEM)
-                     ((IL:NLISTP (IL:SETQ IT (CADR ITEM)))
-                      IT)
-                     ((EQ (IL:SETQ IT1 (CAR IT))
-                          'QUOTE)
-                      (CADR IT))
-                     ((EQ IT1 'PROGN)
-                      (IL:EVAL IT))
-                     ((IL:LISTP IT1)
-                      (IL:EVAL IT1))
-                     (T IT1))))))
-
-(DUAL-SUB-ITEMS
-  (IL:LAMBDA (MENU ITEM)                            (IL:* IL:\; "Edited 14-Jul-87 17:14 by Rao")
-                                                             (IL:* IL:\; "13-DEC-83 21:07")
-
-    (IL:* IL:|;;| "menu WHENSELECTEDFN which allows differential selection on LEFT and middle button.  For such differential selection item should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu")
-
-    (PROG (IT IT1)
-          (RETURN (COND
-                     ((OR (IL:NLISTP ITEM)
-                          (IL:NLISTP (IL:SETQ IT (CADR ITEM)))
-                          (EQ (IL:SETQ IT1 (CAR IT))
-                              'QUOTE)
-                          (EQ IT1 'PROGN)
-                          (IL:NLISTP (IL:SETQ IT1 (CADR IT))))
-                      NIL)
-                     (T IT1))))))
-
-(WINDOW-WHEN-HELD-FN
-  (LAMBDA (ITEM MENU KEY)                           (IL:* IL:\; "Edited  9-Jul-87 11:58 by Rao")
-                                                             (IL:* IL:\; "29-Dec-85 15:28")
-                                                             (IL:* IL:\; 
-                                        "Send to window the message to respond to time out on menu")
-         (DECLARE (IL:SPECVARS WINDOW-FOR-MENU))
-         (WHEN-MENU-ITEM-HELD WINDOW-FOR-MENU ITEM MENU KEY)))
-
-(DO-MENU-METHOD
-  (IL:LAMBDA (OBJECT ITEMS)                         (IL:* IL:\; "Edited 14-Jul-87 17:15 by Rao")
-                                                             (IL:* IL:\; "13-NOV-83 16:20")
-    (PROG ((SELECTOR (AND ITEMS (DUAL-MENU ITEMS))))
-          (AND SELECTOR (RETURN (FUNCALL SELECTOR OBJECT))))))
-
-(DUAL-MENU
-  (IL:LAMBDA (ITEMS WHEN-HELD-FN)                   (IL:* IL:\; "Edited 14-Jul-87 17:16 by Rao")
-                                                             (IL:* IL:\; " 9-FEB-84 16:17")
-                                                             (IL:* IL:\; 
-                 "and pops up a menu which allows differential selection on LEFT an middle buttons")
-    (IL:MENU (IL:|create| IL:MENU
-                    IL:ITEMS IL:_ ITEMS
-                    IL:WHENSELECTEDFN IL:_ 'SUB-ITEM-SELECTION
-                    IL:SUBITEMFN IL:_ 'DUAL-SUB-ITEMS
-                    IL:WHENHELDFN IL:_ WHEN-HELD-FN
-                    IL:CHANGEOFFSETFLG IL:_ T))))
-
-(DUAL-SELECTION
-  (IL:LAMBDA (ITEM MENU BUTTON)                     (IL:* IL:\; "Edited 14-Jul-87 17:28 by Rao")
-                                                             (IL:* IL:\; "29-MAR-83 17:57")
-
-    (IL:* IL:|;;| "MENU WHENSELECTEDFN which allows differential selection on LEFT and middle button.  For such differential selection ITEM should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when ITEM is selected with middle, or midValue can be an itemList, which will be displayed in a subselection MENU")
-
-    (PROG (IT IT1)
-          (RETURN (COND
-                     ((IL:NLISTP ITEM)
-                      ITEM)
-                     ((IL:NLISTP (IL:SETQ IT (CADR ITEM)))
-                      IT)
-                     ((EQ (IL:SETQ IT1 (CAR IT))
-                          'QUOTE)
-                      (CADR IT))
-                     ((EQ IT1 'PROGN)
-                      (IL:EVAL IT))
-                     ((EQ BUTTON 'IL:LEFT)
-                      (COND
-                         ((IL:LISTP IT1)
-                          (IL:EVAL IT1))
-                         (T IT1)))
-                     ((IL:NLISTP (IL:SETQ IT1 (CADR IT)))
-                      IT1)
-                     (T (DUAL-MENU IT1)))))))
-)
-
-
-
-(IL:* IL:\; "Node Moving Protocol")
-
-
-(DEFMETHOD NODE-MOVE ((SELF WEB-EDITOR))
-   (LET ((OLD-REGIONS (MAKE-REG-ASSOC SELF))
-         NEW-REGIONS MOVED-PAIR NEW-FATHER CLOSEST-PAIR)
-        (NODE-MOVE-SHALLOW SELF)
-        (SETQ NEW-REGIONS (MAKE-REG-ASSOC SELF))
-        (SETQ MOVED-PAIR (IL:|for| |npair| IL:|in| NEW-REGIONS IL:|as| |opair|
-                            IL:|in| OLD-REGIONS IL:|thereis| (NOT (IL:EQUAL (CAR |opair|)
-                                                                                 (CAR |npair|)))))
-        (WHEN (AND MOVED-PAIR 
-
-                   (IL:* IL:|;;| "The moved guy has a parent")
-
-                   (SLOT-VALUE (CDR MOVED-PAIR)
-                          'PARENT))
-            (IL:DREMOVE MOVED-PAIR NEW-REGIONS)
-            (SETQ NEW-REGIONS 
-
-                  (IL:* IL:|;;| "Collect the pairs that havn't changed.")
-
-                  (IL:|bind| (SCIONS-OF-MOVED IL:_ (SCIONS (CDR MOVED-PAIR))) IL:|for| PAIR
-                     IL:|in| NEW-REGIONS IL:|unless| (IL:MEMBER (CDR PAIR)
-                                                                    SCIONS-OF-MOVED) IL:|collect|
-                                                                                     PAIR))
-            (SETQ CLOSEST-PAIR (IL:|bind| (\b IL:_ (IL:|fetch| IL:BOTTOM IL:|of|
-                                                                                 (CAR MOVED-PAIR)))
-                                      (\l IL:_ (IL:|fetch| IL:LEFT IL:|of| (CAR MOVED-PAIR)))
-                                  IL:|for| |pair| IL:|in| NEW-REGIONS
-                                  IL:|smallest| (IL:PLUS (ABS (IL:IDIFFERENCE (IL:|fetch|
-                                                                                   IL:BOTTOM
-                                                                                     IL:|of|
-                                                                                     (CAR |pair|))
-                                                                         \b))
-                                                           (ABS (IL:IDIFFERENCE (IL:|fetch|
-                                                                                 IL:LEFT
-                                                                                   IL:|of|
-                                                                                   (CAR |pair|))
-                                                                       \l)))))
-
-            (IL:* IL:|;;| 
-          "Either make moved node a sibling or a child of the node it is now closest to.")
-
-            (IL:|if| (IL:IGREATERP (IL:IDIFFERENCE (IL:|fetch| IL:LEFT IL:|of|
-                                                                               (CAR MOVED-PAIR))
-                                              (IL:|fetch| IL:LEFT IL:|of| (CAR CLOSEST-PAIR))
-                                              )
-                                15)
-                IL:|then| (IL:SETQ NEW-FATHER (CDR CLOSEST-PAIR))
-              IL:|else| (IL:SETQ NEW-FATHER (OR (SLOT-VALUE (CDR CLOSEST-PAIR)
-                                                           'PARENT)
-                                                    (CDR CLOSEST-PAIR))))
-            (MOVE-NODE (CDR MOVED-PAIR)
-                   NEW-FATHER)
-            (REORDER-TREE SELF NEW-FATHER))
-        (RECOMPUTE SELF)))
-
-(DEFMETHOD NODE-MOVE-SHALLOW ((SELF WEB-EDITOR))
-
-   (IL:* IL:|;;| "Just moves the node graphically with no deep impact")
-
-   (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW)))
-        (IL:RESETLST
-            (IL:RESETSAVE NIL (LIST (IL:FUNCTION IL:DSPOPERATION)
-                                    (IL:DSPOPERATION 'IL:INVERT WINDOW)
-                                    WINDOW))
-            (IL:GETMOUSESTATE)                               (IL:* IL:\; "Here to move a node.")
-            (IL:DSPOPERATION 'IL:INVERT WINDOW)
-            (IL:EDITMOVENODE WINDOW))))
-
-(DEFMETHOD SCIONS ((SELF WEB-NODE))                      (IL:* IL:\; "14-Nov-86 03:01")
-                                                             (IL:* IL:\; "Used by the Node Mover")
-   (LET ((TO-LINKS (GET-TO-LINKS SELF)))
-        (APPEND TO-LINKS (IL:|for| IL:|child| IL:|in| TO-LINKS IL:|join| (SCIONS 
-                                                                                           IL:|child|
-                                                                                            )))))
-
-(DEFMETHOD MAKE-REG-ASSOC ((SELF WEB-EDITOR))            (IL:* IL:\; "14-Nov-86 02:08")
-                                                             (IL:* IL:\; "Ho hum")
-   (IL:|for| X IL:|in| (SLOT-VALUE SELF 'STARTING-LIST) IL:|collect| (CONS (NODE-REGION
-                                                                                        SELF X)
-                                                                                       X)))
-
-(DEFMETHOD REORDER-TREE ((SELF WEB-EDITOR)
-                             ROOT)                           (IL:* IL:\; "14-Nov-86 02:35")
-   (LET ((CHILDREN (GET-TO-LINKS ROOT)))
-        (IF CHILDREN
-            (IL:SORT CHILDREN #'(IL:LAMBDA (C1 C2)
-                                  (LET ((R1 (NODE-REGION SELF C1))
-                                        (R2 (NODE-REGION SELF C2)))
-                                       (IL:LESSP (IL:|fetch| IL:BOTTOM IL:|of| R1)
-                                              (IL:|fetch| IL:BOTTOM IL:|of| R2))))))))
-
-(DEFMETHOD MOVE-NODE ((SELF WEB-NODE)
-                          NEW-PARENT)                        (IL:* IL:\; "29-Jan-87 17:55")
-   (LET ((OLD-PARENT (SLOT-VALUE SELF 'PARENT)))
-        (UNLESS (EQ OLD-PARENT NEW-PARENT)
-            (SETF (SLOT-VALUE SELF 'PARENT)
-                  NEW-PARENT)
-            (SETF (SLOT-VALUE OLD-PARENT 'TO-LINKS)
-                  (IL:DREMOVE SELF (SLOT-VALUE OLD-PARENT 'TO-LINKS)))
-            (SETF (SLOT-VALUE NEW-PARENT 'TO-LINKS)
-                  (IL:NCONC1 (SLOT-VALUE NEW-PARENT 'TO-LINKS)
-                         SELF))
-            T)))
-
-
-
-(IL:* IL:\; "")
-
-
-
-
-(IL:* IL:|;;| "")
-
-(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
-
-(IL:ADDTOVAR IL:NLAMA )
-
-(IL:ADDTOVAR IL:NLAML )
-
-(IL:ADDTOVAR IL:LAMA WINDOW-WHEN-HELD-FN WINDOW-WHEN-HELD-FN)
-)
-(IL:PUTPROPS IL:WEB-EDITOR IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1989 1991))
-(IL:DECLARE\: IL:DONTCOPY
-  (IL:FILEMAP (NIL (50310 53152 (WEB-WINDOW-AFTER-MOVE-FN 50323 . 50701) (WEB-WINDOW-BUTTON-EVENT-FN 
-50703 . 51146) (WEB-WINDOW-RESHAPE-FN 51148 . 51704) (WEB-WINDOW-CLOSE-FN 51706 . 52056) (
-IL:|PromptRead| 52058 . 53150)) (53153 53586 (WEB-WINDOW-EXPAND-FN 53166 . 53584)) (57488 65032 (
-TREE-ROOTS 57501 . 62883) (CHILD-NODES 62885 . 63646) (REACHABLE-NODES! 63648 . 65030)) (94827 108235 
-(BOX-PRINT-STRING 94840 . 101302) (BREAK-STRING-FOR-BOXING 101304 . 107100) (BOX-WINDOW-NODE 107102 . 
-108233)) (108273 111315 (FIND-SELECTED-NODE 108286 . 111313)) (119862 121033 (WEB-MENU-WHENSELECTEDFN 
-119875 . 120505) (WINDOW-WHEN-HELD-FN 120507 . 121031)) (121034 126038 (SUB-ITEM-SELECTION 121047 . 
-122147) (DUAL-SUB-ITEMS 122149 . 123158) (WINDOW-WHEN-HELD-FN 123160 . 123684) (DO-MENU-METHOD 123686
- . 124026) (DUAL-MENU 124028 . 124723) (DUAL-SELECTION 124725 . 126036)))))
-IL:STOP
diff --git a/obsolete/clos/2.0/boot.lisp b/obsolete/clos/2.0/boot.lisp
deleted file mode 100644
index 5385f6ff..00000000
--- a/obsolete/clos/2.0/boot.lisp
+++ /dev/null
@@ -1,1297 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;; File converted on  2-Apr-91 16:40:32 from source bood
-
-
-
-(in-package "CLOS")
-
-;;; Shadow, Export, Require, Use-package, and Import forms should follow here
-
-
-
-;;; ************************************************************************* Copyright (c) 1985,
-;;; 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this
-;;; software and preparation of derivative works based upon this software are permitted.  Any
-;;; distribution of this software or derivative works must comply with all applicable United States
-;;; export control laws. This software is made available AS IS, and Xerox Corporation makes no
-;;; warranty about the software, its performance or its conformity to any specification. Any person
-;;; obtaining a copy of this software is requested to send their name and post office or electronic
-;;; mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or
-;;; send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests
-;;; for improvements are also welcome.
-;;; ************************************************************************* 
-
-
-#|
-
-The CommonLoops evaluator is meta-circular.  
-
-Most of the code in CLOS is methods on generic functions, including most of
-the code that actually implements generic functions and method lookup.
-
-So, we have a classic bootstrapping problem.   The solution to this is to
-first get a cheap implementation of generic functions running, these are
-called early generic functions.  These early generic functions and the
-corresponding early methods and early method lookup are used to get enough
-of the system running that it is possible to create real generic functions
-and methods and implement real method lookup.  At that point (done in the
-file FIXUP) the function fix-early-generic-functions is called to convert
-all the early generic functions to real generic functions.
-
-The cheap generic functions are built using the same funcallable-instance
-objects real generic-functions are made out of.  This means that as CLOS
-is being bootstrapped, the cheap generic function objects which are being
-created are the same objects which will later be real generic functions.
-This is good because:
-  - we don't cons garbage structure
-  - we can keep pointers to the cheap generic function objects
-    during booting because those pointers will still point to
-    the right object after the generic functions are all fixed
-    up
-
-
-
-This file defines the defmethod macro and the mechanism used to expand it.
-This includes the mechanism for processing the body of a method.  defmethod
-basically expands into a call to load-defmethod, which basically calls
-add-method to add the method to the generic-function.  These expansions can
-be loaded either during bootstrapping or when CLOS is fully up and running.
-
-An important effect of this structure is it means we can compile files with
-defmethod forms in them in a completely running CLOS, but then load those files
-back in during bootstrapping.  This makes development easier.  It also means
-there is only one set of code for processing defmethod.  Bootstrapping works
-by being sure to have load-method be careful to call only primitives which
-work during bootstrapping.
-
-|#
-
-(proclaim '(notinline make-a-method add-named-method ensure-generic-function-using-class add-method 
-                  remove-method))
-
-(defvar *early-functions* '((make-a-method early-make-a-method real-make-a-method)
-                            (add-named-method early-add-named-method real-add-named-method)))
-
-
-;;; For each of the early functions, arrange to have it point to its early definition.  Do this in a
-;;; way that makes sure that if we redefine one of the early definitions the redefinition will take
-;;; effect.  This makes development easier. The function which generates the redirection closure is
-;;; pulled out into a separate piece of code because of a bug in ExCL which causes this not to work
-;;; if it is inlined. 
-
-
-(eval-when (load eval)
-       (defun redirect-early-function-internal (to)
-              #'(lambda (&rest args)
-                       (apply (symbol-function to)
-                              args))) 
-	 (dolist (fns *early-functions*)
-    (let ((name (car fns))
-	  (early-name (cadr fns)))
-      (setf (symbol-function name)
-	    (redirect-early-function-internal early-name))))
-)
-
-
-;;; *generic-function-fixups* is used by fix-early-generic-functions to convert the few functions in
-;;; the bootstrap which are supposed to be generic functions but can't be early on. 
-
-
-(defvar *generic-function-fixups* '((add-method ((generic-function method)
-                                                             ; lambda-list
-                                                 (standard-generic-function method)
-                                                             ; specializers
-                                                 real-add-method))
-                                                             ; method-function
-                                    (remove-method ((generic-function method)
-                                                    (standard-generic-function method)
-                                                    real-remove-method))
-                                    (get-method ((generic-function qualifiers specializers &optional
-                                                        (errorp t))
-                                                 (standard-generic-function t t)
-                                                 real-get-method))
-                                    (ensure-generic-function-using-class ((generic-function 
-                                                                                 function-specifier 
-                                                                                 &key 
-                                                                               generic-function-class
-                                                                                 environment 
-                                                                                 &allow-other-keys)
-                                                                          (generic-function t)
-                                                                          
-                                                         real-ensure-gf-using-class--generic-function
-                                                                          )
-                                           ((generic-function function-specifier &key 
-                                                   generic-function-class environment 
-                                                   &allow-other-keys)
-                                            (null t)
-                                            real-ensure-gf-using-class--null))))
-
-
-;;; 
-
-
-(defmacro defgeneric (function-specifier lambda-list &body options)
-       (expand-defgeneric function-specifier lambda-list options))
-
-(defun expand-defgeneric (function-specifier lambda-list options)
-       (when (listp function-specifier)
-           (do-standard-defsetf-1 (cadr function-specifier)))
-       (let ((initargs nil))
-            (flet ((duplicate-option (name)
-                          (error "The option ~S appears more than once." name)))
-                  
-                  ;; INITARG takes this screwy new argument to get around a bad interaction between
-                  ;; lexical macros and setf in the Lucid compiler. 
-                  (macrolet ((initarg (key &optional new)
-                                    (if new
-                                        `(setf (getf initargs ,key)
-                                               ,new)
-                                        `(getf initargs ,key))))
-                         (dolist (option options)
-                             (ecase (car option)
-                                 (:argument-precedence-order 
-                                    (if (initarg :argument-precedence-order)
-                                        (duplicate-option :argument-precedence-order)
-                                        (initarg :argument-precedence-order
-                                               `',(cdr option))))
-                                 (declare (initarg :declarations (append (cdr option)
-                                                                        (initarg :declarations))))
-                                 (:documentation (if (initarg :documentation)
-                                                     (duplicate-option :documentation)
-                                                     (initarg :documentation
-                                                            `',(cadr option))))
-                                 (:method-combination 
-                                    (if (initarg :method-combination)
-                                        (duplicate-option :method-combination)
-                                        (initarg :method-combination
-                                               `',(cdr option))))
-                                 (:generic-function-class 
-                                    (if (initarg :generic-function-class)
-                                        (duplicate-option :generic-function-class)
-                                        (initarg :generic-function-class
-                                               `',(cadr option))))
-                                 (:method-class (if (initarg :method-class)
-                                                    (duplicate-option :method-class)
-                                                    (initarg :method-class
-                                                           `',(cadr option))))
-                                 (:method (error "DEFGENERIC doesn't support the :METHOD option yet."
-                                                 ))))
-                         (let ((declarations (initarg :declarations)))
-                              (when declarations
-                                  (initarg :declarations `',declarations)))))
-            (make-top-level-form `(defgeneric ,function-specifier)
-                   *defgeneric-times*
-                   `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))
-
-(defun load-defgeneric (function-specifier lambda-list &rest initargs)
-       (when (listp function-specifier)
-           (do-standard-defsetf-1 (cadr function-specifier)))
-       (apply #'ensure-generic-function function-specifier :lambda-list lambda-list 
-              :definition-source `((defgeneric ,function-specifier)
-                                   ,(load-truename))
-              initargs))
-
-
-;;; 
-
-
-(defmacro defmethod (&rest args &environment env)
-       (declare (arglist name {method-qualifier}* specialized-lambda-list &body body))
-       (multiple-value-bind (name qualifiers lambda-list body)
-              (parse-defmethod args)
-              (let ((proto-method (method-prototype-for-gf name)))
-                   (expand-defmethod proto-method name qualifiers lambda-list body env))))
-
-
-;;; takes a name which is either a generic function name or a list specifying a setf generic
-;;; function (like: (SETF <generic-function-name>)).  Returns the prototype instance of the
-;;; method-class for that generic function. If there is no generic function by that name, this
-;;; returns the default value, the prototype instance of the class STANDARD-METHOD.  This default
-;;; value is also returned if the spec names an ordinary function or even a macro.  In effect, this
-;;; leaves the signalling of the appropriate error until load time. NOTE that during bootstrapping,
-;;; this function is allowed to return NIL. 
-
-
-(defun method-prototype-for-gf (name)
-       (let ((gf? (and (gboundp name)
-                       (gdefinition name))))
-            (cond ((neq *boot-state* 'complete)
-                   nil)
-                  ((or (null gf?)
-                       (not (generic-function-p gf?)))
-                                                             ; Someone else MIGHT error at load
-                                                             ; time. 
-                   (class-prototype (find-class 'standard-method)))
-                  (t (class-prototype (or (generic-function-method-class gf?)
-                                          (find-class 'standard-method)))))))
-
-(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
-  (when (listp name) (do-standard-defsetf-1 (cadr name)))
-  (multiple-value-bind (fn-form specializers doc plist)
-      (expand-defmethod-internal name qualifiers lambda-list body env)
-    `(load-defmethod
-      ',(if proto-method
-	    (class-name (class-of proto-method))
-	    'standard-method)
-      ',name
-      ',qualifiers
-      (list ,@(mapcar #'(lambda (specializer)
-			  (if (and (consp specializer)
-				   (eq (car specializer) 'eql))
-			      ``(eql ,,(cadr specializer))
-			      `',specializer))
-	       specializers))
-      ',(specialized-lambda-list-lambda-list lambda-list)
-      ',doc
-      ',(getf plist :isl-cache-symbol)	;Paper over a bug in KCL by
-					;passing the cache-symbol
-					;here in addition to in the
-					;plist.
-      ',plist
-      ,fn-form)))
-
-(defun
- expand-defmethod-internal
- (generic-function-name qualifiers specialized-lambda-list body env)
- (declare (values fn-form specializers doc)
-        (ignore qualifiers))
- (when (listp generic-function-name)
-     (do-standard-defsetf-1 (cadr generic-function-name)))
- (multiple-value-bind
-  (documentation declarations real-body)
-  (extract-declarations body)
-  (multiple-value-bind
-   (parameters lambda-list specializers)
-   (parse-specialized-lambda-list specialized-lambda-list)
-   (let*
-    ((required-parameters (mapcar #'(lambda (r s)
-                                           (declare (ignore s))
-                                           r)
-                                 parameters specializers))
-     (parameters-to-reference (make-parameter-references specialized-lambda-list required-parameters
-                                     declarations generic-function-name specializers))
-     (class-declarations
-      `(declare ,@(remove nil (mapcar #'(lambda (a s)
-                                               (and (symbolp s)
-                                                    (neq s 't)
-                                                    `(class ,a ,s)))
-                                     parameters specializers))))
-     (method-lambda 
-
-            ;; Remove the documentation string and insert the appropriate class declarations.  The
-            ;; documentation string is removed to make it easy for us to insert new declarations
-            ;; later, they will just go after the cadr of the method lambda.  The class declarations
-            ;; are inserted to communicate the class of the method's arguments to the code walk. 
-            (let nil `(lambda ,lambda-list ,class-declarations ,@declarations (progn 
-                                                                                     ,@
-                                                                              parameters-to-reference
-                                                                                     )
-                             (block ,(if (listp generic-function-name)
-                                         (cadr generic-function-name)
-                                         generic-function-name)
-                                    ,@real-body))))
-     (call-next-method-p nil)
-                                                             ; flag indicating that call-next-method
-                                                             ; should be in the method definition 
-     (closurep nil)
-                                                             ; flag indicating that
-                                                             ; #'call-next-method was seen in the
-                                                             ; body of a method 
-     (next-method-p-p nil)
-                                                             ; flag indicating that next-method-p
-                                                             ; should be in the method definition 
-     (save-original-args nil)
-                                                             ; flag indicating whether or not the
-                                                             ; original arguments to the method must
-                                                             ; be preserved.  This happens for two
-                                                             ; reasons: - the method takes &mumble
-                                                             ; args, so one of the lexical functions
-                                                             ; might be used in a default value form
-                                                             ; - call-next-method is used without
-                                                             ; arguments at least once in the body
-                                                             ; of the method 
-     (original-args nil)
-     (applyp nil)
-                                                             ; flag indicating whether or not the
-                                                             ; method takes &mumble arguments. If it
-                                                             ; does, it means call-next-method
-                                                             ; without arguments must be APPLY'd to
-                                                             ; original-args.  If this gets set
-                                                             ; true, save-original-args is set so as
-                                                             ; well 
-     (aux-bindings nil)
-                                                             ; Suffice to say that &aux is one of
-                                                             ; damndest things to have put in a
-                                                             ; language. 
-     (slots (mapcar #'list required-parameters))
-     (plist nil)
-     (walked-lambda nil))
-    (flet ((walk-function (form context env)
-                  (cond ((not (eq context ':eval))
-                         form)
-                        ((not (listp form))
-                         form)
-                        ((eq (car form)
-                             'call-next-method)
-                         (setq call-next-method-p 't)
-                         (unless (cdr form)
-                                (setq save-original-args t))
-                         form)
-                        ((eq (car form)
-                             'next-method-p)
-                         (setq next-method-p-p 't)
-                         form)
-                        ((and (eq (car form)
-                                  'function)
-                              (cond ((eq (cadr form)
-                                         'call-next-method)
-                                     (setq call-next-method-p 't)
-                                     (setq save-original-args 't)
-                                     (setq closurep t)
-                                     form)
-                                    ((eq (cadr form)
-                                         'next-method-p)
-                                     (setq next-method-p-p 't)
-                                     (setq closurep t)
-                                     form)
-                                    (t nil))))
-                        ((and (or (eq (car form)
-                                      'slot-value)
-                                  (eq (car form)
-                                      'set-slot-value))
-                              (symbolp (cadr form))
-                              (constantp (caddr form)))
-                         (let ((parameter (can-optimize-access (cadr form)
-                                                 required-parameters env)))
-                              (if (null parameter)
-                                  form
-                                  (ecase (car form)
-                                      (slot-value (optimize-slot-value slots parameter form))
-                                      (set-slot-value (optimize-set-slot-value slots parameter form)))
-)))
-                        (t form))))
-          (setq walked-lambda (walk-form method-lambda env #'walk-function))
-          
-          ;; Add &allow-other-keys to the lambda list as an interim way of implementing lambda list
-          ;; congruence rules. 
-          (when (and (memq '&key lambda-list)
-                     (not (memq '&allow-other-keys lambda-list)))
-              (let* ((rll (reverse lambda-list))
-                     (aux (memq '&aux rll)))
-                    (setq lambda-list (if aux
-                                          (progn (setf (cdr aux)
-                                                       (cons '&allow-other-keys (cdr aux)))
-                                                 (nreverse rll))
-                                          (nconc (nreverse rll)
-                                                 (list '&allow-other-keys))))))
-          
-          ;; Scan the lambda list to determine whether this method takes &mumble arguments.  If it
-          ;; does, we set applyp and save-original-args true. This is also the place where we
-          ;; construct the original arguments lambda list if there has to be one. 
-          (dolist (p lambda-list)
-              (if (memq p lambda-list-keywords)
-                  (if (eq p '&aux)
-                      (progn (setq aux-bindings (cdr (memq '&aux lambda-list)))
-                             (return nil))
-                      (progn (setq applyp t save-original-args t)
-                             (push '&rest original-args)
-                             (push (make-symbol "AMPERSAND-ARGS")
-                                   original-args)
-                             (return nil)))
-                  (push (make-symbol (symbol-name p))
-                        original-args)))
-          (setq original-args (if save-original-args
-                                  (nreverse original-args)
-                                  nil))
-          (multiple-value-bind (ignore walked-declarations walked-lambda-body)
-                 (extract-declarations (cddr walked-lambda))
-                 (declare (ignore ignore))
-                 (when (some #'cdr slots)
-                     (setq slots (slot-name-lists-from-slots slots))
-                     (setq plist (list* :isl slots plist))
-                     (setq walked-lambda-body (add-pv-binding walked-lambda-body plist 
-                                                     required-parameters)))
-                 (when (or next-method-p-p call-next-method-p)
-                     (setq plist (list* :needs-next-methods-p 't plist)))
-                 
-
-;;; changes are here... (mt)
-
-                 (let ((fn-body (if (or call-next-method-p next-method-p-p)
-                                    (add-lexical-functions-to-method-lambda
-                                     walked-declarations walked-lambda-body
-                                     `(lambda ,lambda-list ,@walked-declarations 
-                                             ,.walked-lambda-body)
-                                     original-args lambda-list save-original-args applyp aux-bindings
-                                     call-next-method-p next-method-p-p closurep)
-                                    `(lambda ,lambda-list ,@walked-declarations ,.walked-lambda-body))
-                              ))
-                      (values `#',fn-body specializers documentation plist))))))))
-
-(defun
- add-lexical-functions-to-method-lambda
- (walked-declarations walked-lambda-body walked-lambda original-args lambda-list save-original-args 
-        applyp aux-bindings call-next-method-p next-method-p-p closurep)
- (cond
-  ((and (null closurep)
-        (null applyp)
-        (null save-original-args))
-   
-   ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, and all args are mandatory
-   ;; (else APPLYP would be true). 
-   `(lambda ,lambda-list ,@walked-declarations
-           (let ((.next-method. (car *next-methods*))
-                 (.next-methods. (cdr *next-methods*)))
-                (macrolet ((call-next-method ,lambda-list '(if .next-method.
-                                                               (let ((*next-methods* .next-methods.))
-                                                                    (funcall .next-method.
-                                                                           ,@lambda-list))
-                                                               (error "No next method.")))
-                           (next-method-p nil `(not (null .next-method.))))
-                       ,@walked-lambda-body))))
-  ((and (null closurep)
-        (null applyp)
-        save-original-args)
-   
-   ;; OK to use MACROLET.  CALL-NEXT-METHOD is sometimes called in the body with zero args, so we
-   ;; have to save the original args. 
-   (if save-original-args
-       
-       ;; CALL-NEXT-METHOD is sometimes called with no args
-       `(lambda ,original-args
-               (let ((.next-method. (car *next-methods*))
-                     (.next-methods. (cdr *next-methods*)))
-                    (macrolet ((call-next-method
-                                (&rest cnm-args)
-                                `(if .next-method.
-                                     (let ((*next-methods* .next-methods.))
-                                          (funcall .next-method. ,@(if cnm-args
-                                                                       cnm-args
-                                                                       ',original-args)))
-                                     (error "No next method.")))
-                               (next-method-p nil `(not (null .next-method.))))
-                           (let* (,@(mapcar #'list lambda-list original-args)
-                                  ,@aux-bindings)
-                                 ,@walked-declarations
-                                 ,@walked-lambda-body))))))
-  ((and (null save-original-args)
-        (null applyp))
-   
-   ;; We don't have to save the original arguments.  In addition, this method doesn't take any
-   ;; &mumble arguments (this means that there is no way the lexical functions can be used inside of
-   ;; the default value form for an &mumble argument). We can expand this into a simple lambda
-   ;; expression with an FLET to define the lexical functions. 
-   `(lambda ,lambda-list ,@walked-declarations
-           (let ((.next-method. (car *next-methods*))
-                 (.next-methods. (cdr *next-methods*)))
-                (flet (,@(and call-next-method-p '((call-next-method (&rest cnm-args)
-                                                          (if .next-method.
-                                                              (let ((*next-methods* .next-methods.))
-                                                                   (apply .next-method. cnm-args))
-                                                              (error "No next method.")))))
-                       ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.))))))
-                      ,@walked-lambda-body))))
-  ((null applyp)
-   
-   ;; This method doesn't accept any &mumble arguments.  But we do have to save the original
-   ;; arguments (this is because call-next-method is being called with no arguments). Have to be
-   ;; careful though, there may be multiple calls to call-next-method, all we know is that at least
-   ;; one of them is with no arguments. 
-   `(lambda ,original-args
-           (let ((.next-method. (car *next-methods*))
-                 (.next-methods. (cdr *next-methods*)))
-                (flet (,@(and call-next-method-p
-                              `((call-next-method (&rest cnm-args)
-                                       (if .next-method.
-                                           (let ((*next-methods* .next-methods.))
-                                                (if cnm-args
-                                                    (apply .next-method. cnm-args)
-                                                    (funcall .next-method. ,@original-args)))
-                                           (error "No next method.")))))
-                       ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.))))))
-                      (let* (,@(mapcar #'list (remtail lambda-list (memq '&aux lambda-list))
-                                      original-args)
-                             ,@aux-bindings)
-                            ,@walked-declarations
-                            ,@walked-lambda-body)))))
-  (t
-   
-   ;; This is the fully general case. We must allow for the lexical functions being used inside the
-   ;; default value forms of &mumble arguments, and if must allow for call-next-method being called
-   ;; with no arguments. 
-   `(lambda
-     ,original-args
-     (let
-      ((.next-method. (car *next-methods*))
-       (.next-methods. (cdr *next-methods*)))
-      (flet (,@(and call-next-method-p
-                    `((call-next-method (&rest cnm-args)
-                             (if .next-method.
-                                 (let ((*next-methods* .next-methods.))
-                                      (if cnm-args
-                                          (apply .next-method. cnm-args)
-                                          (apply .next-method. ,@(remove '&rest original-args))))
-                                 (error "No next method.")))))
-             ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.))))))
-            (apply #',walked-lambda ,@(remove '&rest original-args))))))))
-
-(defun make-parameter-references (specialized-lambda-list required-parameters declarations 
-                                        generic-function-name specializers)
-       (flet ((ignoredp (symbol)
-                     (dolist (decl (cdar declarations))
-                         (when (and (eq (car decl)
-                                        'ignore)
-                                    (memq symbol (cdr decl)))
-                               (return t)))))
-             (gathering ((references (collecting)))
-                    (iterate ((s (list-elements specialized-lambda-list))
-                              (p (list-elements required-parameters)))
-                           (progn p)
-                           (cond ((not (listp s)))
-                                 ((ignoredp (car s))
-                                  (warn "In defmethod ~S ~S, there is a~%~
-                      redundant ignore declaration for the parameter ~S." generic-function-name 
-                                        specializers (car s)))
-                                 (t (gather (car s)
-                                           references)))))))
-
-(defvar *method-function-plist* (make-hash-table :test #'eq))
-
-(defun method-function-plist (method-function)
-       (gethash method-function *method-function-plist*))
-
-(defun |SETF CLOS METHOD-FUNCTION-PLIST| (val method-function)
-       (setf (gethash method-function *method-function-plist*)
-             val))
-
-(defun method-function-get (method-function key)
-       (getf (method-function-plist method-function)
-             key))
-
-(defun |SETF CLOS METHOD-FUNCTION-GET| (val method-function key)
-       (setf (getf (method-function-plist method-function)
-                   key)
-             val))
-
-(defun method-function-isl (method-function)
-       (method-function-get method-function :isl))
-
-(defun method-function-needs-next-methods-p (method-function)
-       (method-function-get method-function :needs-next-methods-p))
-
-(defun load-defmethod (class name quals specls ll doc isl-cache-symbol plist fn)
-       (when (listp name)
-           (do-standard-defsetf-1 (cadr name)))
-       (let ((method-spec (make-method-spec name quals specls)))
-            (record-definition 'method method-spec)
-            (setq fn (set-function-name fn method-spec))
-            (load-defmethod-internal name quals specls ll doc isl-cache-symbol plist fn class)))
-
-(defun load-defmethod-internal (gf-spec qualifiers specializers lambda-list doc isl-cache-symbol 
-                                      plist fn method-class)
-       (when (listp gf-spec)
-           (do-standard-defsetf-1 (cadr gf-spec)))
-       (when plist
-           (setq plist (copy-list plist))
-                                                             ; Do this to keep from affecting the
-                                                             ; plist that is about to be dumped when
-                                                             ; we are compiling. 
-           (let ((uisl (getf plist :isl))
-                 (isl nil))
-                (when uisl
-                    (setq isl (intern-slot-name-lists uisl))
-                    (setf (getf plist :isl)
-                          isl))
-                (when isl-cache-symbol
-                    (setf (getf plist :isl-cache-symbol)
-                          isl-cache-symbol)
-                    (set isl-cache-symbol isl)))
-           (setf (method-function-plist fn)
-                 plist))
-       (let ((method (add-named-method gf-spec qualifiers specializers lambda-list fn :documentation
-                            doc :definition-source `((defmethod ,gf-spec ,@qualifiers ,specializers)
-                                                     ,(load-truename)))))
-            (unless (or (eq method-class 'standard-method)
-                        (eq (find-class method-class nil)
-                            (class-of method)))
-                (format *error-output* "At the time the method with qualifiers ~:~S and~%~
-               specializers ~:S on the generic function ~S~%~
-               was compiled, the method-class for that generic function was~%~
-               ~S.  But, the method class is now ~S, this~%~
-               may mean that this method was compiled improperly." qualifiers specializers gf-spec 
-                       method-class (class-name (class-of method))))
-            method))
-
-(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
-       `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
-
-                                                             ; Early generic-function support
-
-
-
-;;; 
-
-
-(defvar *early-generic-functions* nil)
-
-(defun ensure-generic-function (function-specifier &rest all-keys &key environment &allow-other-keys)
-       (declare (ignore environment))
-       (let ((existing (and (gboundp function-specifier)
-                            (gdefinition function-specifier))))
-            (if (and existing (eq *boot-state* 'complete)
-                     (null (generic-function-p existing)))
-                (generic-clobbers-function function-specifier)
-                (apply #'ensure-generic-function-using-class existing function-specifier all-keys))))
-
-(defun generic-clobbers-function (function-specifier)
-       (error "~S already names an ordinary function or a macro,~%~
-                  you may want to replace it with a generic function, but doing so~%~
-                  will require that you decide what to do with the existing function~%~
-                  definition.~%~
-                  The CLOS-specific function MAKE-SPECIALIZABLE may be useful to you." 
-              function-specifier))
-
-
-;;; This is the early definition of ensure-generic-function-using-class. The static-slots field of
-;;; the funcallable instances used as early generic functions is used to store the early methods and
-;;; early discriminator code for the early generic function.  The static slots field of the fins
-;;; contains a list whose: CAR    -   a list of the early methods on this early gf CADR   -   the
-;;; early discriminator code for this method 
-
-
-(defun ensure-generic-function-using-class (existing spec &rest keys)
-       (declare (ignore keys))
-       (if* existing existing (pushnew spec *early-generic-functions* :test #'equal)
-            (let ((fin (allocate-funcallable-instance-1)))
-                 (setf (gdefinition spec)
-                       fin)
-                 (setf (fsc-instance-slots fin)
-                       (list nil nil))
-                 fin)))
-
-(defun early-gf-p (x)
-       (and (fsc-instance-p x)
-            (listp (fsc-instance-slots x))))
-
-(defmacro early-gf-methods (early-gf)
-                                                             ; These are macros so that
-       `(car (fsc-instance-slots ,early-gf)))
-
-                                                             ; they can be setf'd. 
-
-
-(defmacro early-gf-discriminator-code (early-gf)
-                                                             ; 
-       `(cadr (fsc-instance-slots ,early-gf)))
-
-                                                             ; 
-
-
-(defmacro real-ensure-gf-internal (gf-class all-keys env)
-       `(progn (cond ((symbolp ,gf-class)
-                      (setq ,gf-class (find-class ,gf-class t ,env)))
-                     ((classp ,gf-class))
-                     (t (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
-                    class nor a symbol that names a class." ,gf-class)))
-               (remf ,all-keys :generic-function-class)
-               (remf ,all-keys :environment)
-               (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
-                    (unless (eq combin '.shes-not-there.)
-                        (setf (getf ,all-keys :method-combination)
-                              (find-method-combination (class-prototype ,gf-class)
-                                     (car combin)
-                                     (cdr combin)))))))
-
-(defun real-ensure-gf-using-class--generic-function (existing function-specifier &rest all-keys &key
-                                                           environment (generic-function-class
-                                                                        'standard-generic-function 
-                                                                        gf-class-p)
-                                                           &allow-other-keys)
-       (declare (ignore function-specifier))
-       (real-ensure-gf-internal generic-function-class all-keys environment)
-       (unless (or (null gf-class-p)
-                   (eq (class-of existing)
-                       generic-function-class))
-              (change-class existing generic-function-class))
-       (apply #'reinitialize-instance existing all-keys))
-
-(defun real-ensure-gf-using-class--null (existing function-specifier &rest all-keys &key environment
-                                               (generic-function-class 'standard-generic-function)
-                                               &allow-other-keys)
-       (declare (ignore existing))
-       (real-ensure-gf-internal generic-function-class all-keys environment)
-       (setf (gdefinition function-specifier)
-             (apply #'make-instance generic-function-class :name function-specifier all-keys)))
-
-(defun early-make-a-method (class qualifiers arglist specializers function doc &optional slot-name)
-       (let ((parsed nil)
-             (unparsed nil))
-            
-            ;; Figure out whether we got class objects or class names as the specializers and set
-            ;; parsed and unparsed appropriately.  If we got class objects, then we can compute
-            ;; unparsed, but if we got class names we don't try to compute parsed. Note that the use
-            ;; of not symbolp in this call to every should be read as 'classp' we can't use classp
-            ;; itself because it doesn't exist yet. 
-            (if (every #'(lambda (s)
-                                (not (symbolp s)))
-                       specializers)
-                (setq parsed specializers unparsed (mapcar #'(lambda (s)
-                                                                    (if (eq s 't)
-                                                                        't
-                                                                        (class-name s)))
-                                                          specializers))
-                (setq unparsed specializers parsed nil))
-            (list :early-method                              ; This is an early method dammit!
-                  function
-                                                             ; Function is here for the benefit of
-                                                             ; early-lookup-method. 
-                  parsed
-                                                             ; The parsed specializers.  This is
-                                                             ; used by early-method-specializers to
-                                                             ; cache the parse.  Note that this only
-                                                             ; comes into play when there is more
-                                                             ; than one early method on an early gf.
-                  (list class                                ; A list to which real-make-a-method
-                        qualifiers
-                                                             ; can be applied to make a real method
-                        arglist
-                                                             ; corresponding to this early one.
-                        unparsed function doc slot-name))))
-
-(defun real-make-a-method (class qualifiers lambda-list specializers function doc &optional slot-name
-                                 )
-       
-       ;; Hmm what is this use of when buying me??
-       (when (some #'(lambda (x)
-                            (and (neq x 't)
-                                 (symbolp x)))
-                   specializers)
-           (setq specializers (parse-specializers specializers)))
-       (make-instance class :qualifiers qualifiers :lambda-list lambda-list :specializers 
-              specializers :function function :documentation doc :slot-name slot-name 
-              :allow-other-keys t))
-
-(defun early-method-function (early-method)
-       (cadr early-method))
-
-
-;;; Fetch the specializers of an early method.  This is basically just a simple accessor except that
-;;; when the second argument is t, this converts the specializers from symbols into class objects. 
-;;; The class objects are cached in the early method, this makes bootstrapping faster because the
-;;; class objects only have to be computed once. NOTE: the second argument should only be passed as
-;;; T by early-lookup-method. this is to implement the rule that only when there is more than one
-;;; early method on a generic function is the conversion from class names to class objects done. the
-;;; corresponds to the fact that we are only allowed to have one method on any generic function up
-;;; until the time classes exist. 
-
-
-(defun early-method-specializers (early-method &optional objectsp)
-       (if (and (listp early-method)
-                (eq (car early-method)
-                    :early-method))
-           (cond ((eq objectsp 't)
-                  (or (caddr early-method)
-                      (setf (caddr early-method)
-                            (mapcar #'find-class (cadddr (cadddr early-method))))))
-                 (t (cadddr (cadddr early-method))))
-           (error "~S is not an early-method." early-method)))
-
-(defun early-method-qualifiers (early-method)
-       (cadr (cadddr early-method)))
-
-(defun early-add-named-method (generic-function-name qualifiers specializers arglist function &rest 
-                                     options)
-       (declare (ignore options))
-       (let* ((gf (ensure-generic-function generic-function-name))
-              (existing (dolist (m (early-gf-methods gf))
-                            (when (and (equal (early-method-specializers m)
-                                              specializers)
-                                       (equal (early-method-qualifiers m)
-                                              qualifiers))
-                                  (return m))))
-              (new (make-a-method 'standard-method qualifiers arglist specializers function nil)))
-             (when existing (remove-method gf existing))
-             (add-method gf new)))
-
-
-;;; This is the early version of add-method.  Later this will become a generic function.  See
-;;; fix-early-generic-functions which has special knowledge about add-method. 
-
-
-(defun add-method (generic-function method)
-       (when (not (fsc-instance-p generic-function))
-             (error "Early add-method didn't get a funcallable instance."))
-       (when (not (and (listp method)
-                       (eq (car method)
-                           :early-method)))
-             (error "Early add-method didn't get an early method."))
-       (push method (early-gf-methods generic-function))
-       (early-update-discriminator-code generic-function))
-
-
-;;; This is the early version of remove method. 
-
-
-(defun remove-method (generic-function method)
-       (when (not (fsc-instance-p generic-function))
-             (error "Early remove-method didn't get a funcallable instance."))
-       (when (not (and (listp method)
-                       (eq (car method)
-                           :early-method)))
-             (error "Early remove-method didn't get an early method."))
-       (setf (early-gf-methods generic-function)
-             (remove method (early-gf-methods generic-function)))
-       (early-update-discriminator-code generic-function))
-
-
-;;; And the early version of get-method. 
-
-
-(defun get-method (generic-function qualifiers specializers &optional (errorp t))
-       (if (early-gf-p generic-function)
-           (or (dolist (m (early-gf-methods generic-function))
-                   (when (and (or (equal (early-method-specializers m nil)
-                                         specializers)
-                                  (equal (early-method-specializers m 't)
-                                         specializers))
-                              (equal (early-method-qualifiers m)
-                                     qualifiers))
-                         (return m)))
-               (if errorp
-                   (error "Can't get early method.")
-                   nil))
-           (real-get-method generic-function qualifiers specializers errorp)))
-
-(defun early-update-discriminator-code (generic-function)
-       (let* ((methods (early-gf-methods generic-function))
-              (early-dfun (cond ((null methods)
-                                 #'(lambda (&rest ignore)
-                                          (declare (ignore ignore))
-                                          (error 
-              "Called an early generic-function that ~
-                              has no methods?")))
-                                ((null (cdr methods))
-                                 
-                                 ;; If there is only one method, just use that method's function. 
-                                 ;; This corresponds to the important fact that early
-                                 ;; generic-functions with only one method always call that method
-                                 ;; when they are called.  If there is more than one method, we have
-                                 ;; to install a simple little discriminator-code for this generic
-                                 ;; function. 
-                                 (cadr (car methods)))
-                                (t #'(lambda (&rest args)
-                                            (early-dfun methods args))))))
-             (set-funcallable-instance-function generic-function early-dfun)
-             (setf (early-gf-discriminator-code generic-function)
-                   early-dfun)))
-
-(defun early-get-cpl (object)
-       (bootstrap-get-slot 'std-class                        ; HMMM? should be CLOS-CLASS
-              (class-of object)
-              'class-precedence-list))
-
-(defun early-sort-methods (list args)
-       (if (null (cdr list))
-           list
-           (sort list #'(lambda (specls-1 specls-2)
-                               (iterate ((s1 (list-elements specls-1))
-                                         (s2 (list-elements specls-2))
-                                         (a (list-elements args)))
-                                      (cond ((eq s1 s2))
-                                            ((eq s2 *the-class-t*)
-                                             (return t))
-                                            ((eq s1 *the-class-t*)
-                                             (return nil))
-                                            (t (return (memq s2 (memq s1 (early-get-cpl a))))))))
-                 :key
-                 #'(lambda (em)
-                          (early-method-specializers em t)))))
-
-(defun early-dfun (methods args)
-       (let ((primary nil)
-             (before nil)
-             (after nil)
-             (around nil))
-            (dolist (method methods)
-                (let* ((specializers (early-method-specializers method t))
-                       (qualifiers (early-method-qualifiers method))
-                       (args args)
-                       (specs specializers))
-                      (when (loop (when (or (null args)
-                                            (null specs))
-                                      
-
-                                 ;; If we are out of specs, then we must be in the optional, rest or
-                                 ;; keywords arguments.  This method is applicable to these
-                                 ;; arguments.  Return T. 
-                                      (return t))
-                                  (let ((arg (pop args))
-                                        (spec (pop specs)))
-                                       (unless (or (eq spec *the-class-t*)
-                                                   (memq spec (early-get-cpl arg)))
-                                              (return nil))))
-                          (cond ((null qualifiers)
-                                 (push method primary))
-                                ((equal qualifiers '(:before))
-                                 (push method before))
-                                ((equal qualifiers '(:after))
-                                 (push method after))
-                                ((equal qualifiers '(:around))
-                                 (push method around))
-                                (t (error "Unrecognized qualifer in early method."))))))
-            (setq primary (early-sort-methods primary args)
-                  before
-                  (early-sort-methods before args)
-                  after
-                  (early-sort-methods after args)
-                  around
-                  (early-sort-methods around args))
-            (flet ((do-main-combined-method (arguments)
-                          (dolist (m before)
-                              (apply (cadr m)
-                                     arguments))
-                          (multiple-value-prog1 (let ((*next-methods* (mapcar #'car (cdr primary))))
-                                                     (apply (cadar primary)
-                                                            arguments))
-                                 (dolist (m after)
-                                     (apply (cadr m)
-                                            arguments)))))
-                  (if (null around)
-                      (do-main-combined-method args)
-                      (let ((*next-methods* (append (mapcar #'cadr (cdr around))
-                                                   #'do-main-combined-method)))
-                           (apply (caar around)
-                                  args))))))
-
-(defun
- fix-early-generic-functions
- (&optional noisyp)
- (allocate-instance (find-class 'standard-generic-function))
-                                                             ; Be sure this class has an instance. 
- (let* ((class (find-class 'standard-generic-function))
-        (wrapper (class-wrapper class))
-        (n-static-slots (class-no-of-instance-slots class))
-        (default-initargs (default-initargs class nil))
-        (*invalidate-discriminating-function-force-p* t))
-       (flet ((fix-structure (gf)
-                     (let ((static-slots (%allocate-static-slot-storage--class n-static-slots)))
-                          (setf (fsc-instance-wrapper gf)
-                                wrapper
-                                (fsc-instance-slots gf)
-                                static-slots))))
-             (dolist (early-gf-spec *early-generic-functions*)
-                 (when noisyp (format t "~&~S..." early-gf-spec))
-                 (let* ((early-gf (gdefinition early-gf-spec))
-                        (early-static-slots (fsc-instance-slots early-gf))
-                        (early-discriminator-code nil)
-                        (early-methods nil)
-                        (methods nil)
-                        (aborted t))
-                       (flet ((trampoline (&rest args)
-                                     (apply early-discriminator-code args)))
-                             (if (not (listp early-static-slots))
-                                 (when noisyp (format t "already fixed?"))
-                                 (unwind-protect
-                                     (progn (setq early-discriminator-code (
-                                                                          early-gf-discriminator-code
-                                                                            early-gf))
-                                            (setq early-methods (early-gf-methods early-gf))
-                                            (setf (gdefinition early-gf-spec)
-                                                  #'trampoline)
-                                            (when noisyp (format t "trampoline..."))
-                                            (fix-structure early-gf)
-                                            (when noisyp (format t "fixed..."))
-                                            (apply #'initialize-instance early-gf :name early-gf-spec
-                                                   default-initargs)
-                                            (dolist (early-method early-methods)
-                                                (destructuring-bind (class quals lambda-list specs fn
-                                                                           doc slot-name)
-                                                       (cadddr early-method)
-                                                       (setq specs (early-method-specializers 
-                                                                          early-method t))
-                                                       (let ((method (real-make-a-method class quals
-                                                                            lambda-list specs fn doc
-                                                                            slot-name)))
-                                                            (real-add-method early-gf method)
-                                                            (push method methods)
-                                                            (when noisyp (format t "m")))))
-                                            (setf (slot-value early-gf 'name)
-                                                  early-gf-spec)
-                                            (fixup-magic-generic-function early-gf-spec early-methods
-                                                   early-gf (reverse methods))
-                                            (setq aborted nil))
-                                     (setf (gdefinition early-gf-spec)
-                                           early-gf)
-                                     (when noisyp (format t "."))
-                                     (when aborted
-                                         (setf (fsc-instance-slots early-gf)
-                                               early-static-slots)))))))
-             (dolist (fns *early-functions*)
-                 (setf (symbol-function (car fns))
-                       (symbol-function (caddr fns))))
-             (dolist (fixup *generic-function-fixups*)
-                 (let ((fspec (car fixup))
-                       (methods (cdr fixup))
-                       (gf (make-instance 'standard-generic-function)))
-                      (set-function-name gf fspec)
-                      (setf (generic-function-name gf)
-                            fspec)
-                      (dolist (method methods)
-                          (destructuring-bind (lambda-list specializers method-fn-name)
-                                 method
-                                 (let* ((fn (if method-fn-name
-                                                (symbol-function method-fn-name)
-                                                (symbol-function fspec)))
-                                        (method (make-a-method 'standard-method nil lambda-list 
-                                                       specializers fn nil)))
-                                       (real-add-method gf method))))
-                      (setf (gdefinition fspec)
-                            gf))))))
-
-
-;;; parse-defmethod is used by defmethod to parse the &rest argument into the 'real' arguments. 
-;;; This is where the syntax of defmethod is really implemented. 
-
-
-(defun parse-defmethod (cdr-of-form)
-       (declare (values name qualifiers specialized-lambda-list body))
-       (let ((name (pop cdr-of-form))
-             (qualifiers nil)
-             (spec-ll nil))
-            (loop (if (and (car cdr-of-form)
-                           (atom (car cdr-of-form)))
-                      (push (pop cdr-of-form)
-                            qualifiers)
-                      (return (setq qualifiers (nreverse qualifiers)))))
-            (setq spec-ll (pop cdr-of-form))
-            (values name qualifiers spec-ll cdr-of-form)))
-
-(defun parse-specializers (specializers)
-       (flet ((parse (spec)
-                     (cond ((symbolp spec)
-                            (or (find-class spec nil)
-                                (error 
-              "~S used as a specializer,~%~
-                         but is not the name of a class." spec)))
-                           ((and (listp spec)
-                                 (eq (car spec)
-                                     'eql)
-                                 (null (cddr spec)))
-                            (make-instance 'eql-specializer :object (cadr spec))
-                                                             ; *EQL* spec 
-                            )
-                           (t (error "~S is not a legal specializer." spec)))))
-             (mapcar #'parse specializers)))
-
-(defun unparse-specializers (specializers-or-method)
-       (if (listp specializers-or-method)
-           (flet ((unparse (spec)
-                         (cond ((classp spec)
-                                (or (class-name spec)
-                                    spec))
-                               ((eql-specializer-p spec)
-                                                             ; *EQL*
-                                (eql-specializer-object spec)
-                                                             ; (and (listp spec) (eq (car spec)
-                                                             ; 'eql)) spec 
-                                )
-                               (t (error "~S is not a legal specializer." spec)))))
-                 (mapcar #'unparse specializers-or-method))
-           (unparse-specializers (method-specializers specializers-or-method))))
-
-(defun parse-method-or-spec (spec &optional (errorp t))
-       (declare (values generic-function method method-name))
-       (let (gf method name temp)
-            (if (method-p spec)
-                (setq method spec gf (method-generic-function method)
-                      temp
-                      (and gf (generic-function-name gf))
-                      name
-                      (if temp
-                          (intern-function-name (make-method-spec temp (method-qualifiers method)
-                                                       (unparse-specializers (method-specializers
-                                                                              method))))
-                          (make-symbol (format nil "~S" method))))
-                (multiple-value-bind (gf-spec quals specls)
-                       (parse-defmethod spec)
-                       (and (setq gf (and (or errorp (gboundp gf-spec))
-                                          (gdefinition gf-spec)))
-                            (let ((nreq (compute-discriminating-function-arglist-info gf)))
-                                 (setq specls (append (parse-specializers specls)
-                                                     (make-list (- nreq (length specls))
-                                                            :initial-element *the-class-t*)))
-                                 (and (setq method (get-method gf quals specls errorp))
-                                      (setq name (intern-function-name (make-method-spec gf-spec 
-                                                                              quals specls))))))))
-            (values gf method name)))
-
-(defun specialized-lambda-list-parameters (specialized-lambda-list)
-       (multiple-value-bind (parameters ignore1 ignore2)
-              (parse-specialized-lambda-list specialized-lambda-list)
-              (declare (ignore ignore1 ignore2))
-              parameters))
-
-(defun specialized-lambda-list-lambda-list (specialized-lambda-list)
-       (multiple-value-bind (ignore1 lambda-list ignore2)
-              (parse-specialized-lambda-list specialized-lambda-list)
-              (declare (ignore ignore1 ignore2))
-              lambda-list))
-
-(defun specialized-lambda-list-specializers (specialized-lambda-list)
-       (multiple-value-bind (ignore1 ignore2 specializers)
-              (parse-specialized-lambda-list specialized-lambda-list)
-              (declare (ignore ignore1 ignore2))
-              specializers))
-
-(defun specialized-lambda-list-required-parameters (specialized-lambda-list)
-       (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
-              (parse-specialized-lambda-list specialized-lambda-list)
-              (declare (ignore ignore1 ignore2 ignore3))
-              required-parameters))
-
-(defun parse-specialized-lambda-list (arglist &optional post-keyword)
-       (declare (values parameters lambda-list specializers required-parameters))
-       (let ((arg (car arglist)))
-            (cond ((null arglist)
-                   (values nil nil nil nil))
-                  ((eq arg '&aux)
-                   (values nil arglist nil))
-                  ((memq arg lambda-list-keywords)
-                   (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
-                       
-                       ;; Warn about non-standard lambda-list-keywords, but then go on to treat them
-                       ;; like a standard lambda-list-keyword what with the warning its probably ok.
-                       (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
-                    Assuming that the symbols following it are parameters,~%~
-                    and not allowing any parameter specializers to follow~%~
-                    to follow it." arg))
-                   
-                   ;; When we are at a lambda-list-keyword, the parameters don't include the
-                   ;; lambda-list-keyword; the lambda-list does include the lambda-list-keyword; and
-                   ;; no specializers are allowed to follow the lambda-list-keywords (at least for
-                   ;; now). 
-                   (multiple-value-bind (parameters lambda-list)
-                          (parse-specialized-lambda-list (cdr arglist)
-                                 t)
-                          (values parameters (cons arg lambda-list)
-                                 nil nil)))
-                  (post-keyword 
-
-                         ;; After a lambda-list-keyword there can be no specializers.
-                         (multiple-value-bind (parameters lambda-list)
-                                (parse-specialized-lambda-list (cdr arglist)
-                                       t)
-                                (values (cons (if (listp arg)
-                                                  (car arg)
-                                                  arg)
-                                              parameters)
-                                       (cons arg lambda-list)
-                                       nil nil)))
-                  (t (multiple-value-bind (parameters lambda-list specializers required)
-                            (parse-specialized-lambda-list (cdr arglist))
-                            (values (cons (if (listp arg)
-                                              (car arg)
-                                              arg)
-                                          parameters)
-                                   (cons (if (listp arg)
-                                             (car arg)
-                                             arg)
-                                         lambda-list)
-                                   (cons (if (listp arg)
-                                             (cadr arg)
-                                             't)
-                                         specializers)
-                                   (cons (if (listp arg)
-                                             (car arg)
-                                             arg)
-                                         required)))))))
-
-(eval-when (load eval)
-       (setq *boot-state* 'early))
-
-(defmacro with-slots (slots instance &body body &environment env)
-       (let ((gensym (gensym))
-             (specs (mapcar #'(lambda (ss)
-                                     (if (consp ss)
-                                         (list (car ss)
-                                               (variable-lexical-p (car ss)
-                                                      env)
-                                               (cadr ss))
-                                         (list ss (variable-lexical-p ss env)
-                                               ss)))
-                           slots)))
-            (expand-with-slots specs body env gensym instance
-                   #'(lambda (s)
-                            `(slot-value ,gensym ',s)))))
-
-(defmacro with-accessors (slot-accessor-pairs instance &body body &environment env)
-       (let ((gensym (gensym))
-             (specs (mapcar #'(lambda (ss)
-                                     (list (car ss)
-                                           (variable-lexical-p (car ss)
-                                                  env)
-                                           (cadr ss)))
-                           slot-accessor-pairs)))
-            (expand-with-slots specs body env gensym instance #'(lambda (a)
-                                                                       `(,a ,gensym)))))
-
-(defun expand-with-slots (specs body env gensym instance translate-fn)
-       `(let ((,gensym ,instance))
-             ,@(and (symbolp instance)
-                    `((declare (variable-rebinding ,gensym ,instance))))
-             ,gensym
-             ,@(cdr (walk-form `(progn ,@body)
-                           env
-                           #'(lambda (f c e)
-                                    (expand-with-slots-internal specs f c translate-fn e))))))
-
-(defun expand-with-slots-internal (specs form context translate-fn env)
-       (let ((entry nil))
-            (cond ((not (eq context :eval))
-                   form)
-                  ((symbolp form)
-                   (if (and (setq entry (assoc form specs))
-                            (eq (cadr entry)
-                                (variable-lexical-p form env)))
-                       (funcall translate-fn (caddr entry))
-                       form))
-                  ((not (listp form))
-                   form)
-                  ((member (car form)
-                          '(setq setf))
-                   
-                   ;; Have to be careful.  We must only convert the form to a SETF form when we
-                   ;; convert one of the 'logical' variables to a form Otherwise we will get looping
-                   ;; in implementations where setf is a macro which expands into setq. 
-                   (let ((kind (car form)))
-                        (labels ((scan-setf (tail)
-                                        (if (null tail)
-                                            nil
-                                            (walker::relist* tail
-                                                   (if (and (setq entry (assoc (car tail)
-                                                                               specs))
-                                                            (eq (cadr entry)
-                                                                (variable-lexical-p (car tail)
-                                                                       env)))
-                                                       (progn (setq kind 'setf)
-                                                              (funcall translate-fn (caddr entry)))
-                                                       (car tail))
-                                                   (cadr tail)
-                                                   (scan-setf (cddr tail))))))
-                               (let (new-tail)
-                                    (setq new-tail (scan-setf (cdr form)))
-                                    (walker::recons form kind new-tail)))))
-                  ((eq (car form)
-                       'multiple-value-setq)
-                   (let* ((vars (cadr form))
-                          (gensyms (mapcar #'(lambda (i)
-                                                    (declare (ignore i))
-                                                    (gensym))
-                                          vars)))
-                         `(multiple-value-bind ,gensyms ,(caddr form)
-                                 . ,(reverse (mapcar #'(lambda (v g)
-                                                              `(setf ,v ,g))
-                                                    vars gensyms)))))
-                  (t form))))
diff --git a/obsolete/clos/2.0/braid.lisp b/obsolete/clos/2.0/braid.lisp
deleted file mode 100644
index 80424b6a..00000000
--- a/obsolete/clos/2.0/braid.lisp
+++ /dev/null
@@ -1,503 +0,0 @@
-;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-;;; Bootstrapping the meta-braid.
-;;;
-;;; The code in this file takes the early definitions that have been saved
-;;; up and actually builds those class objects.  This work is largely driven
-;;; off of those class definitions, but the fact that STANDARD-CLASS is the
-;;; class of all metaclasses in the braid is built into this code pretty
-;;; deeply.
-;;;
-;;; 
-
-(in-package 'clos)
-
-(defun early-class-definition (class-name)
-  (or (find class-name *early-class-definitions* :key #'ecd-class-name)
-      (error "~S is not a class in *early-class-definitions*." class-name)))
-
-(defun canonical-slot-name (canonical-slot)
-  (getf canonical-slot :name))
-
-(defun early-collect-inheritance (class-name)
-  (declare (values slots cpl default-initargs direct-subclasses))
-  (let ((cpl (early-collect-cpl class-name)))
-    (values (early-collect-slots cpl)
-	    cpl
-	    (early-collect-default-initargs cpl)
-	    (gathering1 (collecting)
-	      (dolist (definition *early-class-definitions*)
-		(when (memq class-name (ecd-superclass-names definition))
-		  (gather1 (ecd-class-name definition))))))))
-
-(defun early-collect-cpl (class-name)
-  (labels ((walk (c)
-	     (let* ((definition (early-class-definition c))
-		    (supers (ecd-superclass-names definition)))
-	       (cons c
-		     (apply #'append (mapcar #'early-collect-cpl supers))))))
-    (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
-
-(defun early-collect-slots (cpl)
-  (let* ((definitions (mapcar #'early-class-definition cpl))
-	 (super-slots (mapcar #'ecd-canonical-slots definitions))
-	 (slots (apply #'append (reverse super-slots))))
-    (dolist (s1 slots)
-      (let ((name1 (canonical-slot-name s1)))
-	(dolist (s2 (cdr (memq s1 slots)))
-	  (when (eq name1 (canonical-slot-name s2))
-	    (error "More than one early class defines a slot with the~%~
-                    name ~S.  This can't work because the bootstrap~%~
-                    object system doesn't know how to compute effective~%~
-                    slots."
-		   name1)))))
-    slots))
-
-(defun early-collect-default-initargs (cpl)
-  (let ((default-initargs ()))
-    (dolist (class-name cpl)
-      (let ((definition (early-class-definition class-name)))
-	(dolist (option (ecd-other-initargs definition))
-	  (unless (eq (car option) :default-initargs)
-	    (error "The defclass option ~S is not supported by the bootstrap~%~
-                    object system."
-		   (car option)))
-	  (setq default-initargs
-		(nconc default-initargs (reverse (cdr option)))))))
-    (reverse default-initargs)))
-
-
-;;;
-;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
-;;; the values of slots during bootstrapping.  During bootstrapping, there
-;;; are only two kinds of objects whose slots we need to access, CLASSes
-;;; and SLOTDs.  The first argument to these functions tells whether the
-;;; object is a CLASS or a SLOTD.
-;;;
-;;; Note that the way this works it stores the slot in the same place in
-;;; memory that the full object system will expect to find it later.  This
-;;; is critical to the bootstrapping process, the whole changeover to the
-;;; full object system is predicated on this.
-;;;
-;;; One important point is that the layout of standard classes and standard
-;;; slots must be computed the same way in this file as it is by the full
-;;; object system later.
-;;; 
-(defun bootstrap-get-slot (type object slot-name)
-  (let ((index (bootstrap-slot-index type slot-name)))
-    (svref (std-instance-slots object) index)))
-
-(defun bootstrap-set-slot (type object slot-name new-value)
-  (let ((index (bootstrap-slot-index type slot-name)))
-    (setf (svref (std-instance-slots object) index) new-value)))
-
-(defvar *std-class-slots*
-	(mapcar #'canonical-slot-name
-		(early-collect-inheritance 'standard-class)))
-
-(defvar *bin-class-slots*
-	(mapcar #'canonical-slot-name
-		(early-collect-inheritance 'built-in-class)))
-
-(defvar *std-slotd-slots*
-	(mapcar #'canonical-slot-name
-		(early-collect-inheritance 'standard-slot-definition)))
-
-(defun bootstrap-slot-index (type slot-name)
-  (or (position slot-name (ecase type
-			    (std-class *std-class-slots*)
-			    (bin-class *bin-class-slots*)
-			    (std-slotd *std-slotd-slots*)))
-      (error "~S not found" slot-name)))
-
-
-;;;
-;;; bootstrap-meta-braid
-;;;
-;;; This function builds the base metabraid from the early class definitions.
-;;;   
-(defun bootstrap-meta-braid ()
-  (let* ((std-class-size (length *std-class-slots*))
-         (std-class (%allocate-instance--class std-class-size))
-         (std-class-wrapper (make-wrapper std-class))
-	 (built-in-class (%allocate-instance--class std-class-size))
-	 (built-in-class-wrapper (make-wrapper built-in-class))
-	 (direct-slotd    (%allocate-instance--class std-class-size))
-	 (effective-slotd (%allocate-instance--class std-class-size))
-	 (direct-slotd-wrapper    (make-wrapper direct-slotd))
-	 (effective-slotd-wrapper (make-wrapper effective-slotd)))
-    ;;
-    ;; First, make a class metaobject for each of the early classes.  For
-    ;; each metaobject we also set its wrapper.  Except for the class T,
-    ;; the wrapper is always that of STANDARD-CLASS.
-    ;; 
-    (dolist (definition *early-class-definitions*)
-      (let* ((name (ecd-class-name definition))
-	     (meta (ecd-metaclass definition))
-             (class (case name
-                      (standard-class                     std-class)
-                      (standard-direct-slot-definition    direct-slotd)
-		      (standard-effective-slot-definition effective-slotd)
-		      (built-in-class                     built-in-class)
-                      (otherwise
-			(%allocate-instance--class std-class-size)))))
-	(unless (eq name t)
-	  (inform-type-system-about-class class name))
-	(setf (std-instance-wrapper class)
-	      (ecase meta
-		(standard-class std-class-wrapper)
-		(built-in-class built-in-class-wrapper)))
-        (setf (find-class name) class)))
-    ;;
-    ;;
-    ;;
-    (dolist (definition *early-class-definitions*)
-      (let ((name (ecd-class-name definition))
-	    (source (ecd-source definition))
-	    (direct-supers (ecd-superclass-names definition))
-	    (direct-slots  (ecd-canonical-slots definition))
-	    (other-initargs (ecd-other-initargs definition)))
-	(let ((direct-default-initargs
-		(getf other-initargs :default-initargs)))
-	  (multiple-value-bind (slots cpl default-initargs direct-subclasses)
-	      (early-collect-inheritance name)
-	    (let* ((class (find-class name))
-		   (wrapper
-		     (cond
-		       ((eq class std-class)       std-class-wrapper)
-		       ((eq class direct-slotd)    direct-slotd-wrapper)
-		       ((eq class effective-slotd) effective-slotd-wrapper)
-		       ((eq class built-in-class)  built-in-class-wrapper)
-		       (t (make-wrapper class))))
-		   (proto nil))
-	      (cond ((eq name 't)
-		     (setq *the-wrapper-of-t* wrapper
-			   *the-class-t* class))
-		    ((memq name '(standard-object 
-				  standard-class
-				  standard-effective-slot-definition))
-		     (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
-				  *the-clos-package*)
-			  class)))
-	      (dolist (slot slots)
-		(unless (eq (getf slot :allocation :instance) :instance)
-		  (error "Slot allocation ~S not supported in bootstrap.")))
-	      
-	      (setf (wrapper-instance-slots-layout wrapper)
-		    (mapcar #'canonical-slot-name slots))
-	      (setf (wrapper-class-slots wrapper)
-		    ())
-	      
-	      (setq proto (%allocate-instance--class (length slots)))
-	      (setf (std-instance-wrapper proto) wrapper)
-	    
-	      (setq direct-slots
-		    (bootstrap-make-slot-definitions name direct-slots
-						     direct-slotd-wrapper nil))
-	      (setq slots
-		    (bootstrap-make-slot-definitions name slots
-						     effective-slotd-wrapper t))
-	      
-	      (bootstrap-initialize-std-class
-		class name source
-		direct-supers direct-subclasses cpl wrapper
-		direct-slots slots direct-default-initargs default-initargs
-		proto)
-	      
-	      (dolist (slotd direct-slots)
-		(bootstrap-accessor-definitions
-		  name
-		  (bootstrap-get-slot 'std-slotd slotd 'name)
-		  (bootstrap-get-slot 'std-slotd slotd 'readers)
-		  (bootstrap-get-slot 'std-slotd slotd 'writers))))))))))
-
-(defun bootstrap-accessor-definitions (class-name slot-name readers writers)
-  (flet ((do-reader-definition (reader)
-	   (add-method
-	     (ensure-generic-function reader)
-	     (make-a-method
-	       'standard-reader-method
-	       ()
-	       (list class-name)
-	       (list class-name)
-	       (make-std-reader-method-function slot-name)
-	       "automatically generated reader method"
-	       slot-name)))
-	 (do-writer-definition (writer)
-	   (add-method
-	     (ensure-generic-function writer)
-	     (make-a-method
-	       'standard-writer-method
-	       ()
-	       (list 'new-value class-name)
-	       (list 't class-name)
-	       (make-std-writer-method-function slot-name)
-	       "automatically generated writer method"
-	       slot-name))))
-    (dolist (reader readers) (do-reader-definition reader))
-    (dolist (writer writers) (do-writer-definition writer))))
-
-;;;
-;;; Initialize a standard class metaobject.
-;;;
-(defun bootstrap-initialize-std-class
-       (class
-	name definition-source direct-supers direct-subclasses cpl wrapper
-	direct-slots slots direct-default-initargs default-initargs proto)
-  (flet ((classes (names) (mapcar #'find-class names))
-	 (set-slot (slot-name value)
-	   (bootstrap-set-slot 'std-class class slot-name value)))
-    
-    (set-slot 'name name)
-    (set-slot 'source definition-source)
-    (set-slot 'class-precedence-list (classes cpl))
-    (set-slot 'direct-superclasses (classes direct-supers))
-    (set-slot 'direct-slots direct-slots)
-    (set-slot 'direct-subclasses (classes direct-subclasses))
-    (set-slot 'direct-methods (cons nil nil))
-    (set-slot 'no-of-instance-slots (length slots))
-    (set-slot 'slots slots)
-    (set-slot 'wrapper wrapper)
-    (set-slot 'prototype proto)
-    (set-slot 'plist
-	      `(,@(and direct-default-initargs
-		       `(direct-default-initargs ,direct-default-initargs))
-		,@(and default-initargs
-		       `(default-initargs ,default-initargs))))
-    ))
-
-;;;
-;;; Initialize a built-in-class metaobject.
-;;;
-(defun bootstrap-initialize-bin-class
-       (class
-	name definition-source direct-supers direct-subclasses cpl wrapper)
-  (flet ((classes (names) (mapcar #'find-class names))
-	 (set-slot (slot-name value)
-	   (bootstrap-set-slot 'bin-class class slot-name value)))
-    
-    (set-slot 'name name)
-    (set-slot 'source definition-source)
-    (set-slot 'direct-superclasses (classes direct-supers))
-    (set-slot 'direct-subclasses (classes direct-subclasses))
-    (set-slot 'direct-methods (cons nil nil))
-    (set-slot 'class-precedence-list (classes cpl))
-    (set-slot 'wrapper wrapper)))
-
-(defun bootstrap-make-slot-definitions (name slots wrapper e-p)
-  (mapcar #'(lambda (slot) (bootstrap-make-slot-definition name slot wrapper e-p))
-          slots))
-
-(defun bootstrap-make-slot-definition (name slot wrapper e-p)  
-  (let ((slotd (%allocate-instance--class (length *std-slotd-slots*))))
-    (setf (std-instance-wrapper slotd) wrapper)
-    (flet ((get-val (name) (getf slot name))
-	   (set-val (name val) (bootstrap-set-slot 'std-slotd slotd name val)))
-      (set-val 'name         (get-val :name))
-      (set-val 'initform     (get-val :initform))
-      (set-val 'initfunction (get-val :initfunction))      
-      (set-val 'initargs     (get-val :initargs))
-      (set-val 'readers      (get-val :readers))
-      (set-val 'writers      (get-val :writers))
-      (set-val 'allocation   :instance)
-      (set-val 'type         (get-val :type))
-      (set-val 'class        nil)
-      (set-val 'instance-index nil)
-      (when (and (eq name 'standard-class) (eq (get-val :name) 'slots) e-p)
-	(setq *the-eslotd-standard-class-slots* slotd))
-      slotd)))
-
-(defun bootstrap-built-in-classes ()
-  ;;
-  ;; First make sure that all the supers listed in *built-in-class-lattice*
-  ;; are themselves defined by *built-in-class-lattice*.  This is just to
-  ;; check for typos and other sorts of brainos.
-  ;; 
-  (dolist (e *built-in-classes*)
-    (dolist (super (cadr e))
-      (unless (or (eq super 't)
-		  (assq super *built-in-classes*))
-	(error "In *built-in-classes*: ~S has ~S as a super,~%~
-                but ~S is not itself a class in *built-in-classes*."
-	       (car e) super super))))
-
-  ;;
-  ;; In the first pass, we create a skeletal object to be bound to the
-  ;; class name.
-  ;;
-  (let* ((built-in-class (find-class 'built-in-class))
-	 (built-in-class-wrapper (class-wrapper built-in-class))
-	 (bin-class-size (length *bin-class-slots*)))
-    (dolist (e *built-in-classes*)
-      (let ((class (%allocate-instance--class bin-class-size)))
-	(setf (std-instance-wrapper class) built-in-class-wrapper)
-	(setf (find-class (car e)) class))))
-
-  ;;
-  ;; In the second pass, we initialize the class objects.
-  ;;
-  (dolist (e *built-in-classes*)
-    (destructuring-bind (name supers subs cpl) e
-      (let* ((class (find-class name))
-	     (wrapper (make-wrapper class)))
-	(set (get-built-in-class-symbol name) class)
-	(set (get-built-in-wrapper-symbol name) wrapper)
-
-	(setf (wrapper-instance-slots-layout wrapper) ()
-	      (wrapper-class-slots wrapper) ())
-
-	(bootstrap-initialize-bin-class class
-					name nil
-					supers subs
-					(cons name cpl) wrapper)
-	))))
-
-
-;;;
-;;;
-;;;
-
-(defun class-of (x) (wrapper-class (wrapper-of x)))
-
-(defun wrapper-of (x) 
-  (or (and (std-instance-p x)
-	   (std-instance-wrapper x))
-      (and (fsc-instance-p x)
-	   (fsc-instance-wrapper x))
-      (built-in-wrapper-of x)
-      (error "Can't determine wrapper of ~S" x)))
-
-
-(eval-when (compile eval)
-
-(defun make-built-in-class-subs ()
-  (mapcar #'(lambda (e)
-	      (let ((class (car e))
-		    (class-subs ()))
-		(dolist (s *built-in-classes*)
-		  (when (memq class (cadr s)) (pushnew (car s) class-subs)))
-		(cons class class-subs)))
-	  (cons '(t) *built-in-classes*)))
-
-(defun make-built-in-class-tree ()
-  (let ((subs (make-built-in-class-subs)))
-    (labels ((descend (class)
-	       (cons class (mapcar #'descend (cdr (assq class subs))))))
-      (descend 't))))
-
-(defun make-built-in-wrapper-of-body ()
-  (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
-				   'x
-				   #'get-built-in-wrapper-symbol))
-
-(defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
-  (let ((*specials* ()))
-    (declare (special *specials*))
-    (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
-      `(locally (declare (special .,*specials*)) ,inner))))
-
-(defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
-  (declare (special *specials*))
-  (let ((symbol (funcall get-symbol (car tree))))
-    (push symbol *specials*)
-    (let ((sub-tests
-	    (mapcar #'(lambda (x)
-			(make-built-in-wrapper-of-body-2 x var get-symbol))
-		    (cdr tree))))
-      `(and (typep ,var ',(car tree))
-	    ,(if sub-tests
-		 `(or ,.sub-tests ,symbol)
-		 symbol)))))
-)
-
-(defun built-in-wrapper-of (x)
-  #.(make-built-in-wrapper-of-body))
-
-
-
-
-(eval-when (load eval)
-  (clrhash *find-class*)
-  (bootstrap-meta-braid)
-  (bootstrap-built-in-classes)
-  (setq *boot-state* 'braid)
-  (setf (symbol-function 'load-defclass) #'real-load-defclass)
-  )
-
-
-;;;
-;;; All of these method definitions must appear here because the bootstrap
-;;; only allows one method per generic function until the braid is fully
-;;; built.
-;;;
-(defmethod print-object (instance stream)
-  (printing-random-thing (instance stream)
-    (let ((name (class-name (class-of instance))))
-      (if name
-	  (format stream "~S" name)
-	  (format stream "Instance")))))
-
-(defmethod print-object ((class class) stream)
-  (named-object-print-function class stream))
-
-(defmethod print-object ((slotd standard-slot-definition) stream)
-  (named-object-print-function slotd stream))
-
-(defun named-object-print-function (instance stream
-				    &optional (extra nil extra-p))
-  (printing-random-thing (instance stream)
-    (if extra-p					
-	(format stream "~A ~S ~:S"
-		(capitalize-words (class-name (class-of instance)))
-		(slot-value-or-default instance 'name)
-		extra)
-	(format stream "~A ~S"
-		(capitalize-words (class-name (class-of instance)))
-		(slot-value-or-default instance 'name)))))
-
-
-;;;
-;;;
-;;;
-;(defmethod shared-initialize :after ((class class) slot-names &key name)
-;  (declare (ignore slot-names))
-;  (setf (slot-value class 'name) name))
-;
-;
-;(defmethod shared-initialize :after ((class std-class)
-;				     slot-names
-;				     &key direct-superclasses
-;					  direct-slots)
-; (declare (ignore slot-names))
-; (setf (slot-value class 'direct-superclasses) direct-superclasses
-;	(slot-value class 'direct-slots) direct-slots))
-
-;;;
-;;;
-;;;
-(defmethod shared-initialize :after ((slotd standard-slot-definition)
-				     slot-names
-				     &key class
-					  name
-					  initform
-					  initfunction
-					  initargs 
-					  (allocation :instance)
-					  (type t)
-					  readers
-					  writers)
-  (declare (ignore slot-names))
-  (setf (slot-value slotd 'name) name
-	(slot-value slotd 'initform) initform
-	(slot-value slotd 'initfunction) initfunction
-	(slot-value slotd 'initargs) initargs 
-	(slot-value slotd 'allocation) (if (eq allocation :class) class allocation)
-	(slot-value slotd 'type) type
-	(slot-value slotd 'readers) readers
-	(slot-value slotd 'writers) writers))
-
diff --git a/obsolete/clos/2.0/cache.lisp b/obsolete/clos/2.0/cache.lisp
deleted file mode 100644
index 068ab817..00000000
--- a/obsolete/clos/2.0/cache.lisp
+++ /dev/null
@@ -1,1089 +0,0 @@
-;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-;;; The basics of the CLOS wrapper cache mechanism.
-;;;
-
-(in-package 'clos)
-;;;
-;;; The caching algorithm implemented:
-;;;
-;;; << put a paper here >>
-;;;
-;;; For now, understand that as far as most of this code goes, a cache has
-;;; two important properties.  The first is the number of wrappers used as
-;;; keys in each cache line.  Throughout this code, this value is always
-;;; called NKEYS.  The second is whether or not the cache lines of a cache
-;;; store a value.  Throughout this code, this always called VALUEP.
-;;;
-;;; Depending on these values, there are three kinds of caches.
-;;;
-;;; NKEYS = 1, VALUEP = NIL
-;;;
-;;; In this kind of cache, each line is 1 word long.  No cache locking is
-;;; needed since all read's in the cache are a single value.  Nevertheless
-;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will
-;;; not get a first probe hit.
-;;;
-;;; To keep the code simpler, a cache lock count does appear in location 0
-;;; of these caches, that count is incremented whenever data is written to
-;;; the cache.  But, the actual lookup code (see make-dlap) doesn't need to
-;;; do locking when reading the cache.
-;;; 
-;;;
-;;; NKEYS = 1, VALUEP = T
-;;;
-;;; In this kind of cache, each line is 2 words long.  Cache locking must
-;;; be done to ensure the synchronization of cache reads.  Line 0 of the
-;;; cache (location 0) is reserved for the cache lock count.  Location 1
-;;; of the cache is unused (in effect wasted).
-;;; 
-;;; NKEYS > 1
-;;;
-;;; In this kind of cache, the 0 word of the cache holds the lock count.
-;;; The 1 word of the cache is line 0.  Line 0 of these caches is not
-;;; reserved.
-;;;
-;;; This is done because in this sort of cache, the overhead of doing the
-;;; cache probe is high enough that the 1+ required to offset the location
-;;; is not a significant cost.  In addition, because of the larger line
-;;; sizes, the space that would be wasted by reserving line 0 to hold the
-;;; lock count is more significant.
-;;;
-
-
-;;;
-;;; Caches
-;;;
-;;; A cache is essentially just a vector.  The use of the individual `words'
-;;; in the vector depends on particular properties of the cache as described
-;;; above.
-;;;
-;;; This defines an abstraction for caches in terms of their most obvious
-;;; implementation as simple vectors.  But, please notice that part of the
-;;; implementation of this abstraction, is the function lap-out-cache-ref.
-;;; This means that most port-specific modifications to the implementation
-;;; of caches will require corresponding port-specific modifications to the
-;;; lap code assembler.
-;;;
-(defmacro cache-ref (cache location)
-  `(svref (the simple-vector ,cache) (the fixnum ,location)))
-
-(defun emit-cache-ref (cache-operand location-operand)
-  (operand :iref cache-operand location-operand))
-
-
-(defun cache-size (cache)
-  (array-dimension (the simple-vector cache) 0))
-
-(defun allocate-cache (size)
-  (make-array size :adjustable nil))
-
-(defmacro cache-lock-count (cache)
-  `(cache-ref ,cache 0))
-
-(defun flush-cache-internal (cache)
-  (without-interrupts  
-    (fill (the simple-vector cache) nil)
-    (setf (cache-lock-count cache) 0))
-  cache)
-
-(defmacro modify-cache (cache &body body)
-  `(without-interrupts
-     (multiple-value-prog1
-       (progn ,@body)
-       (let ((old-count (cache-lock-count ,cache)))
-	 (setf (cache-lock-count ,cache)
-	       (if (= old-count most-positive-fixnum) 1 (1+ old-count)))))))
-
-
-
-;;;
-;;; Some facilities for allocation and freeing caches as they are needed.
-;;; This is done on the assumption that a better port of CLOS will arrange
-;;; to cons these all the same static area.  Given that, the fact that
-;;; CLOS tries to reuse them should be a win.
-;;; 
-(defvar *free-caches* (make-hash-table :size 16))
-
-;;;
-;;; Return a cache that has had flush-cache-internal called on it.  This
-;;; returns a cache of exactly the size requested, it won't ever return a
-;;; larger cache.
-;;; 
-(defun get-cache (size)
-  (let ((entry (gethash size *free-caches*)))
-    (without-interrupts
-      (cond ((null entry)
-	     (setf (gethash size *free-caches*) (cons 0 nil))
-	     (get-cache size))
-	    ((null (cdr entry))
-	     (incf (car entry))
-	     (flush-cache-internal (allocate-cache size)))
-	    (t
-	     (let ((cache (cdr entry)))
-	       (setf (cdr entry) (cache-ref cache 0))
-	       (flush-cache-internal cache)))))))
-
-(defun free-cache (cache)
-  (let ((entry (gethash (cache-size cache) *free-caches*)))
-    (without-interrupts
-      (if (null entry)
-	  (error "Attempt to free a cache not allocated by GET-CACHE.")
-	  (let ((thread (cdr entry)))
-	    (loop (unless thread (return))
-		  (when (eq thread cache) (error "Freeing a cache twice."))
-		  (setq thread (cache-ref thread 0)))	  
-	    (flush-cache-internal cache)		;Help the GC
-	    (setf (cache-ref cache 0) (cdr entry))
-	    (setf (cdr entry) cache)
-	    nil)))))
-
-;;;
-;;; This is just for debugging and analysis.  It shows the state of the free
-;;; cache resource.
-;;; 
-(defun show-free-caches ()
-  (let ((elements ()))
-    (maphash #'(lambda (s e) (push (list s e) elements)) *free-caches*)
-    (setq elements (sort elements #'< :key #'car))
-    (dolist (e elements)
-      (let* ((size (car e))
-	     (entry (cadr e))
-	     (allocated (car entry))
-	     (head (cdr entry))
-	     (free 0))
-	(loop (when (null head) (return t))
-	      (setq head (cache-ref head 0))
-	      (incf free))
-	(format t
-		"~&There  ~4D are caches of size ~4D. (~D free  ~3D%)"
-		allocated
-		size
-		free
-		(floor (* 100 (/ free (float allocated)))))))))
-
-
-;;;
-;;; Wrapper cache numbers
-;;; 
-
-;;;
-;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero
-;;; bits wrapper cache numbers will have.
-;;;
-;;; The value of this constant is the number of wrapper cache numbers which
-;;; can be added and still be certain the result will be a fixnum.  This is
-;;; used by all the code that computes primary cache locations from multiple
-;;; wrappers.
-;;;
-;;; The value of this constant is used to derive the next two which are the
-;;; forms of this constant which it is more convenient for the runtime code
-;;; to use.
-;;; 
-(eval-when (compile load eval)
-
-(defconstant wrapper-cache-number-adds-ok 4)
-
-(defconstant wrapper-cache-number-length
-	     (- (integer-length most-positive-fixnum)
-		wrapper-cache-number-adds-ok))
-
-(defconstant wrapper-cache-number-mask
-	     (1- (expt 2 wrapper-cache-number-length)))
-
-
-(defvar *get-wrapper-cache-number* (make-random-state))
-
-(defun get-wrapper-cache-number ()
-  (let ((n 0))
-    (loop
-      (setq n
-	    (logand wrapper-cache-number-mask
-		    (random most-positive-fixnum *get-wrapper-cache-number*)))
-      (unless (zerop n) (return n)))))
-
-
-(unless (> wrapper-cache-number-length 8)
-  (error "In this implementation of Common Lisp, fixnums are so small that~@
-          wrapper cache numbers end up being only ~D bits long.  This does~@
-          not actually keep CLOS from running, but it may degrade cache~@
-          performance.~@
-          You may want to consider changing the value of the constant~@
-          WRAPPER-CACHE-NUMBER-ADDS-OK.")))
-
-
-;;;
-;;; wrappers themselves
-;;;
-;;; This caching algorithm requires that wrappers have more than one wrapper
-;;; cache number.  You should think of these multiple numbers as being in
-;;; columns.  That is, for a given cache, the same column of wrapper cache
-;;; numbers will be used.
-;;;
-;;; If at some point the cache distribution of a cache gets bad, the cache
-;;; can be rehashed by switching to a different column.
-;;;
-;;; The columns are referred to by field number which is that number which,
-;;; when used as a second argument to wrapper-ref, will return that column
-;;; of wrapper cache number.
-;;;
-;;; This code is written to allow flexibility as to how many wrapper cache
-;;; numbers will be in each wrapper, and where they will be located.  It is
-;;; also set up to allow port specific modifications to `pack' the wrapper
-;;; cache numbers on machines where the addressing modes make that a good
-;;; idea.
-;;; 
-(eval-when (compile load eval)
-(defconstant wrapper-layout
-	     '(number
-	       number
-	       number
-	       number
-	       number
-	       number
-	       number
-	       number
-	       state
-	       instance-slots-layout
-	       class-slots
-	       class))
-)
-
-(eval-when (compile load eval)
-
-(defun wrapper-field (type)
-  (position type wrapper-layout))
-
-(defun next-wrapper-field (field-number)
-  (position (nth field-number wrapper-layout)
-	    wrapper-layout
-	    :start (1+ field-number)))
-
-);eval-when
-
-(defmacro wrapper-ref (wrapper n)
-  `(svref ,wrapper ,n))
-
-(defun emit-wrapper-ref (wrapper-operand field-operand)
-  (operand :iref wrapper-operand field-operand))
-
-	      
-(defmacro wrapper-state (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'state)))
-
-(defmacro wrapper-instance-slots-layout (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout)))
-
-(defmacro wrapper-class-slots (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots)))
-
-(defmacro wrapper-class (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'class)))
-
-
-(defmacro make-wrapper-internal ()
-  `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil)))
-     ,@(gathering1 (collecting)
-	 (iterate ((i (interval :from 0))
-		   (desc (list-elements wrapper-layout)))
-	   (ecase desc
-	     (number
-	      (gather1 `(setf (wrapper-ref wrapper ,i)
-			      (get-wrapper-cache-number))))
-	     ((state instance-slots-layout class-slots class)))))
-     (setf (wrapper-state wrapper) 't)     
-     wrapper))
-
-(defun make-wrapper (class)
-  (let ((wrapper (make-wrapper-internal)))
-    (setf (wrapper-class wrapper) class)
-    wrapper))
-
-;;;
-;;; The wrapper cache machinery provides general mechanism for trapping on
-;;; the next access to any instance of a given class.  This mechanism is
-;;; used to implement the updating of instances when the class is redefined
-;;; (make-instances-obsolete).  The same mechanism is also used to update
-;;; generic function caches when there is a change to the supers of a class.
-;;;
-;;; Basically, a given wrapper can be valid or invalid.  If it is invalid,
-;;; it means that any attempt to do a wrapper cache lookup using the wrapper
-;;; should trap.  Also, methods on slot-value-using-class check the wrapper
-;;; validity as well.  This is done by calling check-wrapper-validity.
-;;; 
-
-(defun invalid-wrapper-p (wrapper)
-  (neq (wrapper-state wrapper) 't))
-
-(defvar *previous-nwrappers* (make-hash-table))
-
-(defun invalidate-wrapper (owrapper state nwrapper)
-  (ecase state
-    ((flush obsolete)
-     (let ((new-previous ()))
-       ;;
-       ;; First off, a previous call to invalidate-wrapper may have recorded
-       ;; owrapper as an nwrapper to update to.  Since owrapper is about to
-       ;; be invalid, it no longer makes sense to update to it.
-       ;;
-       ;; We go back and change the previously invalidated wrappers so that
-       ;; they will now update directly to nwrapper.  This corresponds to a
-       ;; kind of transitivity of wrapper updates.
-       ;; 
-       (dolist (previous (gethash owrapper *previous-nwrappers*))
-	 (when (eq state 'obsolete)
-	   (setf (car previous) 'obsolete))
-	 (setf (cadr previous) nwrapper)
-	 (push previous new-previous))
-       
-       (iterate ((type (list-elements wrapper-layout))
-		 (i (interval :from 0)))
-	 (when (eq type 'number) (setf (wrapper-ref owrapper i) 0)))
-       (push (setf (wrapper-state owrapper) (list state nwrapper))
-	     new-previous)
-       
-       (setf (gethash owrapper *previous-nwrappers*) ()
-	     (gethash nwrapper *previous-nwrappers*) new-previous)))))
-
-(defun check-wrapper-validity (instance)
-  (let* ((owrapper (wrapper-of instance))
-	 (state (wrapper-state owrapper)))
-    (if (eq state  't)
-	owrapper
-	(let ((nwrapper
-		(ecase (car state)
-		  (flush
-		    (flush-cache-trap owrapper (cadr state) instance))
-		  (obsolete
-		    (obsolete-instance-trap owrapper (cadr state) instance)))))
-	  ;;
-	  ;; This little bit of error checking is superfluous.  It only
-	  ;; checks to see whether the person who implemented the trap
-	  ;; handling screwed up.  Since that person is hacking internal
-	  ;; CLOS code, and is not a user, this should be needless.  Also,
-	  ;; since this directly slows down instance update and generic
-	  ;; function cache refilling, feel free to take it out sometime
-	  ;; soon.
-	  ;; 
-	  (cond ((neq nwrapper (wrapper-of instance))
-		 (error "Wrapper returned from trap not wrapper of instance."))
-		((invalid-wrapper-p nwrapper)
-		 (error "Wrapper returned from trap invalid.")))
-	  nwrapper))))
-
-
-
-(defun compute-line-size (nelements) (expt 2 (ceiling (log nelements 2))))
-
-(defun compute-cache-parameters (nkeys valuep nlines-or-cache)
-  (declare (values cache-mask actual-size line-size nlines))
-  (flet ((compute-mask (cache-size line-size)
-	   (logxor (1- cache-size) (1- line-size))))
-    (if (= nkeys 1)
-	(let* ((line-size (if valuep 2 1))
-	       (cache-size (if (numberp nlines-or-cache)
-			       (* line-size
-				  (expt 2 (ceiling (log nlines-or-cache 2))))
-			       (cache-size nlines-or-cache))))
-	  (values (compute-mask cache-size line-size)
-		  cache-size
-		  line-size
-		  (/ cache-size line-size)))
-	(let* ((line-size (compute-line-size (+ nkeys (if valuep 1 0))))
-	       (cache-size (if (numberp nlines-or-cache)
-			       (* line-size 
-				  (expt 2 (ceiling (log nlines-or-cache 2))))
-			       (1- (cache-size nlines-or-cache)))))
-	  (values (compute-mask cache-size line-size)
-		  (1+ cache-size)
-		  line-size
-		  (/ cache-size line-size))))))
-
-
-
-;;;
-;;; The various implementations of computing a primary cache location from
-;;; wrappers.  Because some implementations of this must run fast there are
-;;; several implementations of the same algorithm.
-;;;
-;;; The algorithm is:
-;;;
-;;;  SUM       over the wrapper cache numbers,
-;;;  ENSURING  that the result is a fixnum
-;;;  MASK      the result against the mask argument.
-;;;
-;;;
-
-;;;
-;;; COMPUTE-PRIMARY-CACHE-LOCATION
-;;; 
-;;; The basic functional version.  This is used by the cache miss code to
-;;; compute the primary location of an entry.  
-;;;
-(defun compute-primary-cache-location (field mask wrappers)
-  (if (not (consp wrappers))
-      (logand mask (wrapper-ref wrappers field))
-      (let ((location 0))
-	(iterate ((wrapper (list-elements wrappers))
-		  (i (interval :from 0)))
-	  ;;
-	  ;; First add the cache number of this wrapper to location.
-	  ;; 
-	  (let ((wrapper-cache-number (wrapper-ref wrapper field)))
-	    (if (zerop wrapper-cache-number)
-		(return-from compute-primary-cache-location 0)
-		(setq location (+ location wrapper-cache-number))))
-	  ;;
-	  ;; Then, if we are working with lots of wrappers, deal with
-	  ;; the wrapper-cache-number-mask stuff.
-	  ;; 
-	  (when (and (not (zerop i))
-		     (zerop (mod i wrapper-cache-number-adds-ok)))
-	    (setq location
-		  (logand location wrapper-cache-number-mask))))
-	(1+ (logand mask location)))))
-
-;;;
-;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
-;;;
-;;; This version is called on a cache line.  It fetches the wrappers from
-;;; the cache line and determines the primary location.  Various parts of
-;;; the cache filling code call this to determine whether it is appropriate
-;;; to displace a given cache entry.
-;;; 
-;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol
-;;; invalid to suggest to its caller that it would be provident to blow away
-;;; the cache line in question.
-;;;
-(defun compute-primary-cache-location-from-location (field cache location mask nkeys)
-  (let ((result 0))
-    (dotimes (i nkeys)
-      (let* ((wrapper (cache-ref cache (+ i location)))
-	     (wcn (wrapper-ref wrapper field)))
-	(setq result (+ result wcn)))
-      (when (and (not (zerop i))
-		 (zerop (mod i wrapper-cache-number-adds-ok)))
-	(setq result (logand result wrapper-cache-number-mask)))
-      )    
-    (if (= nkeys 1)
-	(logand mask result)
-	(1+ (logand mask result)))))
-
-(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no)
-  (with-lap-registers ((mask index))
-    (let ((field wrapper-cache-no))
-      (flatten-lap
-        (opcode :move (operand :cvar 'mask) mask)
-        (opcode :move (operand :cvar 'field) field)
-        (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
-        (opcode :move (operand :ilogand wrapper-cache-no mask) primary)))))
-
-(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label)
-  (with-lap-registers ((field index)
-		       (mask index))
-    (let ((add-wrapper-cache-numbers
-	   (flatten-lap
-	    (gathering1 (flattening-lap)
-	       (iterate ((wrapper (list-elements wrappers))
-			 (i (interval :from 1)))
-		 (gather1
-		  (with-lap-registers ((wrapper-cache-no index))
-		    (flatten-lap
-		     (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
-		     (opcode :izerop wrapper-cache-no miss-label)
-		     (opcode :move (operand :i+ primary wrapper-cache-no) primary)
-		     (when (zerop (mod i wrapper-cache-number-adds-ok))
-		       (opcode :move (operand :ilogand primary mask) primary))))))))))
-      (flatten-lap
-       (opcode :move (operand :constant 0) primary)
-       (opcode :move (operand :cvar 'field) field)
-       (opcode :move (operand :cvar 'mask) mask)
-       add-wrapper-cache-numbers
-       (opcode :move (operand :ilogand primary mask) primary)
-       (opcode :move (operand :i1+ primary) primary)))))
-
-
-
-;;;
-;;;  NIL              means nothing so far, no actual arg info has NILs
-;;;                   in the metatype
-;;;  CLASS            seen all sorts of metaclasses
-;;;                   (specifically, more than one of the next 4 values)
-;;;  T                means everything so far is the class T
-;;;  STANDARD-CLASS   seen only standard classes
-;;;  BUILT-IN-CLASS   seen only built in classes
-;;;  STRUCTURE-CLASS  seen only structure classes
-;;;  
-(defun raise-metatype (metatype new-specializer)
-  (let ((standard  (find-class 'standard-class))
-	(fsc       (find-class 'funcallable-standard-class))
-;	(structure (find-class 'structure-class))
-	(built-in  (find-class 'built-in-class)))
-    (flet ((specializer->metatype (x)
-	     (let ((meta-specializer 
-		     (if (and (eq *boot-state* 'complete)
-			      (eql-specializer-p x))
-			 (class-of (class-of (eql-specializer-object x)))
-			 (class-of x))))
-	       (cond ((eq x *the-class-t*) t)
-		     ((*subtypep meta-specializer standard)  'standard-instance)
-		     ((*subtypep meta-specializer fsc)       'standard-instance)
-;                    ((*subtypep meta-specializer structure) 'structure-instance)
-		     ((*subtypep meta-specializer built-in)  'built-in-instance)
-		     (t (error "CLOS can not handle the specializer ~S (meta-specializer ~S)."
-			       new-specializer meta-specializer))))))
-      ;;
-      ;; We implement the following table.  The notation is
-      ;; that X and Y are distinct meta specializer names.
-      ;; 
-      ;;   NIL    <anything>    ===>  <anything>
-      ;;    X      X            ===>      X
-      ;;    X      Y            ===>    CLASS
-      ;;    
-      (let ((new-metatype (specializer->metatype new-specializer)))
-	(cond ((null metatype) new-metatype)
-	      ((eq metatype new-metatype) new-metatype)
-	      (t 'class))))))
-
-
-(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
-  (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
-    (with-lap-registers ((arg t))
-      (ecase metatype
-	(standard-instance
-	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
-		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
-	    (flatten-lap
-	      (opcode :move (operand :arg argument) arg)
-	      (opcode :std-instance-p arg get-std-inst-wrapper)	   ;is it a std wrapper?
-	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)	   ;is it a fsc wrapper?
-	      (opcode :go miss-label)
-	      (opcode :label get-fsc-inst-wrapper)
-	      (opcode :move (operand :fsc-wrapper arg) dest)	   ;get fsc wrapper
-	      (and slot
-		   (opcode :move (operand :fsc-slots arg) slot))
-	      (opcode :go exit-emit-fetch-wrapper)
-	      (opcode :label get-std-inst-wrapper)
-	      (opcode :move (operand :std-wrapper arg) dest)	   ;get std wrapper
-	      (and slot
-		   (opcode :move (operand :std-slots arg) slot))
-	      (opcode :label exit-emit-fetch-wrapper))))
-
-	(class
-	  (when slot (error "Can't do a slot reg for this metatype."))
-	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
-		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))
-		(get-built-in-wrapper (make-symbol "get-built-in-wrapper")))
-	    (flatten-lap
-	      (opcode :move (operand :arg argument) arg)
-	      (opcode :std-instance-p arg get-std-inst-wrapper)
-	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)
-	      (opcode :built-in-instance-p arg get-built-in-wrapper)
-	      ;; If the code falls through the checks above, there is a serious problem
-	      (opcode :label get-fsc-inst-wrapper)
-	      (opcode :move (operand :fsc-wrapper arg) dest)
-	      (opcode :go exit-emit-fetch-wrapper)
-	      (opcode :label get-built-in-wrapper)
-	      (opcode :move (operand :built-in-wrapper arg) dest)
-	      (opcode :go exit-emit-fetch-wrapper)
-	      (opcode :label get-std-inst-wrapper)
-	      (opcode :move (operand :std-wrapper arg) dest)
-	      (opcode :label exit-emit-fetch-wrapper))))
-	(structure-instance 
-	  (when slot (error "Can't do a slot reg for this metatype."))
-	  (error "Not yet implemented"))
-	(built-in-instance
-	  (when slot (error "Can't do a slot reg for this metatype."))
-	  (let ((get-built-in-wrapper (make-symbol "get-built-in-wrapper")))
-	    (flatten-lap
-	      (opcode :move (operand :arg argument) arg)
-	      (opcode :built-in-instance-p arg get-built-in-wrapper)
-	      (opcode :go miss-label)
-	      (opcode :label get-built-in-wrapper)
-	      (opcode :move (operand :built-in-wrapper arg) dest))))))))
-
-
-;;;
-;;; Some support stuff for getting a hold of symbols that we need when
-;;; building the discriminator codes.  Its ok for these to be interned
-;;; symbols because we don't capture any user code in the scope in which
-;;; these symbols are bound.
-;;; 
-
-(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
-
-(defun dfun-arg-symbol (arg-number)
-  (or (nth arg-number (the list *dfun-arg-symbols*))
-      (intern (format nil ".ARG~A." arg-number) *the-clos-package*)))
-
-(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
-
-(defun slot-vector-symbol (arg-number)
-  (or (nth arg-number (the list *slot-vector-symbols*))
-      (intern (format nil ".SLOTS~A." arg-number) *the-clos-package*)))
-
-(defun make-dfun-lambda-list (metatypes applyp)
-  (gathering1 (collecting)
-    (iterate ((i (interval :from 0))
-	      (s (list-elements metatypes)))
-      (progn s)
-      (gather1 (dfun-arg-symbol i)))
-    (when applyp
-      (gather1 '&rest)
-      (gather1 '.dfun-rest-arg.))))
-
-(defun make-dlap-lambda-list (metatypes applyp)
-  (gathering1 (collecting)
-    (iterate ((i (interval :from 0))
-	      (s (list-elements metatypes)))
-      (progn s)
-      (gather1 (dfun-arg-symbol i)))
-    (when applyp
-      (gather1 '&rest))))
-
-(defun make-dfun-call (metatypes applyp fn-variable)
-  (let ((required
-	  (gathering1 (collecting)
-	    (iterate ((i (interval :from 0))
-		      (s (list-elements metatypes)))
-	      (progn s)
-	      (gather1 (dfun-arg-symbol i))))))
-    (if applyp
-	`(apply   ,fn-variable ,@required .dfun-rest-arg.)
-	`(funcall ,fn-variable ,@required))))
-
-
-;;;
-;;; Here is where we actually fill, recache and expand caches.
-;;;
-;;; The function FILL-CACHE is the ONLY external entrypoint into this code.
-;;; It returns 4 values:
-;;;   a wrapper field number
-;;;   a cache
-;;;   a mask
-;;;   an absolute cache size (the size of the actual vector)
-;;;
-;;;
-(defun fill-cache (field cache nkeys valuep limit-fn wrappers value)
-  (declare (values field cache mask size))
-  (fill-cache-internal field cache nkeys valuep limit-fn wrappers value))
-
-(defun default-limit-fn (nlines)
-  (case nlines
-    ((1 2 4) 1)
-    ((8 16)  4)
-    (otherwise 6)))
-
-
-;;;
-;;; Its too bad Common Lisp compilers freak out when you have a defun with
-;;; a lot of LABELS in it.  If I could do that I could make this code much
-;;; easier to read and work with.
-;;;
-;;; Ahh Scheme...
-;;; 
-;;; In the absence of that, the following little macro makes the code that
-;;; follows a little bit more reasonable.  I would like to add that having
-;;; to practically write my own compiler in order to get just this simple
-;;; thing is something of a drag.
-;;;
-(eval-when (compile load eval)
-
-(proclaim '(special *nkeys* *valuep* *limit-fn*))
-
-;;; This patch avoids a bug in the ENVCALL instruction. Lookup of free
-;;; variables under ENVCALL always results in nil. In particular, the
-;;; compiler generates such code for flet and friends. Therefore, some
-;;; macros must be defined at top-level.
-
-;(defmacro cache     () '.cache.)
-;(defmacro nkeys () '*nkeys*)
-;(defmacro valuep    () '*valuep*)
-;(defmacro limit-fn  () '*limit-fn*)
-;(defmacro line-size () '.line-size.)
-;(defmacro mask      () '.mask.)
-;(defmacro size      () '.size.)
-;(defmacro nlines    () '.nlines.)
-;(defmacro line-reserved-p (line)
-;            `(and (= (nkeys) 1)
-;                 (= ,line 0)))
-;(defmacro line-location (line)
-;            `(and (null (line-reserved-p ,line))
-;                 (if (= (nkeys) 1)
-;                     (* ,line (line-size))
-;                     (1+ (* ,line (line-size))))))
-;(defmacro location-line (location)
-;            `(if (= (nkeys) 1)
-;                (/ ,location (line-size))
-;                (/ (1- ,location) (line-size))))
-;end patch
-
-(defvar *local-cache-functions*
-	`((cache     () .cache.)
-	  (nkeys     () *nkeys*)
-	  (valuep    () *valuep*)
-	  (limit-fn  () *limit-fn*)
-	  (line-size () .line-size.)
-	  (mask      () .mask.)
-	  (size      () .size.)
-	  (nlines    () .nlines.)
-	  ;;
-	  ;; Return T IFF this cache location is reserved.  The only time
-	  ;; this is true is for line number 0 of an nkeys=1 cache.  
-	  ;;
-	  (line-reserved-p (line)
-	    (and (= (nkeys) 1)
-		 (= line 0))) 
-	  ;;
-	  ;; Given a line number, return the cache location.  This is the
-	  ;; value that is the second argument to cache-ref.  Basically,
-	  ;; this deals with the offset of nkeys>1 caches and multiplies
-	  ;; by line size.  This returns nil if the line is reserved.
-	  ;; 	  
-	  (line-location (line)
-	    (and (null (line-reserved-p line))
-		 (if (= (nkeys) 1)
-		     (* line (line-size))
-		     (1+ (* line (line-size)))))) 
-	  ;;
-	  ;; Given a cache location, return the line.  This is the inverse
-	  ;; of LINE-LOCATION.
-	  ;; 	  
-	  (location-line (location)
-	    (if (= (nkeys) 1)
-		(/ location (line-size))
-		(/ (1- location) (line-size)))) 
-	  ;;
-	  ;; Given a line number, return the wrappers stored at that line.
-	  ;; As usual, if nkeys=1, this returns a single value.  Only when
-	  ;; nkeys>1 does it return a list.  An error is signalled if the
-	  ;; line is reserved.
-	  ;;
-	  (line-wrappers (line)
-	    (when (line-reserved-p line) (error "Line is reserved."))
-	    (let ((location (line-location line)))
-	      (if (= (nkeys) 1)
-		  (cache-ref (cache) location)
-		  (gathering1 (collecting)
-		    (dotimes (i (nkeys))
-		      (gather1 (cache-ref (cache) (+ location i))))))))
-	  ;;
-	  ;; Given a line number, return the value stored at that line.
-	  ;; If valuep is NIL, this returns NIL.  As with line-wrappers,
-	  ;; an error is signalled if the line is reserved.
-	  ;; 
-	  (line-value (line)
-	    (when (line-reserved-p line) (error "Line is reserved."))
-	    (and (valuep)
-		 (cache-ref (cache) (+ (line-location line) (nkeys)))))
-	  ;;
-	  ;; Given a line number, return true IFF that line has data in
-	  ;; it.  The state of the wrappers stored in the line is not
-	  ;; checked.  An error is signalled if line is reserved.
-	  (line-full-p (line)
-	    (when (line-reserved-p line) (error "Line is reserved."))
-	    (not (null (cache-ref (cache) (line-location line)))))
-	  ;;
-	  ;; Given a line number, return true IFF the line is full and
-	  ;; there are no invalid wrappers in the line, and the line's
-	  ;; wrappers are different from wrappers.
-	  ;; An error is signalled if the line is reserved.
-	  ;;
-	  (line-valid-p (line wrappers)
-	    (when (line-reserved-p line) (error "Line is reserved."))
-	    (let ((loc (line-location line)))
-	      (dotimes (i (nkeys) t)
-		(let ((wrapper (cache-ref (cache) (+ loc i))))
-		  (when (or (null wrapper)
-;***					(numberp wrapper)
-					;Think of this as an optimized:
-					; (and (zerop i)
-					;      (= (nkeys) 1)
-					;      (null (valuep))
-					;      (numberp wrapper))
-                            (invalid-wrapper-p wrapper))
-                    (return nil))))))
-	  ;;
-	  ;; How many unreserved lines separate line-1 and line-2.
-	  ;;
-	  (line-separation (line-1 line-2)
-	    (let ((diff (- line-2 line-1)))
-	      (cond ((zerop diff) diff)
-		    ((plusp diff) diff)
-		    (t
-		     (if (line-reserved-p 0)
-			 (1- (+ (- (nlines) line-1) line-2))
-			 (+ (- (nlines) line-1) line-2))))))
-	  ;;
-	  ;; Given a cache line, get the next cache line.  This will not
-	  ;; return a reserved line.
-	  ;; 
-	  (next-line (line)
-	    (if (= line (1- (nlines)))
-		(if (line-reserved-p 0) 1 0)
-		(1+ line)))
-	  ;;
-	  ;; Given a line which has a valid entry in it, this will return
-	  ;; the primary cache line of the wrappers in that line.  We just
-	  ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an
-	  ;; easier packaging up of the call to it.
-	  ;; 
-	  (line-primary (field line)
-	    (location-line
-	      (compute-primary-cache-location-from-location
-		field (cache) (line-location line) (mask) (nkeys))))
-	  ;;
-	  ;;
-	  (fill-line (line wrappers value)
-	    (when (line-reserved-p line)
-	      (error "Attempt to fill a reserved line."))
-	    (let ((loc (line-location line)))
-	      (cond ((= (nkeys) 1)
-		     (setf (cache-ref (cache) loc) wrappers)
-		     (when (valuep) (setf (cache-ref (cache) (1+ loc)) value)))
-		    (t
-		     (iterate ((i (interval :from 0))
-			       (w (list-elements wrappers)))
-		       (setf (cache-ref (cache) (+ loc i)) w))
-		     (when (valuep) (setf (cache-ref (cache) (+ loc (nkeys))) value))))))
-	  ;;
-	  ;; Blindly copy the contents of one cache line to another.  The
-	  ;; contents of the <to> line are overwritten, so whatever was in
-	  ;; there should already have been moved out.
-	  ;;
-	  ;; For convenience in debugging, this also clears out the from
-	  ;; location after it has been copied.
-	  ;;
-	  (copy-line (from to)
-	    (if (line-reserved-p to)
-		(error "Copying something into a reserved cache line.")
-		(let ((from-loc (line-location from))
-		      (to-loc (line-location to)))
-		  (modify-cache (cache)
-		    (dotimes (i (line-size))
-		      (setf (cache-ref (cache) (+ to-loc i))
-			    (cache-ref (cache) (+ from-loc i)))
-		      (setf (cache-ref (cache) (+ from-loc i))
-			    nil))))))
-	  ;;
-	  ;;
-	  ;;
-	  (transfer-line (from-cache from-line to-cache to-line)
-	    (if (line-reserved-p to-line)
-		(error "transfering something into a reserved cache line.")
-		(let ((from-loc (line-location from-line))
-		      (to-loc (line-location to-line)))
-		  (modify-cache to-cache
-		    (dotimes (i (line-size))
-		      (setf (cache-ref to-cache (+ to-loc i))
-			    (cache-ref from-cache (+ from-loc i))))))))
-	  ))
-
-(defmacro with-local-cache-functions ((cache) &body body &environment env)
-  `(let ((.cache. ,cache))
-     (declare (type simple-vector .cache.))
-     (multiple-value-bind (.mask. .size. .line-size. .nlines.)
-	 (compute-cache-parameters *nkeys* *valuep* .cache.)
-       (declare (type fixnum .mask. .size. .line-size. .nlines.))
-       (progn .mask. .size. .line-size. .nlines.)
-       (labels ,(mapcar #'(lambda (fn) (assq fn *local-cache-functions*))
-			(pickup-local-cache-functions body env))
-	 ,@body))))
-
-(defun pickup-local-cache-functions (body env)
-  (let ((functions ())
-	(possible-functions (mapcar #'car *local-cache-functions*)))
-    (labels ((walk-function (form context env)
-	       (declare (ignore env))
-	       (when (and (eq context :eval)
-			  (consp form)
-			  (symbolp (car form)))
-		 (let ((name (car form)))
-		   (when (and (not (memq name functions))
-			      (memq name possible-functions))
-		     (pushnew name functions)
-		     (walk (cddr (assq name *local-cache-functions*))))))
-	       form)
-	     (walk (body)
-	       (walk-form `(progn . ,body) env #'walk-function)))
-      (walk body)
-      functions)))
-
-)
-
-
-;;;
-;;; returns 4 values, <field> <cache> <mask> <size>
-;;; It tries to re-adjust the cache every time it makes a new fill.  The
-;;; intuition here is that we want uniformity in the number of probes needed to
-;;; find an entry.  Furthermore, adjusting has the nice property of throwing out
-;;; any entries that are invalid.
-;;;
-(defun fill-cache-internal (field cache nkeys valuep limit-fn wrappers value)
-  (let ((*nkeys* nkeys)
-	(*valuep* valuep)
-	(*limit-fn* limit-fn))
-    (with-local-cache-functions (cache)
-      (flet ((4-values-please (f c)
-	       (multiple-value-bind (mask size)
-		   (compute-cache-parameters *nkeys* *valuep* c)
-		 (values f c mask size))))
-	(let ((easy-fill-p (fill-cache-p nil field cache wrappers value)))
-	  (if easy-fill-p
-	      (4-values-please field cache)
-	      (multiple-value-bind (adj-field adj-cache)
-		  (adjust-cache field cache wrappers value)
-		(if adj-field
-		    (4-values-please adj-field adj-cache)
-		    (multiple-value-bind (exp-field exp-cache)
-			(expand-cache field cache wrappers value)
-		      (4-values-please exp-field exp-cache))))))))))
-
-;;;
-;;; returns T or NIL
-;;;
-(defun fill-cache-p (forcep field cache wrappers value)
-  (with-local-cache-functions (cache)
-    (let* ((primary (location-line (compute-primary-cache-location field (mask) wrappers))))
-      (multiple-value-bind (free emptyp)
-	  (find-free-cache-line primary field cache wrappers)
-	(when (or forcep emptyp) (fill-line free wrappers value) t)))))
-
-(defun fill-cache-from-cache-p (forcep field cache from-cache from-line)
-  (with-local-cache-functions (from-cache)
-    (let ((primary (line-primary field from-line)))
-      (multiple-value-bind (free emptyp)
-	  (find-free-cache-line primary field cache)
-	(when (or forcep emptyp)
-	  (transfer-line from-cache from-line cache free)
-	  t)))))
-
-(defun entry-in-cache-p (field cache wrappers value)
-  (declare (ignore field value))
-  (with-local-cache-functions (cache)
-    (dotimes (i (nlines))
-      (unless (line-reserved-p i)
-	(when (equal (line-wrappers i) wrappers) (return t))))))
-
-;;;
-;;; Returns NIL or (values <field> <cache>)
-;;; 
-;;; This is only called when it isn't possible to put the entry in the cache
-;;; the easy way.  That is, this function assumes that FILL-CACHE-P has been
-;;; called as returned NIL.
-;;;
-;;; If this returns NIL, it means that it wasn't possible to find a wrapper
-;;; field for which all of the entries could be put in the cache (within the
-;;; limit).  
-;;;
-(defun adjust-cache (field cache wrappers value)
-  (with-local-cache-functions (cache)
-    (let ((ncache (get-cache (size))))
-      (do ((nfield field (next-wrapper-field nfield)))
-	  ((null nfield) (free-cache ncache) nil)
-	(labels ((try-one-fill-from-line (line)
-		   (fill-cache-from-cache-p nil nfield ncache cache line))
-		 (try-one-fill (wrappers value)
-		   (fill-cache-p nil nfield ncache wrappers value)))
-	  (if (and (dotimes (i (nlines) t)
-		     (when (and (null (line-reserved-p i))
-				(line-valid-p i wrappers))
-		       (unless (try-one-fill-from-line i) (return nil))))
-		   (try-one-fill wrappers value))
-	      (return (values nfield ncache))
-	      (flush-cache-internal ncache)))))))
-
-		       
-;;;
-;;; returns: (values <field> <cache>)
-;;;
-(defun expand-cache (field cache wrappers value)
-  (declare (values field cache) (ignore field))
-  (with-local-cache-functions (cache)
-    (multiple-value-bind (ignore size)
-	(compute-cache-parameters (nkeys) (valuep) (* (nlines) 2))
-      (let* ((ncache (get-cache size))
-	     (nfield (wrapper-field 'number)))
-	(labels ((do-one-fill-from-line (line)
-		   (unless (fill-cache-from-cache-p nil nfield ncache cache line)
-		     (do-one-fill (line-wrappers line) (line-value line))))
-		 (do-one-fill (wrappers value)
-		   (multiple-value-bind (adj-field adj-cache)
-		       (adjust-cache nfield ncache wrappers value)
-		     (if adj-field
-			 (setq nfield adj-field ncache adj-cache)
-			 (fill-cache-p t nfield ncache wrappers value))))
-		 (try-one-fill (wrappers value)
-		   (fill-cache-p nil nfield ncache wrappers value)))
-	  (dotimes (i (nlines))
-	    (when (and (null (line-reserved-p i))
-		       (line-valid-p i wrappers))
-	      (do-one-fill-from-line i)))
-	  (unless (try-one-fill wrappers value)
-	    (do-one-fill wrappers value))
-	  (values nfield ncache))))))
-
-
-;;;
-;;; This is the heart of the cache filling mechanism.  It implements the decisions
-;;; about where entries are placed.
-;;; 
-;;; Find a line in the cache at which a new entry can be inserted.
-;;;
-;;;   <line>
-;;;   <empty?>           is <line> in fact empty?
-;;;
-(defun find-free-cache-line (primary field cache &optional wrappers)
-  (declare (values line empty?))
-  (with-local-cache-functions (cache)
-    (let ((limit (funcall (limit-fn) (nlines)))
-	  (wrappedp nil))
-      (when (line-reserved-p primary) (setq primary (next-line primary)))
-      (labels (;;
-	       ;; Try to find a free line starting at <start>.  <primary>
-	       ;; is the primary line of the entry we are finding a free
-	       ;; line for, it is used to compute the seperations.
-	       ;;
-	       (find-free (p s)
-		 (do* ((line s (next-line line))
-		       (nsep (line-separation p s) (1+ nsep)))
-		      (())
-		   (if (null (line-valid-p line wrappers)) ;If this line is empty or
-		       (return (values line t))	           ;invalid, just use it.
-
-		       (let ((osep (line-separation (line-primary field line) line)))
-			 (if (and wrappedp (>= line primary))
-			     ;;
-			     ;; have gone all the way around the cache, time to quit
-			     ;; 
-			     (return (values line nil))
-			     
-			     (when (cond ((or (= nsep limit)) t)
-					 ((= nsep osep) (zerop (random 2)))
-					 ((> nsep osep) t)
-					 (t nil))
-			       ;;
-			       ;; Try to displace what is in this line so that we
-			       ;; can use the line.
-			       ;;
-			       (return (values line (displace line)))))))
-		   
-		   (if (= line (1- (nlines))) (setq wrappedp t))))
-	       ;;
-	       ;; Given a line, attempt to free up that line by moving its
-	       ;; contents elsewhere. Returns nil when it wasn't possible to
-	       ;; move the contents of the line without dumping something on
-	       ;; the floor.  
-	       ;; 
-	       (displace (line)
-		 (if (= line (1- (nlines))) (setq wrappedp t))
-		 (multiple-value-bind (dline dempty?)
-		     (find-free (line-primary field line) (next-line line))
-		   (when dempty? (copy-line line dline) t))))
-	
-	(find-free primary primary)))))
diff --git a/obsolete/clos/2.0/clos-env-internal.lisp b/obsolete/clos/2.0/clos-env-internal.lisp
deleted file mode 100644
index 6d720032..00000000
--- a/obsolete/clos/2.0/clos-env-internal.lisp
+++ /dev/null
@@ -1,260 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL")
-(il:filecreated "28-Aug-87 18:42:36" il:{phylum}<clos>clos-env-internal.\;1 8356   
-
-      il:|changes| il:|to:|  (il:vars il:clos-env-internalcoms)
-                             (il:props (il:clos-env-internal il:makefile-environment))
-                             (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
-                                    stack-frame-fn-header stack-frame-pc fnheader-debugging-info 
-                                    stack-frame-name compiled-closure-fnheader compiled-closure-env)
-)
-
-
-; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.
-
-(il:prettycomprint il:clos-env-internalcoms)
-
-(il:rpaqq il:clos-env-internalcoms (
-
-(il:* il:|;;;| "***************************************")
-
-                                   
-
-(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
-
-                                   
-
-(il:* il:|;;;| "")
-
-                                   
-
-(il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws.")
-
-                                   
-
-(il:* il:|;;;| " ")
-
-                                   
-
-(il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification.")
-
-                                   
-
-(il:* il:|;;;| " ")
-
-                                   
-
-(il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:")
-
-                                   
-
-(il:* il:|;;;| "   CommonLoops Coordinator")
-
-                                   
-
-(il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
-
-                                   
-
-(il:* il:|;;;| "   2400 Hanover St.")
-
-                                   
-
-(il:* il:|;;;| "   Palo Alto, CA 94303")
-
-                                   
-
-(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
-
-                                   
-
-(il:* il:|;;;| "")
-
-                                   
-
-(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
-
-                                   
-
-(il:* il:|;;;| " *************************************************************************")
-
-                                   
-
-(il:* il:|;;;| "")
-
-                                   (il:declare\: il:dontcopy (il:prop il:makefile-environment 
-                                                                    il:clos-env-internal))
-                                                             (il:* il:\; 
-                                                             "We're off to hack the system...")
-
-                                   (il:declare\: il:eval@compile il:dontcopy (il:files clos::abc)
-                                          
-          
-          (il:* il:|;;| "The Deltas and The East and The Freeze")
-)
-                                   (il:functions stack-eql stack-pointer-frame stack-frame-valid-p 
-                                          stack-frame-fn-header stack-frame-pc 
-                                          fnheader-debugging-info stack-frame-name 
-                                          compiled-closure-fnheader compiled-closure-env)))
-
-
-
-(il:* il:|;;;| "***************************************")
-
-
-
-
-(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation.  All rights reserved.")
-
-
-
-
-(il:* il:|;;;| "")
-
-
-
-
-(il:* il:|;;;| 
-"Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws."
-)
-
-
-
-
-(il:* il:|;;;| " ")
-
-
-
-
-(il:* il:|;;;| 
-"This software is made available AS IS, and Xerox Corporation makes no  warranty about the software, its performance or its conformity to any  specification."
-)
-
-
-
-
-(il:* il:|;;;| " ")
-
-
-
-
-(il:* il:|;;;| 
-"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:"
-)
-
-
-
-
-(il:* il:|;;;| "   CommonLoops Coordinator")
-
-
-
-
-(il:* il:|;;;| "   Xerox Artifical Intelligence Systems")
-
-
-
-
-(il:* il:|;;;| "   2400 Hanover St.")
-
-
-
-
-(il:* il:|;;;| "   Palo Alto, CA 94303")
-
-
-
-
-(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
-
-
-
-
-(il:* il:|;;;| "")
-
-
-
-
-(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
-
-
-
-
-(il:* il:|;;;| " *************************************************************************")
-
-
-
-
-(il:* il:|;;;| "")
-
-(il:declare\: il:dontcopy 
-
-(il:putprops il:clos-env-internal il:makefile-environment (:package "XCL" :readtable "XCL"))
-)
-
-
-
-(il:* il:\; "We're off to hack the system...")
-
-(il:declare\: il:eval@compile il:dontcopy 
-(il:filesload clos::abc)
-)
-
-(defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x)
-                                                                   (il:stackp y)
-                                                                   (eql (il:fetch (il:stackp il:edfxp
-                                                                                         )
-                                                                           il:of x)
-                                                                        (il:fetch (il:stackp il:edfxp
-                                                                                         )
-                                                                           il:of y))))
-
-
-(defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer))
-
-
-(defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame)))
-
-
-(defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame))
-
-
-(defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame))
-
-
-(defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc)
-                                                              il:of fnheader))
-                                                 (name-table-words
-                                                  (let ((size (il:fetch (il:fnheader il:ntsize)
-                                                                 il:of fnheader)))
-                                                       (if (zerop size)
-                                                           il:wordsperquad
-                                                           (* size 2))))
-                                                 (past-name-table-in-words (+ (il:fetch (il:fnheader
-                                                                                         
-                                                                                     il:overheadwords
-                                                                                         )
-                                                                                 il:of fnheader)
-                                                                              name-table-words)))
-                                                (and (= (- start-pc (* il:bytesperword 
-                                                                       past-name-table-in-words))
-                                                        il:bytespercell)
-          
-          (il:* il:|;;| "It's got a debugging-info list.")
-
-                                                     (il:\\getbaseptr fnheader 
-                                                            past-name-table-in-words))))
-
-
-(defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame))
-
-
-(defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of|
-                                                                                         closure))
-
-
-(defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure))
-
-(il:putprops il:clos-env-internal il:copyright ("Xerox Corporation" 1987))
-(il:declare\: il:dontcopy
-  (il:filemap (nil)))
-il:stop
diff --git a/obsolete/clos/2.0/clos-env.lisp b/obsolete/clos/2.0/clos-env.lisp
deleted file mode 100644
index be366810..00000000
--- a/obsolete/clos/2.0/clos-env.lisp
+++ /dev/null
@@ -1,1609 +0,0 @@
-;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-;;; Medley-Lisp specific environment hacking for CLOS
-
-(in-package "CLOS")
-
-;; 
-;; Protect the Corporation
-;; 
-(eval-when (eval load)
-  (format *terminal-io*
-    "~&;CLOS-ENV Copyright (c) 1991 by ~
-        Venue Corporation.  All rights reserved.~%"))
-
-
-;;; Make funcallable instances (FINs) print by calling print-object.
-
-(eval-when (eval load)
-  (il:defprint 'il:compiled-closure 'il:print-closure))
-
-(defun il:print-closure (x &optional stream depth)
-  ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is
-  ;; not correct.  In particular, it makes no mention of the third argument.
-  (cond ((not (funcallable-instance-p x))
-	 ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for
-	 ;; printing closures
-	 (il:\\cclosure.defprint x stream))
-	((streamp stream)
-	 ;; Use the standard CLOS printing method, then return T to tell
-	 ;; the printer that we have done the printing ourselves.
-	 (print-object x stream)
-	 t)
-	(t 
-	 ;; Internal printing (again, see the IRM section 25.3.3). 
-	 ;; Return a list containing the string of characters that
-	 ;; would be printed, if the object were being printed for
-	 ;; real.
-	 (with-output-to-string (stream)
-	   (list (print-object x stream))))))
-
-
-;;; Naming methods
-
-(defun gf-named (gf-name)
-  (let ((spec (cond ((symbolp gf-name) gf-name)
-		    ((and (consp gf-name)
-			  (eq (first gf-name) 'setf)
-			  (symbolp (second gf-name))
-			  (null (cddr gf-name)))
-		     (get-setf-function-name (second gf-name)))
-		    (t nil))))
-    (if (and (fboundp spec)
-	     (generic-function-p (symbol-function spec)))
-	(symbol-function spec)
-	nil)))
-
-(defun generic-function-method-names (gf-name hasdefp)
-  (if hasdefp
-      (let ((names nil))
-        (maphash #'(lambda (key value)
-                     (declare (ignore value))
-                     (when (and (consp key) (eql (car key) gf-name))
-                       (pushnew key names)))
-                 (gethash 'methods xcl:*definition-hash-table*))
-        names)
-      (let ((gf (gf-named gf-name)))
-        (when gf
-          (mapcar #'full-method-name (generic-function-methods gf))))))
-
-(defun full-method-name (method)
-  "Return the full name of the method"
-  (let ((specializers (mapcar #'(lambda (x)
-		                  (cond ((eq x 't) t)
-		                        ((and (consp x) (eq (car x) 'eql)) x)
-		                        (t (class-name x))))
-		       (method-specializers method))))
-    ;; Now go through some hair to make sure that specializer is
-    ;; really right.  Once CLOS returns the right value for
-    ;; specializers this can be taken out.
-    (let* ((arglist (method-lambda-list method))
-	   (number-required (or (position-if
-				  #'(lambda (x) (member x lambda-list-keywords))
-				  arglist)
-				(length arglist)))
-	   (diff (- number-required (length specializers))))
-      (when (> diff 0)
-	(setq specializers (nconc (copy-list specializers)
-				  (make-list diff :initial-element 't)))))
-    (make-full-method-name (generic-function-name
-			       (method-generic-function method))
-			   (method-qualifiers method)
-			   specializers)))
-
-(defun make-full-method-name (generic-function-name qualifiers arg-types)
-  "Return the full name of a method, given the generic-function name, the method
-qualifiers, and the arg-types"
-  ;; The name of the method is:
-  ;;      (<generic-function-name> <qualifier-1> .. 
-  ;;         (<arg-specializer-1>..))
-  (labels ((remove-trailing-ts (l)
-	     (if (null l)
-		 nil
-		 (let ((tail (remove-trailing-ts (cdr l))))
-		   (if (null tail)
-		       (if (eq (car l) 't)
-			   nil
-			   (list (car l)))
-		       (if (eq l tail)
-			   l
-			   (cons (car l) tail)))))))
-    `(,generic-function-name ,@qualifiers
-      ,(remove-trailing-ts arg-types))))
-
-(defun parse-full-method-name (method-name)
-  "Parse the method name, returning the gf-name, the qualifiers, and the
-arg-types."
-  (values (first method-name)
-	  (butlast (rest method-name))
-	  (car (last method-name))))
-
-(defun prompt-for-full-method-name (gf-name &optional has-def-p)
-  "Prompt the user for the full name of a method on the given generic function name"
-  (let ((method-names (generic-function-method-names gf-name has-def-p)))
-    (cond ((null method-names)
-	   nil)
-	  ((null (cdr method-names))
-	   (car method-names))
-	  (t (il:menu
-	      (il:create
-	       il:menu il:items il:_	;If HAS-DEF-P, include only
-					; those methods that have a
-					; symbolic def'n that we can
-					; find
-	       (remove-if #'null
-			  (mapcar #'(lambda (m)
-				      (if (or (not has-def-p)
-					      (il:hasdef m 'methods))
-					  `(,(with-output-to-string (s)
-					       (dolist (x m)
-						 (format s "~A " x))
-					       s)
-					    ',m)
-					  nil))
-				  method-names))
-	       il:title il:_ "Which method?"))))))
-
-
-;;; Converting generic defining macros into DEFDEFINER macros
-
-(defmacro make-defdefiner (definer-name definer-type type-description &body 
-					definer-options)
-  "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE"
-  (let ((old-definer-macro-name (intern (string-append definer-name
-						       " old definition")
-					(symbol-package definer-name)))
-	(old-definer-macro-expander (intern (string-append definer-name 
-							   " old expander")
-					    (symbol-package definer-name))))
-    `(progn 
-      ;; First, move the current defining function off to some safe
-      ;; place
-      (unmake-defdefiner ',definer-name)
-      (cond ((not (fboundp ',definer-name))
-	     (error "~A has no definition!" ',definer-name))
-	    ((fboundp ',old-definer-macro-name))
-	    ((macro-function ',definer-name)
-					; We have to move the macro
-					; expansion function as well,
-					; so it won't get clobbered
-					; when the original macro is
-					; redefined.  See AR 7410.
-	     (let* ((expansion-function (macro-function ',definer-name)))
-	       (setf (symbol-function ',old-definer-macro-expander)
-		     (loop (if (symbolp expansion-function)
-			       (setq expansion-function
-				     (symbol-function expansion-function))
-			       (return expansion-function))))
-	       (setf (macro-function ',old-definer-macro-name)
-		     ',old-definer-macro-expander)
-	       (setf (get ',definer-name 'make-defdefiner) expansion-function)))
-	    (t (error "~A does not name a macro." ',definer-name)))
-      ;; Make sure the type is defined
-      (xcl:def-define-type ,definer-type ,type-description)
-      ;; Now redefine the definer, using DEFEDFINER and the original def'n
-      (xcl:defdefiner ,(if definer-options
-			   (cons definer-name definer-options)
-			   definer-name)
-	  ,definer-type	(&body b) `(,',old-definer-macro-name ,@,'b)))))
-
-(defun unmake-defdefiner (definer-name)
-  (let ((old-expander (get definer-name 'make-defdefiner)))
-    (when old-expander
-      (setf (macro-function definer-name old-expander))
-      (remprop definer-name 'make-defdefiner))))
-
-
-;;; For tricking ED into being able to use just the generic-function-name
-;;; instead of the full method name
-
-(defun source-manager-method-edit-fn (name type source editcoms options)
-  "Edit a method of the given name"
-  (let ((full-name (if (gf-named name)
-					;If given the name of a
-					; generic-function, try to get
-					; the full method name
-		       (prompt-for-full-method-name name t)
-					; Otherwise it should name the
-					; method
-		       name)))
-    (when (not (null full-name))
-      (il:default.editdef full-name type source editcoms options))
-    (or full-name name)))		;Return the name
-
-(defun source-manager-method-hasdef-fn (name type &optional source)
-  "Is there a method defined with the given name?"
-  (cond ((not (eq type 'methods)) nil)
-	((or (symbolp name)
-	     (and (consp name)
-		  (eq (first name) 'setf)
-		  (symbolp (second name))
-		  (null (cddr name))))
-	 ;; If passed in the name of a generic-function, pretend that
-	 ;; there is a method by that name if there is a generic function
-	 ;; by that name, and there is a method whose source we can find.
-	 (if (and (not (null (gf-named name)))
-		  (find-if #'(lambda (m)
-			       (il:hasdef m type source))
-			   (generic-function-method-names name t)))
-	     name
-	     nil))
-	((and (consp name) (>= (length name) 2))
-	 ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*))
-	 (when (il:getdef name type source '(il:nocopy il:noerror))
-	   name))
-	(t
-	 ;; Nothing else can name a method
-	 nil)))
-
-;;; Initialize the CLOS env
-
-(defun initialize-clos-env nil
-  "Initialize the Medley CLOS environment" 
-  ;; Set up SourceManager DEFDEFINERS for classes and methods.
-  ;;
-  ;; Make sure to define methods before classes, so that (IL:FILES?) will build
-  ;; filecoms that have classes before methods. 
-  (unless (il:hasdef 'methods 'il:filepkgtype)
-    (make-defdefiner defmethod methods "methods"
-		     (:name (lambda (form)
-			      (multiple-value-bind (name qualifiers arglist)
-				  (parse-defmethod (cdr form))
-				(make-full-method-name name qualifiers
-				    (specialized-lambda-list-specializers
-					arglist)))))
-		     (:undefiner
-		      (lambda (method-name)
-			(multiple-value-bind
-			      (name qualifiers arg-types)
-			    (parse-full-method-name method-name)
-			  (let* ((gf (gf-named name))
-				 (method (when gf
-					   (get-method gf qualifiers
-						       (mapcar #'find-class 
-							       arg-types)))))
-			    (when method (remove-method gf method))))))))
-  ;; Include support for DEFGENERIC, if that is defined
-  (unless (or (not (fboundp 'defgeneric))
-	      (il:hasdef 'generic-functions 'il:filepkgtype))
-    (make-defdefiner defgeneric generic-functions "generic-function definitions"))
-  ;; DEFCLASS FileManager stuff
-  (unless (il:hasdef 'classes 'il:filepkgtype)
-    (make-defdefiner defclass classes "class definitions"
-		     (:undefiner (lambda (name)
-				   (when (find-class name t)
-				     (setf (find-class name) nil)))))
-    ;; CLASSES "include" TYPES.
-    (il:filepkgcom 'classes 'il:contents
-		   #'(lambda (com name type &optional reason)
-		       (declare (ignore name reason))
-		       (if (member type '(il:types classes) :test #'eq)
-			   (cdr com)
-			   nil))))
-  ;; Set up the hooks so that ED can be handed the name of a generic function,
-  ;; and end up editing a method instead
-  (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn
-		  'il:hasdef 'source-manager-method-hasdef-fn)
-  ;; Set up the inspect macro.  The right way to do this is to
-  ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now...
-  (push '((il:function clos-object-p) . \\internal-inspect-object)
-	il:inspectmacros)
-  ;; Unmark any SourceManager changes caused by this loadup
-  (dolist (com (il:filepkgchanges))
-    (dolist (name (cdr com))
-      (when (and (symbolp name)
-		 (eq (symbol-package name) (find-package "CLOS")))
-	(il:unmarkaschanged name (car com))))))
-
-(eval-when (eval load)
-  (initialize-clos-env))
-
-
-;;; Inspecting CLOS objects
-
-(defun clos-object-p (x)
-  "Is the datum a CLOS object?"
-  (or (std-instance-p x)
-      (fsc-instance-p x)))
-
-(defun \\internal-inspect-object (x type where)
-  (inspect-object x type where))
-
-(defun \\internal-inspect-slot-names (x)
-  (inspect-slot-names x))
-
-(defun \\internal-inspect-slot-value (x slot-name)
-  (inspect-slot-value x slot-name))
-
-(defun \\internal-inspect-setf-slot-value (x slot-name value)
-  (inspect-setf-slot-value x slot-name value))
-
-(defun \\internal-inspect-slot-name-command (slot-name x window)
-  (inspect-slot-name-command slot-name x window))
-
-(defun \\internal-inspect-title (x y)
-  (inspect-title x y))
-
-(defmethod inspect-object (x type where)
-  "Open an insect window on the object x"
-  (il:inspectw.create x '\\internal-inspect-slot-names
-              '\\internal-inspect-slot-value
-              '\\internal-inspect-setf-slot-value
-              '\\internal-inspect-slot-name-command nil nil 
-              '\\internal-inspect-title nil where
-              #'(lambda (n v)		;Same effect as NIL, but avoids bug in
-		  (declare (ignore v))	; INSPECTW.CREATE
-		  n)))
-
-(defmethod inspect-slot-names (x)
-  "Return a list of names of slots of the object that should be shown in the
-inspector"
-  (mapcar #'(lambda (slotd) (slot-value slotd 'name))
-	  (slots-to-inspect (class-of x) x)))
-
-(defmethod inspect-slot-value (x slot-name)
-  (cond ((not (slot-exists-p x slot-name)) "** no such slot **")
-	((not (slot-boundp x slot-name)) "** slot not bound **")
-	(t (slot-value x slot-name))))
-
-(defmethod inspect-setf-slot-value (x slot-name value)
-  "Used by the inspector to set the value fo a slot"
-  ;; Make this UNDO-able
-  (il:undosave `(inspect-setf-slot-value ,x ,slot-name
-		 ,(slot-value x slot-name)))
-  ;; Then change the value
-  (setf (slot-value x slot-name) value))
-
-(defmethod inspect-slot-name-command (slot-name x window)
-  "Allows the user to select a menu item to change a slot value in an inspect
-window"
-  ;; This code is a very slightly hacked version of the system function
-  ;; DEFAULT.INSPECTW.PROPCOMMANDFN.  We have to do this because the
-  ;; standard version makes some nasty assumptions about
-  ;; structure-objects that are not true for CLOS objects.
-  (declare (special il:|SetPropertyMenu|))
-  (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu)
-			il:|SetPropertyMenu|)
-		       (t (il:setq il:|SetPropertyMenu|
-				   (il:|create| il:menu il:items il:_
-				       '((set 'set 
-					  "Allows a new value to be entered"
-					  )))))))
-    (set 
-     ;; The user want to set the value
-     (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name 
-								window))
-		       il:newvalue il:pwindow)
-		   (il:ttydisplaystream (il:setq il:pwindow
-						 (il:getpromptwindow window 3)))
-		   (il:clearbuf t t)
-		   (il:resetlst
-		    (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window)
-				  (list 'il:\\itemw.flipitem 
-					il:oldvalueitem window))
-		    (il:resetsave (il:tty.process (il:this.process)))
-		    (il:resetsave (il:printlevel 4 3))
-		    (il:|printout| t "Enter the new " 
-			slot-name " for " x t 
-			"The expression read will be EVALuated."
-			t "> ")
-		    (il:setq il:newvalue (il:lispx (il:lispxread t t)
-						   '>))
-					; clear tty buffer because it
-					; sometimes has stuff left.
-		    (il:clearbuf t t))
-		   (il:closew il:pwindow)
-		   (return (il:inspectw.replace window slot-name il:newvalue)))))))
-
-(defmethod inspect-title (x window)
-  "Return the title to use in an inspect window viewing x"
-  (format nil "Inspecting a ~A" (class-name (class-of x))))
-
-(defmethod inspect-title ((x standard-class) window)
-  (format nil "Inspecting the class ~A" (class-name x)))
-
-
-;;;  Debugger support for CLOS
-
-
-(il:filesload clos-env-internal)
-
-;; Non-CLOS specific changes to the debugger
-
-;; Redefining the standard INTERESTING-FRAME-P function.  Now functions can be
-;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP
-;; property.
-
-(dolist (fn '(si::*unwind-protect* il:*env*
-	      evalhook xcl::nohook xcl::undohook
-	      xcl::execa0001 xcl::execa0001a0002
-	      xcl::|interpret-UNDOABLY|
-	      cl::|interpret-IF| cl::|interpret-FLET|
-	      cl::|interpret-LET| cl::|interpret-LETA0001|
-	      cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001|
-	      il:do-event il:eval-input
-	      apply t))
-  (setf (get fn 'xcl::uninterestingp) t))
-
-(defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg)
-  "Return TRUE iff the frame should be visible for a short backtrace."
-  (declare (special il:openfns))
-  (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos)))
-    (typecase xcl::name
-      (symbol (case xcl::name
-		(il:*env*
-		 ;; *ENV* is used by ENVEVAL etc.
-		 nil)
-		(il:errorset
-		 (or (<= (il:stknargs xcl::pos) 1)
-		     (not (eq (il:stkarg 2 xcl::pos nil)
-			      'il:internal))))
-		(il:eval
-		 (or (<= (il:stknargs xcl::pos) 1)
-		     (not (eq (il:stkarg 2 xcl::pos nil)
-			      'xcl::internal))))
-		(il:apply
-		 (or (<= (il:stknargs xcl::pos) 2)
-		     (not (il:stkarg 3 xcl::pos nil))))
-		(otherwise
-		 (cond ((get xcl::name 'xcl::uninterestingp)
-			;; Explicitly declared uninteresting.
-			nil)
-		       ((eq (il:chcon1 xcl::name) (char-code #\\))
-			;; Implicitly declared uninteresting by starting the
-			;; name with a "\".
-			nil)
-		       ((or (member xcl::name il:openfns :test #'eq)
-			    (eq xcl::name 'funcall))
-			;;The function won't be seen when compiled, so only show
-			;;it if INTERPFLG it true
-			xcl::interpflg)
-		       (t 
-			;; Interesting by default.
-			t)))))
-       (cons (case (car xcl::name)
-	       (:broken t)
-	       (otherwise nil)))
-       (otherwise nil))))
-
-(setq il:*short-backtrace-filter* 'xcl::interesting-frame-p)
-
-
-(eval-when (eval compile)
-  (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name))))
-
-
-;;  Change the frame inspector to open up lexical environments
-
-  ;; Since the DEFSTRUCT is going to build the accessors in the package that is
-  ;; current at read-time, and we want the accessors to reside in the IL
-  ;; package, we have got to make sure that the defstruct happens when the
-  ;; package is IL.
-
-(in-package "IL")
-
-(cl:defstruct (frame-prop-name (:type cl:list))
-  (label-fn 'nill)
-  (value-fn
-   (function
-    (lambda (prop-name framespec)
-     (frame-prop-name-data prop-name))))
-  (setf-fn 'nill)
-  (inspect-fn
-   (function
-    (lambda (value prop-name framespec window)
-     (default.inspectw.valuecommandfn value prop-name (car framespec) window))))
-  (data nil))
-
-(cl:in-package "CLOS")
-
-(defun il:debugger-stack-frame-prop-names (il:framespec) 
-  ;; Frame prop-names are structures of the form
-  ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA)
-  (let ((il:pos (car il:framespec))
-	(il:backtrace-item (cadr il:framespec)))
-    (il:if (eq 'eval (il:stkname il:pos))
-     il:then
-     (let ((il:expression (il:stkarg 1 il:pos))
-	   (il:environment (il:stkarg 2 il:pos)))
-       `(,(il:make-frame-prop-name :inspect-fn
-	   (il:function
-	    (il:lambda (il:value il:prop-name il:framespec il:window)
-	      (il:inspect/as/function il:value (car il:framespec) il:window)))
-	   :data il:expression)
-	 ,(il:make-frame-prop-name :data "ENVIRONMENT")
-	 ,@(il:for il:aspect il:in
-	    `((,(and il:environment (il:environment-vars il:environment))
-	       "vars")
-	      (,(and il:environment (il:environment-functions il:environment))
-	       "functions")
-	      (,(and il:environment (il:environment-blocks il:environment))
-	       "blocks")
-	      (,(and il:environment (il:environment-tagbodies il:environment))
-	       "tag bodies"))
-	    il:bind il:group-name il:p-list
-	    il:eachtime (il:setq il:group-name (cadr il:aspect))
-	                (il:setq il:p-list (car il:aspect))
-	    il:when (not (null il:p-list))
-	    il:join
-	    `(,(il:make-frame-prop-name :data il:group-name)
-	      ,@(il:for il:p il:on il:p-list il:by cddr il:collect
-		 (il:make-frame-prop-name :label-fn
-		  (il:function (il:lambda (il:prop-name il:framespec)
-				 (car (il:frame-prop-name-data il:prop-name))))
-		  :value-fn
-		  (il:function (il:lambda (il:prop-name il:framespec)
-				 (cadr (il:frame-prop-name-data il:prop-name))))
-		  :setf-fn
-		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
-				 (il:change (cadr (il:frame-prop-name-data
-						   il:prop-name))
-					    il:new-value)))
-		  :data il:p))))))
-     il:else
-     (flet ((il:build-name (&key il:arg-name il:arg-number)
-	      (il:make-frame-prop-name :label-fn
-		  (il:function (il:lambda (il:prop-name il:framespec)
-				 (car (il:frame-prop-name-data il:prop-name))))
-		  :value-fn
-		  (il:function (il:lambda (il:prop-name il:framespec)
-				 (il:stkarg (cadr (il:frame-prop-name-data
-						   il:prop-name))
-					    (car il:framespec))))
-		  :setf-fn
-		  (il:function (il:lambda (il:prop-name il:framespec il:new-value)
-				 (il:setstkarg (cadr (il:frame-prop-name-data
-						      il:prop-name))
-					       (car il:framespec)
-					       il:new-value)))
-		  :data
-		  (list il:arg-name il:arg-number))))
-       (let ((il:nargs (il:stknargs il:pos t))
-	     (il:nargs1 (il:stknargs il:pos))
-	     (il:fnname (il:stkname il:pos))
-	     il:argname
-	     (il:arglist))
-	 (and (il:litatom il:fnname)
-	      (il:ccodep il:fnname)
-	      (il:setq il:arglist (il:listp (il:smartarglist il:fnname))))
-	 `(,(il:make-frame-prop-name :inspect-fn
-	     (il:function (il:lambda (il:value il:prop-name il:framespec
-					       il:window)
-			    (il:inspect/as/function il:value
-						    (car il:framespec)
-						    il:window)))
-	     :data
-	     (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item))
-	   ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect
-	      (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist))
-					 lambda-list-keywords)
-			       il:do
-			       (il:setq il:mode il:argname))
-		     (il:build-name :arg-name
-				    (or (il:stkargname il:i il:pos)
-					; special
-					(if (case il:mode
-					      ((nil &optional) il:argname)
-					      (t nil))
-					    (string il:argname)
-					    (il:concat "arg " (- il:i 1))))
-				    :arg-number il:i)))
-	   ,@(let* ((il:novalue "No value")
-		    (il:slots (il:for il:pvar il:from 0 il:as il:i il:from
-				      (il:add1 il:nargs1)
-				      il:to il:nargs il:by 1 il:when
-				      (and (il:neq il:novalue (il:stkarg il:i il:pos
-									 il:novalue))
-					   (or (il:setq il:argname (il:stkargname
-								    il:i il:pos))
-					       (il:setq il:argname (il:concat 
-								    "local " 
-								    il:pvar)))
-					   )
-				      il:collect
-				      (il:build-name :arg-name il:argname 
-						     :arg-number il:i))))
-               (and il:slots (cons (il:make-frame-prop-name :data "locals")
-                                   il:slots)))))))))
-
-(defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name)
-  (il:apply* (il:frame-prop-name-value-fn il:prop-name)
-	     il:prop-name il:framespec))
-
-(defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue)
-  (il:apply* (il:frame-prop-name-setf-fn il:prop-name)
-	     il:prop-name il:framespec il:newvalue))
-
-(defun il:debugger-stack-frame-value-command (il:datum il:prop-name 
-						       il:framespec il:window)
-  (il:apply* (il:frame-prop-name-inspect-fn il:prop-name)
-	     il:datum il:prop-name il:framespec il:window))
-
-(defun il:debugger-stack-frame-title (il:framespec &optional il:window)
-  (declare (ignore il:window))
-  (il:concat (il:stkname (car il:framespec)) "  Frame"))
-
-(defun il:debugger-stack-frame-property (il:prop-name il:framespec)
-  (il:apply* (il:frame-prop-name-label-fn il:prop-name)
-	     il:prop-name il:framespec))
-
-;; Teaching the debugger that there are other file-manager types that can
-;; appear on the stack
-
-(defvar xcl::*function-types* '(il:fns il:functions)
-  "Manager types that can appear on the stack")
-
-;; Redefine a couple of system functions to use the above stuff
-
-#+Xerox-Lyric
-(progn
-
-(defun il:attach-backtrace-menu (&optional (il:ttywindow
-					    (il:wfromds (il:ttydisplaystream)))
-					   il:skip)
-  (let ((il:bkmenu (il:|create| il:menu
-		       il:items il:_
-		       (il:collect-backtrace-items il:ttywindow il:skip)
-		       il:whenselectedfn il:_
-		       (il:function il:backtrace-item-selected)
-		       il:whenheldfn il:_
-		       #'(il:lambda (il:item il:menu il:button)
-			   (declare (ignore il:item il:menu))
-			   (case il:button
-			     (il:left (il:promptprint 
-				       "Open a frame inspector on this stack frame"
-				       ))
-			     (il:middle (il:promptprint 
-					 "Inspect/Edit this function"))
-			     ))
-		       il:menuoutlinesize il:_ 0
-		       il:menufont il:_ il:backtracefont
-		       il:menucolumns il:_ 1))
-	(il:ttyregion (il:windowprop il:ttywindow 'il:region))
-	il:btw)
-    (cond
-      ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow)
-			   il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu))
-					  (eql (il:|fetch| (il:menu il:whenselectedfn)
-						   il:|of| (car il:btw))
-					       (il:function il:backtrace-item-selected)))
-			   il:|do|                       
-			   (return il:atw)))       
-       (il:deletemenu (car (il:windowprop il:btw 'il:menu))
-		      nil il:btw)
-       (il:windowprop il:btw 'il:extent nil)
-       (il:clearw il:btw))
-      ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region)
-						      (il:widthifwindow (il:imin (il:|fetch| (il:menu 
-											      il:imagewidth
-											      )
-										     il:|of| il:bkmenu)
-										 il:|MaxBkMenuWidth|))
-						      (il:|fetch| (il:region il:height) il:|of| il:ttyregion
-							  )
-						      'il:left)))   
-       (il:attachwindow il:btw il:ttywindow (cond
-					      ((il:igreaterp (il:|fetch| (il:region il:left)
-								 il:|of| (il:windowprop
-									  il:btw
-									  'il:region))
-							     (il:|fetch| (il:region il:left)
-								 il:|of| il:ttyregion))
-					       'il:right)
-					      (t 'il:left))
-			nil
-			'il:localclose)
-       (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process))
-
-       ))
-    (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position
-				     il:xcoord il:_ 0
-				     il:ycoord il:_ (il:idifference (il:windowprop
-								     il:btw
-								     'il:height)
-								    (il:|fetch| (il:menu il:imageheight
-											 ) il:|of| 
-											   il:bkmenu
-											   ))))))
-
-(defun il:backtrace-item-selected (il:item il:menu il:button)
-  (il:resetlst
-   (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow
-		     (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item)
-
-				    ))
-      (cond
-	((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu))
-	 (il:menudeselect il:olditem il:menu)        
-	 ))
-      (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu)
-					   'il:mainwindow))
-      (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position))
-      (il:setq il:pos (il:stknth (- il:framespecn)
-				 il:bkpos))
-      (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos)))
-	(and il:lp (il:stknth 0 il:pos il:lp)))
-      (il:menuselect il:item il:menu)                
-      (if (eq il:button 'il:middle)
-	  (progn 
-
-
-	    (il:resetsave nil (list 'il:relstk il:pos))
-	    (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name)
-					il:|of| il:item)
-				    il:pos il:ttywindow))
-	  (progn 
-
-
-	    (il:setq il:framewindow
-		     (xcl:with-profile (il:process.eval
-						  (il:windowprop il:ttywindow 'il:process)
-						  '(let ((il:profile (xcl:copy-profile (xcl:find-profile
-											"READ-PRINT"))))
-						    (setf (xcl::profile-entry-value '
-							   xcl:*eval-function* il:profile)
-						     xcl:*eval-function*)
-						    (xcl:save-profile il:profile))
-						  t)
-		       (il:inspectw.create (list il:pos il:item)
-				   'il:debugger-stack-frame-prop-names
-				   'il:debugger-stack-frame-fetchfn
-				   'il:debugger-stack-frame-storefn nil '
-				   il:debugger-stack-frame-value-command nil '
-				   il:debugger-stack-frame-title nil (
-								      il:make-frame-inspect-window
-								      il:ttywindow)
-				   'il:debugger-stack-frame-property)))
-	    (cond
-	      ((not (il:windowprop il:framewindow 'il:mainwindow))
-	       (il:attachwindow il:framewindow il:ttywindow
-				(cond
-				  ((il:igreaterp (il:|fetch| (il:region il:bottom)
-						     il:|of| (il:windowprop il:framewindow
-									    'il:region))
-						 (il:|fetch| (il:region il:bottom)
-						     il:|of| (il:windowprop il:ttywindow 'il:region)))
-				   'il:top)
-				  (t 'il:bottom))
-				nil
-				'il:localclose)
-	       (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow
-									 ))))))
-      (return))))
-
-(defun il:collect-backtrace-items (xcl::tty-window xcl::skip)
-   (let* ((xcl::items (cons nil nil))
-          (xcl::items-tail xcl::items))
-         (macrolet ((xcl::collect-item (xcl::new-item)
-                           `(progn (setf (rest xcl::items-tail)
-                                         (cons ,xcl::new-item nil))
-                                   (pop xcl::items-tail))))
-                (let* ((xcl::filter-fn (cond
-                                          ((null xcl::skip)
-                                           #'xcl:true)
-                                          ((eq xcl::skip t)
-                                           il:*short-backtrace-filter*)
-                                          (t xcl::skip)))
-                       (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window '
-                                                           il:stack-position)))
-                       (xcl::next-frame xcl::top-frame)
-                       (xcl::frame-number 0)
-                       xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label)
-                      (loop (when (null xcl::next-frame)
-                                  (return))
-                            (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed 
-                                                        xcl::use-frame xcl::label)
-                                   (funcall xcl::filter-fn xcl::next-frame))
-                            (when (null xcl::last-frame-consumed)
-                                                            
-                                (setf xcl::last-frame-consumed xcl::next-frame))
-                            (when xcl::interesting-p        
-                                (when (null xcl::use-frame)
-                                      (setf xcl::use-frame xcl::last-frame-consumed))
-                                                             
-                                (when (null xcl::label)
-                                    (setf xcl::label (il:stkname xcl::use-frame))
-                                    (if (member xcl::label '(eval il:eval il:apply apply)
-                                               :test
-                                               'eq)
-                                        (setf xcl::label (il:stkarg 1 xcl::use-frame))))
-                                                            
-                                (loop (cond
-                                         ((not (typep xcl::next-frame 'il:stackp))
-                                          (error "~%Use-frame ~S not found" xcl::use-frame))
-                                         ((xcl::stack-eql xcl::next-frame xcl::use-frame)
-                                          (return))
-                                         (t (incf xcl::frame-number)
-                                            (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
-                                                                         xcl::next-frame)))))
-                                                             
-                                (xcl::collect-item (il:|create| il:bkmenuitem
-                                                          il:label il:_ (let ((*print-level* 2)
-                                                                              (*print-length* 3)
-                                                                              (*print-escape* t)
-                                                                              (*print-gensym* t)
-                                                                              (*print-pretty* nil)
-                                                                              (*print-circle* nil)
-                                                                              (*print-radix* 10)
-                                                                              (*print-array* nil)
-                                                                              (il:*print-structure*
-                                                                               nil))
-                                                                             (prin1-to-string 
-                                                                                    xcl::label))
-                                                          il:bkmenuinfo il:_ xcl::frame-number
-                                                          il:frame-name il:_ xcl::label)))
-                                                             
-                            (loop (cond
-                                     ((not (typep xcl::next-frame 'il:stackp))
-                                      (error "~%Last-frame-consumed ~S not found" 
-                                             xcl::last-frame-consumed))
-                                     ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed
-                                                    )
-                                          (incf xcl::frame-number)
-                                          (setf xcl::next-frame (il:stknth -1 xcl::next-frame 
-                                                             
-                                                                       xcl::next-frame)))
-                                      (return)))))))
-         (rest xcl::items)))
-
-)
-#+Xerox-Medley
-(progn
-
-(defun dbg::attach-backtrace-menu (&optional tty-window skip)
-  (declare (special il:\\term.ofd il:backtracefont))
-  (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream))))
-  (prog (btw bkmenu
-	     (tty-region (il:windowprop tty-window 'il:region))
-	     ;; And, for the FORMAT below...
-	     (*print-level* 2)
-	     (*print-length* 3)
-	     (*print-escape* t)
-	     (*print-gensym* t)
-	     (*print-pretty* nil)
-	     (*print-circle* nil)
-	     (*print-radix* 10)
-	     (*print-array* nil)
-	     (il:*print-structure* nil))
-     (setq bkmenu
-	   (il:|create| il:menu
-	       il:items il:_ (dbg::collect-backtrace-items tty-window skip)
-	       il:whenselectedfn il:_ 'dbg::backtrace-item-selected
-	       il:menuoutlinesize il:_ 0
-	       il:menufont il:_ il:backtracefont 
-	       il:menucolumns il:_ 1
-	       il:whenheldfn il:_
-	       #'(il:lambda (item menu button)
-		   (declare (ignore item menu))
-		   (case button
-		     (il:left
-		      (il:promptprint
-		       "Open a frame inspector on this stack frame"))
-		     (il:middle
-		      (il:promptprint "Inspect/Edit this function"))))))
-     (cond ((setq btw
-		  (dolist (atw  (il:attachedwindows tty-window))
-		    ;; Test for an attached window that has a backtrace menu in
-		    ;; it.
-		    (when (and (setq btw (il:windowprop atw 'il:menu))
-			   (eq (il:|fetch| (il:menu il:whenselectedfn)
-				   il:|of| (car btw))
-			       'dbg::backtrace-item-selected))
-		      (return atw))))
-	    ;; If there is alread a backtrace window, delete the old menu from
-	    ;; it.
-	    (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw)
-	    (il:windowprop btw 'il:extent nil)
-	    (il:clearw btw))
-	   ((setq btw
-		  (il:createw (dbg::region-next-to
-			       (il:windowprop tty-window 'il:region)
-			       (il:widthifwindow
-				(il:imin (il:|fetch| (il:menu il:imagewidth)
-					     il:|of| bkmenu)
-					 il:|MaxBkMenuWidth|))
-			       (il:|fetch| (il:region il:height)
-				   il:|of| tty-region)
-			       :left)))
-					; put bt window at left of TTY
-					; window unless ttywindow is
-					; near left edge.
-	    (il:attachwindow btw tty-window
-			     (if (il:igreaterp (il:|fetch| (il:region il:left)
-						   il:|of|
-						   (il:windowprop btw
-								  'il:region))
-					       (il:|fetch| (il:region il:left)
-						   il:|of| tty-region))
-				 'il:right
-				 'il:left)
-			     nil
-			     'il:localclose)
-	    ;; So that button clicks will switch the TTY
-	    (il:windowprop btw 'il:process
-			   (il:windowprop tty-window 'il:process))))
-     (il:addmenu bkmenu btw (il:|create| il:position
-				il:xcoord il:_ 0 
-				il:ycoord il:_ (- (il:windowprop btw 'il:height)
-						  (il:|fetch| (il:menu 
-							       il:imageheight)
-						      il:|of| bkmenu))))
-     ;; IL:ADDMENU sets up buttoneventfn for window that we don't
-     ;; want.  We want to catch middle button events before the menu
-     ;; handler, so that we can pop up edit/inspect menu for the frame
-     ;; currently selected.  So replace the buttoneventfn, and can
-     ;; nuke the cursorin and cursormoved guys, cause don't need them.
-     (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn)
-     (il:windowprop btw 'il:cursorinfn nil)
-     (il:windowprop btw 'il:cursormovedfn nil)))
-
-(defun dbg::collect-backtrace-items (tty-window skip)
-  (xcl:with-collection
-      ;;
-      ;; There are a number of possibilities for the values returned by the
-      ;; filter-fn.
-      ;;
-      ;; (1) INTERESTING-P is false, and the other values are all NIL.  This
-      ;; is the simple case where the stack frame NEXT-POS should be ignored
-      ;; completly, and processing should continue with the next frame.
-      ;;
-      ;; (2) INTERESTING-P is true, and the other values are all NIL.  This
-      ;; is the simple case where the stack frame NEXT-POS should appear in
-      ;; the backtrace as is, and processing should continue with the next
-      ;; frame.
-      ;;
-      ;; [Note that these two cases take care of old values of the
-      ;; filter-fn.]
-      ;;
-      ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack
-      ;; frame.  In that case, ignore all stack frames from NEXT-POS to
-      ;; LAST-FRAME-CONSUMED, inclusive.
-      ;;
-      ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack
-      ;; frame.  In this case, the backtrace should include a single entry
-      ;; coresponding to the frame USE-FRAME (which defaults to
-      ;; LAST-FRAME-CONSUMED), and processing should continue with the next
-      ;; frame after LAST-FRAME-CONSUMED.  If LABEL is non-NIL, it will be
-      ;; the label that appears in the backtrace menu; otherwise the name of
-      ;; USE-FRAME will be used (or the form being EVALed if the frame is an
-      ;; EVAL frame).
-      ;;
-      (let* ((filter (cond ((null skip) #'xcl:true)
-			   ((eq skip t) il:*short-backtrace-filter*)
-			   (t skip)))
-	     (top-frame (il:stknth 0 (il:getwindowprop tty-window
-					      'dbg::stack-position)))
-	     (next-frame top-frame)
-	     (frame-number 0)
-	     interestingp last-frame-consumed frame-to-use label-to-use)
-	(loop (when (null next-frame) (return))
-	      ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED,
-	      ;; FRAME-TO-USE, and LABEL-TO-USE
-	      (multiple-value-setq (interestingp last-frame-consumed 
-						 frame-to-use label-to-use)
-		(funcall filter next-frame))
-	      (when (null last-frame-consumed)
-		(setf last-frame-consumed next-frame))
-	      (when interestingp
-		(when (null frame-to-use)
-		  (setf frame-to-use last-frame-consumed))
-		(when (null label-to-use)
-		  (setf label-to-use (il:stkname frame-to-use))
-		  (if (member label-to-use '(eval il:eval il:apply apply)
-			      :test 'eq)
-		      (setf label-to-use (il:stkarg 1 frame-to-use))))
-
-		;; Walk the stack until we find the frame to use
-		(loop (cond ((not (typep next-frame 'il:stackp))
-			     (error "~%Use-frame ~S not found" frame-to-use))
-			    ((xcl::stack-eql next-frame frame-to-use)
-			     (return))
-			    (t (incf frame-number)
-			       (setf next-frame
-				     (il:stknth -1 next-frame next-frame)))))
-
-		;; Add the menu item to the list under construction
-		(xcl:collect (il:|create| il:bkmenuitem
-				 il:label il:_ (let ((*print-level* 2)
-						     (*print-length* 3)
-						     (*print-escape* t)
-						     (*print-gensym* t)
-						     (*print-pretty* nil)
-						     (*print-circle* nil)
-						     (*print-radix* 10)
-						     (*print-array* nil)
-						     (il:*print-structure* nil))
-						 (prin1-to-string label-to-use))
-				 il:bkmenuinfo il:_ frame-number
-				 il:frame-name il:_ label-to-use)))
-
-	      ;; Update NEXT-POS
-	      (loop (cond ((not (typep next-frame 'il:stackp))
-			   (error "~%Last-frame-consumed ~S not found" 
-				  last-frame-consumed))
-			  ((prog1
-			       (xcl::stack-eql next-frame last-frame-consumed)
-			     (incf frame-number)
-			     (setf next-frame (il:stknth -1 next-frame
-							 next-frame)))
-			   (return))))))))
-
-(defun dbg::backtrace-menu-buttoneventfn (window &aux menu)
-  (setq menu (car (il:listp (il:windowprop window 'il:menu))))
-  (unless (or (il:lastmousestate il:up) (null menu))
-    (il:totopw window)
-    (cond ((il:lastmousestate il:middle)
-	   ;; look for a selected frame in this menu, and then pop up
-	   ;; the editor invoke menu for that frame.  don't change the
-	   ;; selection, just present the edit menu.
-	   (let* ((selection (il:menu.handler menu
-					  (il:windowprop window 'il:dsp)))
-		  (tty-window (il:windowprop window 'il:mainwindow))
-		  (last-pos (il:windowprop tty-window 'dbg::lastpos)))
-                        
-	     ;; don't have to worry about releasing POS because we
-	     ;; only look at it here (nobody here hangs on to it)
-	     ;; and we will be around for less time than LASTPOS. 
-	     ;; The debugger is responsible for releasing LASTPOS.
-	     (il:inspect/as/function (cond
-				       ((and selection
-					     (il:|fetch| (il:bkmenuitem il:frame-name)
-						 il:|of| (car selection))))
-				       ((and (symbolp (il:stkname last-pos))
-					     (il:getd (il:stkname last-pos)))
-					(il:stkname last-pos))
-				       (t 'il:nill))
-				     last-pos tty-window)))
-	  (t (let ((selection (il:menu.handler menu
-					   (il:windowprop window 'il:dsp))))
-	       (when selection
-		 (il:doselecteditem menu (car selection) (cdr selection))))))))
-
-;; This function isn't really redefined, but it needs to be recomiled since we
-;; changed the def'n of the BKMENUITEM record.
-
-(defun dbg::backtrace-item-selected (item menu button)
-  ;;When a frame name is selected in the backtrace menu, this is the function
-  ;;that gets called.
-  (declare (special il:brkenv) (ignore button))
-  (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item))
-	 (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow))
-	 (bkpos (il:windowprop tty-window 'dbg::stack-position))
-	 (pos (il:stknth (- frame-spec) bkpos)))
-    (let ((lp (il:windowprop tty-window 'dbg::lastpos)))
-      (and lp (il:stknth 0 pos lp)))
-    ;; change the item selected from OLDITEM to ITEM.  Only do this on left
-    ;; buttons now.  Middle just pops up the edit menu, doesn't select. -woz
-    (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu)))
-      (when old-item (il:menudeselect old-item menu))
-      (il:menuselect item menu))
-    ;; Change the lexical environment so it is the one in effect as of this
-    ;; frame.
-    (il:process.eval (il:windowprop tty-window (quote dbg::process))
-	       `(setq il:brkenv ',(il:find-lexical-environment pos))
-	       t)
-    (let ((frame-window (xcl:with-profile
-			    (il:process.eval (il:windowprop tty-window
-							    'il:process)
-				       `(let ((profile (xcl:copy-profile
-							(xcl:find-profile
-							 "READ-PRINT"))))
-					 (setf
-					  (xcl::profile-entry-value
-					   'xcl:*eval-function* profile)
-					  xcl:*eval-function*)
-					 (xcl:save-profile profile))
-				       t)
-			  (il:inspectw.create pos
-				      #'(lambda (pos)
-					  (dbg::stack-frame-properties pos t))
-				      'dbg::stack-frame-fetchfn
-				      'dbg::stack-frame-storefn
-				      nil
-				      'dbg::stack-frame-value-command
-				      nil
-				      (format nil "~S  Frame" (il:stkname pos))
-				      nil (dbg::make-frame-inspect-window
-					   tty-window)
-				      'dbg::stack-frame-property))))
-      (when (not (il:windowprop frame-window 'il:mainwindow))
-	(il:attachwindow frame-window tty-window
-			 (if (> (il:|fetch| (il:region il:bottom) il:|of|
-				    (il:windowprop frame-window 'il:region))
-				(il:|fetch| (il:region il:bottom) il:|of|
-				    (il:windowprop tty-window 'il:region)))
-			     'il:top 'il:bottom)
-			 nil 'il:localclose)
-	(il:windowaddprop frame-window 'il:closefn 'il:detachwindow)))))
-
-)					;end of Xerox-Medley
-
-(defun il:select.fns.editor (&optional function)
-    ;; gives the user a menu choice of editors.
-    (il:menu (il:|create| il:menu
-		 il:items il:_ (cond ((il:ccodep function)
-				      '((il:|InspectCode| 'il:inspectcode 
-					 "Shows the compiled code.")
-					(il:|DisplayEdit| 'ed 
-					 "Edit it with the display editor")
-					(il:|TtyEdit| 'il:ef 
-					 "Edit it with the standard editor")))
-				     ((il:closure-p function)
-				      '((il:|Inspect| 'inspect 
-					 "Inspect this object")))
-				     (t '((il:|DisplayEdit| 'ed 
-					   "Edit it with the display editor")
-					  (il:|TtyEdit| 'il:ef 
-					   "Edit it with the standard editor"))))
-		 il:centerflg il:_ t)))
-
-;; 
-
-
-;; CLOS specific extensions to the debugger
-
-
-;; There are some new things that act as functions, and that we want to be
-;; able to edit from a backtrace window
-
-(pushnew 'methods xcl::*function-types*)
-
-(eval-when (eval compile load)
-  (unless (generic-function-p (symbol-function 'il:inspect/as/function))
-    (make-specializable 'il:inspect/as/function)))
-
-(defmethod il:inspect/as/function (name stack-pointer debugger-window)
-  ;; Calls an editor on function NAME.  STKP and WINDOW are the stack pointer
-  ;; and window of the break in which this inspect command was called.
-  (declare (ignore debugger-window))
-  (let ((editor (il:select.fns.editor name)))
-    (case editor
-      ((nil) 
-       ;; No editor chosen, so don't do anything
-       nil)
-      (il:inspectcode 
-       ;; Inspect the compiled code
-       (let ((frame (xcl::stack-pointer-frame stack-pointer)))
-	 (if (and (il:stackp stack-pointer)
-		  (xcl::stack-frame-valid-p frame))
-	     (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame)))
-			       (cond ((eq (il:\\get-compiled-code-base name)
-					  code-base)
-				      name)
-				     (t 
-				      ;; Function executing in this frame is not
-				      ;; the one in the definition cell of its
-				      ;; name, so fetch the real code.  Have to
-				      ;; pass a CCODEP
-				      (il:make-compiled-closure code-base))))
-                             nil nil nil (xcl::stack-frame-pc frame))
-	     (il:inspectcode name))))
-      (ed 
-       ;; Use the standard editor.
-       ;; This used to take care to apply the editor in the debugger
-       ;; process, so forms evaluated in the editor happen in the
-       ;; context of the break.  But that doesn't count for much any
-       ;; more, now that lexical variables are the way to go.  Better to
-       ;; use the LEX debugger command (thank you, Herbie) and
-       ;; shift-select pieces of code from the editor into the debugger
-       ;; window. 
-       (ed name `(,@xcl::*function-types* :display)))
-      (otherwise (funcall editor name)))))
-
-(defmethod il:inspect/as/function ((name standard-object) stkp window)
-  (when (il:menu (il:|create| il:menu
-		     il:items il:_ '(("Inspect" t "Inspect this object"))))
-    (inspect name)))
-
-(defmethod il:inspect/as/function ((x standard-method) stkp window)
-  (let* ((generic-function-name (slot-value (slot-value x 'generic-function)
-					    'name))
-	 (method-name (full-method-name x))
-	 (editor (il:select.fns.editor method-name)))
-    (il:allow.button.events)
-    (case editor
-      (ed (ed method-name '(:display methods)))
-      (il:inspectcode (il:inspectcode (slot-value x 'function)))
-      ((nil) nil)
-      (otherwise (funcall editor method-name)))))
-
-;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods
-;; and generic-functions on the stack.
-
-(defun interesting-frame-p (stack-pos &optional interp-flag)
-  ;; Return up to four values:  INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and
-  ;; LABEL.  See the function IL:COLLECT-BACKTRACE-ITEMS for a full description
-  ;; of how these values are used.
-  (labels
-      ((function-matches-frame-p (function frame)
-	   "Is the function being called in this frame?"
-	   (let* ((frame-name (il:stkname frame))
-		  (code-being-run (cond
-				    ((typep frame-name 'il:closure)
-				     frame-name)
-				    ((and (consp frame-name)
-					  (eq 'il:\\interpreter
-					      (xcl::stack-frame-name
-					       (il:\\stackargptr frame))))
-				     frame-name)
-				    (t (xcl::stack-frame-fn-header
-					(il:\\stackargptr frame))))))
-	     (or (eq function code-being-run)
-		 (and (typep function 'il:compiled-closure)
-		      (eq (xcl::compiled-closure-fnheader function)
-			  code-being-run)))))
-       (generic-function-from-frame (frame)
-	 "If this the frame of a generic function return the gf, otherwise
-          return NIL."
-	 ;; Generic functions are implemented as compiled closures.  On the
-	 ;; stack, we only see the fnheader for the the closure.  This could
-	 ;; be a discriminator code, or in the default method only case it
-	 ;; will be the actual method function.  To tell if this is a generic
-	 ;; function frame, we have to check very carefully to see if the
-	 ;; right stuff is on the stack.  Specifically, the closure's ccode,
-	 ;; and the first local variable has to be a ptrhunk big enough to be
-	 ;; a FIN environment, and fin-env-fin of that ptrhunk has to point
-	 ;; to a generic function whose ccode and environment match. 
-	 (let ((n-args (il:stknargs frame))
-	       (env nil)
-	       (gf nil))
-	   (if (and ;; is there at least one local?
-		(> (il:stknargs frame t) n-args)
-		;; and does the local contain something that might be
-		;; the closure environment of a funcallable instance?
-		(setf env (il:stkarg (1+ n-args) frame))
-		;; and does the local contain something that might be
-		;; the closure environment of a funcallable instance?
-		(typep env *fin-env-type*)
-		(setf gf (fin-env-fin env))
-		;; whose fin-env-fin points to a generic function?
-		(generic-function-p gf)
-		;; whose environment is the same as env?
-		(eq (xcl::compiled-closure-env gf) env)
-		;; and whose code is the same as the code for this
-		;; frame? 
-		(function-matches-frame-p gf frame))
-	       gf
-	       nil))))
-    (let ((frame-name (il:stkname stack-pos)))
-      ;; See if there is a generic-function on the stack at this
-      ;; location.
-      (let ((gf (generic-function-from-frame stack-pos)))
-	(when gf
-	  (return-from interesting-frame-p (values t stack-pos stack-pos gf))))
-      ;; See if this is an interpreted method.  The method body is
-      ;; wrapped in a (BLOCK <function-name> ...).  We look for an
-      ;; interpreted call to BLOCK whose block-name is the name of
-      ;; generic-function.
-      (when (and (eq frame-name 'eval)
-		 (consp (il:stkarg 1 stack-pos))
-		 (eq (first (il:stkarg 1 stack-pos)) 'block)
-		 (symbolp (second (il:stkarg 1 stack-pos)))
-		 (fboundp (second (il:stkarg 1 stack-pos)))
-		 (generic-function-p
-		     (symbol-function (second (il:stkarg 1 stack-pos)))))
-	(let* ((form (il:stkarg 1 stack-pos))
-	       (block-name (second form))
-	       (generic-function (symbol-function block-name))
-	       (methods (generic-function-methods (symbol-function block-name))))
-	  ;; If this is really a method being called from a
-	  ;; generic-function, the g-f should be no more than a
-	  ;; few(?) frames up the stack.  Check for the method call
-	  ;; by looking for a call to APPLY, where the function
-	  ;; being applied is the code in one of the methods.
-	  (do ((i 100 (1- i))
-	       (previous-pos stack-pos current-pos)
-	       (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos))
-	       (found-method nil)
-	       (method-pos))
-	      ((or (null current-pos) (<= i 0)) nil)
-	    (cond ((equalp generic-function
-			   (generic-function-from-frame current-pos))
-		   (if found-method
-		       (return-from interesting-frame-p
-			 (values t previous-pos method-pos found-method))
-		       (return)))
-		  (found-method nil)
-		  ((eq (il:stkname current-pos) 'apply)
-		   (dolist (method methods)
-		     (when (eq (method-function method)
-			       (il:stkarg 1 current-pos))
-		       (setq method-pos current-pos)
-		       (setq found-method method)
-		       (return))))))))
-      ;; Try to handle compiled methods
-      (when (and (symbolp frame-name)
-		 (not (fboundp frame-name))
-		 (eq (il:chcon1 frame-name)
-		     (il:charcode il:\())
-		 (or (string-equal "(method " (symbol-name frame-name)
-			      :start2 0 :end2 13)
-		     (string-equal "(method " (symbol-name frame-name)
-			      :start2 0 :end2 12)
-		     (string-equal "(method " (symbol-name frame-name)
-			      :start2 0 :end2 8)))
-	;; Looks like a name that CLOS consed up.  See if there is a
-	;; GF nearby up the stack.  If there is, use it to help
-	;; determine which method we have.
-	(do ((i 30 (1- i))
-	     (current-pos (il:stknth -1 stack-pos)
-			  (il:stknth -1 current-pos))
-	     (gf))
-	    ((or (null current-pos)
-		 (<= i 0))
-	     nil)
-	  (setq gf (generic-function-from-frame current-pos))
-	  (when gf
-	    (dolist (method (generic-function-methods gf))
-	      (when (function-matches-frame-p (method-function method)
-					      stack-pos)
-		(return-from interesting-frame-p
-		  (values t stack-pos stack-pos method))))
-	    (return))))
-      ;; If we haven't already returned, use the default method.
-      (xcl::interesting-frame-p stack-pos interp-flag))))
-
-
-(setq il:*short-backtrace-filter* 'interesting-frame-p)
-
-;;; Support for undo
-
- (defun undoable-setf-slot-value (object slot-name new-value)
-    (if (slot-boundp object slot-name)
-      (il:undosave (list 'undoable-setf-slot-value
-                         object slot-name (slot-value object slot-name)))
-      (il:undosave (list 'slot-makunbound object slot-name)))
-    (setf (slot-value object slot-name) new-value))
-
-  (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value)
-
-
-;;; Support for ?= and friends
-
-;; The arglists for generic-functions are built using gensyms, and don't reflect
-;; any keywords (they are all included in an &REST arg).  Rather then use the
-;; arglist in the code, we use the one that CLOS kindly keeps in the generic-function.
-
-(xcl:advise-function 'il:smartarglist
-  '(if (and il:explainflg
-	(symbolp il:fn)
-	(fboundp il:fn)
-	(generic-function-p (symbol-function il:fn)))
-    (generic-function-pretty-arglist (symbol-function il:fn))
-    (xcl:inner))
-  :when :around :priority :last)
-
-(setf (get 'defclass 'il:argnames)
-      '(nil (class-name (#\{ superclass-name #\} #\*)
-	     (#\{ slot-specifier #\} #\*)
-	     #\{ slot-option #\} #\*)))
-
-(setf (get 'defmethod 'il:argnames)
-      '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\*
-	     specialized-lambda-list #\{ declaration #\| doc-string #\} #\*
-	     #\{ form #\} #\*)))
-
-;;; Prettyprinting support, the result of Harley Davis.
-
-;; Support the standard Prettyprinter.  This is really minimal right now.  If
-;; anybody wants to fix this, I'd be happy to include their code.  In fact,
-;; there is almost no support for Commonlisp in the standard Prettyprinter, so
-;; the field is wide open to hackers with time on their hands.
-
-
-(setf (get 'defmethod :definition-print-template) ;Not quite right, since it
-      '(:name :arglist :body))		          ; doesn't handle qualifiers,
-		          		          ; but it will have to do.
-
-(defun defclass-prettyprint (form)
-  (let ((left (il:dspxposition))
-	(char-width (il:charwidth (il:charcode x) *standard-output*)))
-    (xcl:destructuring-bind (defclass name supers slots . options) form
-      (princ "(")
-      (prin1 defclass)
-      (princ " ")
-      (prin1 name)
-      (princ " ")
-      (if (null supers)
-	  (princ "()")			;Print "()" instead of "nil"
-	  (il:sequential.prettyprint (list supers) (il:dspxposition)))
-      (if (null slots)
-	  (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*)
-		 (princ "()"))
-	  (il:sequential.prettyprint (list slots) (+ left (* 4 char-width))))
-      (when options
-	(il:sequential.prettyprint options (+ left (* 2 char-width))))
-      (princ ")")
-      nil)))
-
-(let ((pprint-macro (assoc 'defclass il:prettyprintmacros)))
-  (if (null pprint-macro)
-      (push (cons 'defclass 'defclass-prettyprint)
-	    il:prettyprintmacros)
-      (setf (cdr pprint-macro) 'defclass-prettyprint)))
-
-(defun binder-prettyprint (form)
-  ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS
-  ;; that are of the form (fn (var ...) form &rest body).
-  ;; This code is far from correct, but it's better than nothing.
-  (if (and (consp form)
-	   (not (null (cdddr form))))
-      ;; I have no idea what I'm doing here.  Seems I can copy and edit somebody
-      ;; elses code without understanding it.
-      (let ((body-indent (+ (il:dspxposition)
-			    (* 2 (il:charwidth (il:charcode x)
-					       *standard-output*))))
-	    (form-indent (+ (il:dspxposition)
-			    (* 4 (il:charwidth (il:charcode x)
-					       *standard-output*)))))
-	(princ "(")
-	(prin1 (first form))
-	(princ " ")
-	(il:superprint (second form) form nil *standard-output*)
-	(il:sequential.prettyprint (list (third form)) form-indent)
-	(il:sequential.prettyprint (cdddr form) body-indent)
-	(princ ")")
-	nil)				;Return NIL to indicate that we did
-					; the printing
-      t))				;Return true to use default printing
-
-
-(dolist (fn '(multiple-value-bind with-accessors with-slots))
-  (let ((pprint-macro (assoc fn 'il:prettyprintmacros)))
-    (if (null pprint-macro)
-	(push (cons fn 'binder-prettyprint)
-	      il:prettyprintmacros)
-	(setf (cdr pprint-macro) 'binder-prettyprint))))
-
-
-
-;; SEdit has its own prettyprinter, so we need to support that too.  This is due
-;; to Harley Davis.  Really.
-
-(push (cons :slot-spec
-	    '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
-		break sedit::from-indent . 0)
-	       (sedit::set-indent . 1)
-	       (sedit::next-inline? 1 break sedit::from-indent . 1)
-	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
-		break sedit::from-indent . 0))
-	      ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
-		break sedit::from-indent . 0)
-	       (sedit::set-indent . 1)
-	       (sedit::next-inline? 1 break sedit::from-indent . 1)
-	       (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
-		break sedit::from-indent . 0))))
-    sedit:*indent-alist*)
-
-(setf (sedit:get-format :slot-spec)
-      '(:indent :slot-spec :inline t))
-
-(setf (sedit:get-format :slot-spec-list)
-      '(:indent :binding-list :args (:slot-spec) :inline nil))
-
-(setf (sedit:get-format 'defclass)
-      '(:indent ((2) 1)
-	:args (:keyword nil nil :slot-spec-list nil)
-	:sublists (4)))
-
-(setf (sedit:get-format 'defmethod)
-      '(:indent ((2))
-	:args (:keyword nil :lambda-list nil)
-	:sublists (3)))
-
-(setf (sedit:get-format 'defgeneric) 'defun)
-
-(setf (sedit:get-format 'generic-flet) 'flet)
-
-(setf (sedit:get-format 'generic-labels) 'flet)
-
-(setf (sedit:get-format 'call-next-method)
-      '(:indent (1) :args (:keyword nil)))
-
-(setf (sedit:get-format 'symbol-macrolet) 'let)
-
-(setf (sedit:get-format 'with-accessors)
-      '(:indent ((1) 1)
-	:args (:keyword :binding-list nil)
-	:sublists (2)
-	:miser :never))
-
-(setf (sedit:get-format 'with-slots) 'with-accessors)
-
-(setf (sedit:get-format 'make-instance)
-      '(:indent ((1))
-	:args (:keyword nil :slot-spec-list)))
-
-(setf (sedit:get-format '*make-instance) 'make-instance)
-
-;;; PrettyFileIndex stuff, the product of Harley Davis.
-
-(defvar *pfi-class-type* '(class defclass pfi-class-namer))
-
-(defvar *pfi-method-type* '(method defmethod pfi-method-namer)
-  "Handles method for prettyfileindex")
-
-(defvar *pfi-index-accessors* nil
-  "t -> each slot accessor gets a listing in the index.")
-
-(defvar *pfi-method-index* :group
-  ":group, :separate, :both, or nil")
-
-(defun pfi-add-class-type ()
-  (pushnew *pfi-class-type* il:*pfi-types*))
-
-(defun pfi-add-method-type ()
-  (pushnew *pfi-method-type* il:*pfi-types*))
-
-(defun pfi-class-namer (expression entry)
-  (let ((class-name (second expression)))
-    ;; Following adds all slot readers/writers/accessors as separate entries in
-    ;; the index.  Probably a mistake.
-    (if *pfi-index-accessors*
-	(let ((slot-list (fourth expression))
-	      (accessor-names nil))
-	  (labels ((add-accessor (method-index name-index)
-		     (push (case *pfi-method-index*
-			     (:group method-index)
-			     (:separate name-index)
-			     ((t :both) (list method-index name-index))
-			     ((nil) nil)
-			     (otherwise (error "Illegal value for *pfi-method-index*: ~S"
-					       *pfi-method-index*)))
-			   accessor-names))
-		   (add-reader (reader-name)
-		     (add-accessor `(method (,reader-name (,class-name)))
-				   `(,reader-name (,class-name))))
-		   (add-writer (writer-name)
-		     (add-accessor `(method ((setf ,writer-name) (t ,class-name)))
-				   `((setf ,writer-name) (t ,class-name)))))
-	    (dolist (slot-def slot-list)
-	      (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args))
-		    (slot-arg (first  rest-slot-args)  (first rest-slot-args)))
-		   ((null rest-slot-args))
- 		(case slot-arg
-		  (:reader (add-reader (second rest-slot-args)))
-		  (:writer (add-writer (second rest-slot-args)))
-		  (:accessor (add-reader (second rest-slot-args))
-			     (add-writer (second rest-slot-args)))
-		  (otherwise nil))))
-	    (cons `(class (,class-name)) accessor-names)))
-	class-name)))
-
-(defun pfi-method-namer (expression entry)
-  (let ((method-name (second expression))
-	(specializers nil)
-	(qualifiers nil)
-	lambda-list)
-    (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers))
-	  (qualifier (first rest-qualifiers) (first rest-qualifiers)))
-	 ((listp qualifier) (setq lambda-list qualifier)
-	                    (setq qualifiers (reverse qualifiers)) qualifiers)
-      (push qualifier qualifiers))
-    (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list))
-	  (arg (first rest-lambda-list) (first rest-lambda-list)))
-	 ((or (member arg lambda-list-keywords) (null rest-lambda-list))
-	  (setq specializers (reverse specializers)))
-      (push (if (listp arg) (second arg) t) specializers))
-    (let ((method-index `(method (,method-name ,@qualifiers ,specializers)))
-	  (name-index `(,method-name ,@qualifiers ,specializers)))
-      (case *pfi-method-index*
-	(:group method-index)
-	(:separate name-index)
-	((t :both) (list method-index name-index))
-	((nil) nil)
-	(otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*))))))
-
-(defun pfi-install-clos ()
-  (pfi-add-method-type)
-  (pfi-add-class-type))
-
-(eval-when (eval load)
-  (when (boundp (quote il:*pfi-types*))
-    (pfi-install-clos))
-  )
diff --git a/obsolete/clos/2.0/combin.lisp b/obsolete/clos/2.0/combin.lisp
deleted file mode 100644
index f76ba815..00000000
--- a/obsolete/clos/2.0/combin.lisp
+++ /dev/null
@@ -1,254 +0,0 @@
-;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-
-(in-package 'clos)
-
-(defun make-effective-method-function (generic-function form)
-  (flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn))
-    (if (and (listp form)
-	     (eq (car form) 'call-method)
-	     (method-p (cadr form))
-	     (every #'method-p (caddr form)))
-	;;
-	;; The effective method is just a call to call-method.  This opens up
-	;; the possibility of just using the method function of the method as
-	;; as the effective method function.
-	;;
-	;; But we have to be careful.  If that method function will ask for
-	;; the next methods we have to provide them.  We do not look to see
-	;; if there are next methods, we look at whether the method function
-	;; asks about them.  If it does, we must tell it whether there are
-	;; or aren't to prevent the leaky next methods bug.
-	;; 
-	(let* ((method-function (method-function (cadr form)))
-	       (arg-info (gf-arg-info generic-function))
-	       (metatypes (arg-info-metatypes arg-info))
-	       (applyp (arg-info-applyp arg-info)))
-	  (if (not (method-function-needs-next-methods-p method-function))
-	      method-function
-	      (let ((next-method-functions (mapcar #'method-function (caddr form))))
-		(name-function
-		  (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
-				   (let ((*next-methods* .next-method-functions.))
-				     ,(make-dfun-call metatypes applyp '.method-function.)))
-		    #'default-test-converter	;This could be optimized by making
-						;the interface from here to the
-						;walker more clear so that the
-						;form wouldn't get walked at all.
-		    #'(lambda (form)
-			(if (memq form '(.next-method-functions. .method-function.))
-			    (values form (list form))
-			    form))
-		    #'(lambda (form)
-			(cond ((eq form '.next-method-functions.)
-			       (list next-method-functions))
-			      ((eq form '.method-function.)
-			       (list method-function)))))))))
-	;;
-	;; We have some sort of `real' effective method.  Go off and get a
-	;; compiled function for it.  Most of the real hair here is done by
-	;; the GET-FUNCTION mechanism.
-	;; 
-	(name-function (make-effective-method-function-internal generic-function form)))))
-
-(defvar *global-effective-method-gensyms* ())
-(defvar *rebound-effective-method-gensyms*)
-
-(defun get-effective-method-gensym ()
-  (or (pop *rebound-effective-method-gensyms*)
-      (let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-")))
-	(push new *global-effective-method-gensyms*)
-	new)))
-
-(eval-when (load)
-  (let ((*rebound-effective-method-gensyms* ()))
-    (dotimes (i 10) (get-effective-method-gensym))))
-
-(defun make-effective-method-function-internal (generic-function effective-method)
-  (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
-	 (arg-info (gf-arg-info generic-function))
-	 (metatypes (arg-info-metatypes arg-info))
-	 (applyp (arg-info-applyp arg-info)))
-    (labels ((test-converter (form)
-	       (if (and (consp form) (eq (car form) 'call-method))
-		   '.call-method.
-		   (default-test-converter form)))
-	     (code-converter (form)
-	       (if (and (consp form) (eq (car form) 'call-method))
-		   ;;
-		   ;; We have a `call' to CALL-METHOD.  There may or may not be next methods
-		   ;; and the two cases are a little different.  It controls how many gensyms
-		   ;; we will generate.
-		   ;;
-		   (let ((gensyms
-			   (if (cddr form)
-			       (list (get-effective-method-gensym)
-				     (get-effective-method-gensym))
-			       (list (get-effective-method-gensym)
-				     ()))))
-		     (values `(let ((*next-methods* ,(cadr gensyms)))
-				,(make-dfun-call metatypes applyp (car gensyms)))
-			     gensyms))
-		   (default-code-converter form)))
-	     (constant-converter (form)
-	       (if (and (consp form) (eq (car form) 'call-method))
-		   (if (cddr form)
-		       (list (check-for-make-method (cadr form))
-			     (mapcar #'check-for-make-method (caddr form)))
-		       (list (check-for-make-method (cadr form))
-			     ()))
-		   (default-constant-converter form)))
-	     (check-for-make-method (effective-method)
-	       (cond ((method-p effective-method)
-		      (method-function effective-method))
-		     ((and (listp effective-method)
-			   (eq (car effective-method) 'make-method))
-		      (make-effective-method-function generic-function
-						      (make-progn (cadr effective-method))))
-		     (t
-		      (error "Effective-method form is malformed.")))))
-      (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method)
-		  #'test-converter
-		  #'code-converter
-		  #'constant-converter))))
-
-
-
-(defvar *invalid-method-error*
-	#'(lambda (&rest args)
-	    (declare (ignore args))
-	    (error
-	      "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
-               of a method combination function (inside the body of~%~
-               DEFINE-METHOD-COMBINATION or a method on the generic~%~
-               function COMPUTE-EFFECTIVE-METHOD).")))
-
-(defvar *method-combination-error*
-	#'(lambda (&rest args)
-	    (declare (ignore args))
-	    (error
-	      "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
-               of a method combination function (inside the body of~%~
-               DEFINE-METHOD-COMBINATION or a method on the generic~%~
-               function COMPUTE-EFFECTIVE-METHOD).")))
-
-;(defmethod compute-effective-method :around        ;issue with magic
-;	   ((generic-function generic-function)     ;generic functions
-;	    (method-combination method-combination)
-;	    applicable-methods)
-;  (declare (ignore applicable-methods))
-;  (flet ((real-invalid-method-error (method format-string &rest args)
-;	   (declare (ignore method))
-;	   (apply #'error format-string args))
-;	 (real-method-combination-error (format-string &rest args)
-;	   (apply #'error format-string args)))
-;    (let ((*invalid-method-error* #'real-invalid-method-error)
-;	  (*method-combination-error* #'real-method-combination-error))
-;      (call-next-method))))
-
-(defun invalid-method-error (&rest args)
-  (declare (arglist method format-string &rest format-arguments))
-  (apply *invalid-method-error* args))
-
-(defun method-combination-error (&rest args)
-  (declare (arglist format-string &rest format-arguments))
-  (apply *method-combination-error* args))
-
-
-
-;;;
-;;; The STANDARD method combination type.  This is coded by hand (rather than
-;;; with define-method-combination) for bootstrapping and efficiency reasons.
-;;; Note that the definition of the find-method-combination-method appears in
-;;; the file defcombin.lisp, this is because EQL methods can't appear in the
-;;; bootstrap.
-;;;
-;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
-;;; classes has to appear here for this reason.  This code must conform to
-;;; the code in the file defcombin, look there for more details.
-;;;
-
-(defclass method-combination () ())
-
-(define-gf-predicate method-combination-p method-combination)
-
-(defclass standard-method-combination
-	  (definition-source-mixin method-combination)
-     ((type          :reader method-combination-type
-	             :initarg :type)
-      (documentation :reader method-combination-documentation
-		     :initarg :documentation)
-      (options       :reader method-combination-options
-	             :initarg :options)))
-
-(defmethod print-object ((mc method-combination) stream)
-  (printing-random-thing (mc stream)
-    (format stream
-	    "Method-Combination ~S ~S"
-	    (method-combination-type mc)
-	    (method-combination-options mc))))
-
-(eval-when (load eval)
-  (setq *standard-method-combination*
-	(make-instance 'standard-method-combination
-		       :type 'standard
-		       :documentation "The standard method combination."
-		       :options ())))
-
-;This definition appears in defcombin.lisp.
-;
-;(defmethod find-method-combination ((generic-function generic-function)
-;				     (type (eql 'standard))
-;				     options)
-;  (when options
-;    (method-combination-error
-;      "The method combination type STANDARD accepts no options."))
-;  *standard-method-combination*)
-
-(defun make-call-methods (methods)
-  (mapcar #'(lambda (method) `(call-method ,method ())) methods))
-
-(defmethod compute-effective-method ((generic-function generic-function)
-				     (combin standard-method-combination)
-				     applicable-methods)
-  (let ((before ())
-	(primary ())
-	(after ())
-	(around ()))
-    (dolist (m applicable-methods)
-      (let ((qualifiers (method-qualifiers m)))
-	(cond ((member ':before qualifiers)  (push m before))
-	      ((member ':after  qualifiers)  (push m after))
-	      ((member ':around  qualifiers) (push m around))
-	      (t
-	       (push m primary)))))
-    (setq before  (reverse before)
-	  after   (reverse after)
-	  primary (reverse primary)
-	  around  (reverse around))
-    (cond ((null primary)
-	   `(error "No primary method for the generic function ~S." ',generic-function))
-	  ((and (null before) (null after) (null around))
-	   ;;
-	   ;; By returning a single call-method `form' here we enable an important
-	   ;; implementation-specific optimization.
-	   ;; 
-	   `(call-method ,(first primary) ,(rest primary)))
-	  (t
-	   (let ((main-effective-method
-		   (if (or before after (rest primary))
-		       `(multiple-value-prog1
-			  (progn ,@(make-call-methods before)
-				 (call-method ,(first primary) ,(rest primary)))
-			  ,@(make-call-methods (reverse after)))
-		       `(call-method ,(first primary) ()))))
-	     (if around
-		 `(call-method ,(first around)
-			       (,@(rest around) (make-method ,main-effective-method)))
-		 main-effective-method))))))
-
diff --git a/obsolete/clos/2.0/compat.lisp b/obsolete/clos/2.0/compat.lisp
deleted file mode 100644
index ca390f84..00000000
--- a/obsolete/clos/2.0/compat.lisp
+++ /dev/null
@@ -1,11 +0,0 @@
-;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp; -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-
-(in-package 'clos)
-
-()
diff --git a/obsolete/clos/2.0/construct.lisp b/obsolete/clos/2.0/construct.lisp
deleted file mode 100644
index 7d740475..00000000
--- a/obsolete/clos/2.0/construct.lisp
+++ /dev/null
@@ -1,1090 +0,0 @@
-;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-;;;
-;;; This file defines the defconstructor and other make-instance optimization
-;;; mechanisms.
-;;; 
-
-(in-package 'clos)
-
-;;;
-;;; defconstructor is used to define special purpose functions which just
-;;; call make-instance with a symbol as the first argument.  The semantics
-;;; of defconstructor is that it is equivalent to defining a function which
-;;; just calls make-instance. The purpose of defconstructor is to provide
-;;; CLOS with a way of noticing these calls to make-instance so that it can
-;;; optimize them.  Specific ports of CLOS could just have their compiler
-;;; spot these calls to make-instance and then call this code.  Having the
-;;; special defconstructor facility is the best we can do portably.
-;;; 
-;;;
-;;; A call to defconstructor like:
-;;;
-;;;  (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
-;;;
-;;; Is equivalent to a defun like:
-;;;
-;;;  (defun make-foo (a b &rest r)
-;;;    (make-instance 'foo 'a a ':mumble b 'baz r))
-;;;
-;;; Calls like the following are also legal:
-;;;
-;;;  (defconstructor make-foo foo ())
-;;;  (defconstructor make-bar bar () :x *x* :y *y*)
-;;;  (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c))
-;;;
-;;;
-;;; The general idea of this implementation is that the expansion of the
-;;; defconstructor form includes the creation of closure generators which
-;;; can be called to create constructor code for the class.  The ways that
-;;; a constructor can be optimized depends not only on the defconstructor
-;;; form, but also on the state of the class and the generic functions in
-;;; the initialization protocol.  Because of this, the determination of the
-;;; form of constructor code to be used is a two part process.
-;;;
-;;; At compile time, make-constructor-code-generators looks at the actual
-;;; defconstructor form and makes a list of appropriate constructor code
-;;; generators.  All that is really taken into account here is whether
-;;; any initargs are supplied in the call to make-instance, and whether
-;;; any of those are constant.
-;;;
-;;; At constructor code generation time (see note about lazy evaluation)
-;;; compute-constructor-code calls each of the constructor code generators
-;;; to try to get code for this constructor.  Each generator looks at the
-;;; state of the class and initialization protocol generic functions and
-;;; decides whether its type of code is appropriate.  This depends on things
-;;; like whether there are any applicable methods on initialize-instance,
-;;; whether class slots are affected by initialization etc.
-;;; 
-;;;
-;;; Constructor objects are funcallable instances, the protocol followed to
-;;; to compute the constructor code for them is quite similar to the protocol
-;;; followed to compute the discriminator code for a generic function.  When
-;;; the constructor is first loaded, we install as its code a function which
-;;; will compute the actual constructor code the first time it is called.
-;;; 
-;;; If there is an update to the class structure which might invalidate the
-;;; optimized constructor, the special lazy constructor installer is put back
-;;; so that it can compute the appropriate constructor when it is called.
-;;; This is the same kind of lazy evaluation update strategy used elswhere
-;;; in CLOS.
-;;;
-;;; To allow for flexibility in the CLOS implementation and to allow CLOS users
-;;; to specialize this constructor facility for their own metaclasses, there
-;;; is an internal protocol followed by the code which loads and installs
-;;; the constructors.  This is documented in the comments in the code.
-;;;
-;;; This code is also designed so that one of its levels, can be used to
-;;; implement optimization of calls to make-instance which can't go through
-;;; the defconstructor facility.  This has not been implemented yet, but the
-;;; hooks are there.
-;;;
-;;;
-
-(defmacro defconstructor
-	  (name class lambda-list &rest initialization-arguments)
-  (expand-defconstructor class
-			 name
-			 lambda-list
-			 (copy-list initialization-arguments)))
-
-(defun expand-defconstructor (class-name name lambda-list supplied-initargs)
-  (let ((class (find-class class-name nil))
-	(supplied-initarg-names
-	  (gathering1 (collecting)
-	    (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
-	      (gather1 name)))))
-    (when (null class)
-      (error "defconstructor form being compiled (or evaluated) before~@
-              class ~S is defined."
-	     class-name))
-    `(progn
-       ;; In order to avoid undefined function warnings, we want to tell
-       ;; the compile time environment that a function with this name and
-       ;; this argument list has been defined.  The portable way to do this
-       ;; is with defun.
-       (proclaim '(notinline ,name))
-       (defun ,name ,lambda-list
-	 (declare (ignore ,@(specialized-lambda-list-parameters lambda-list)))
-	 (error "Constructor ~S not loaded." ',name))
-
-       ,(make-top-level-form `(defconstructor ,name)
-			     '(load eval)
-	  `(load-constructor
-	     ',class-name
-	     ',(class-name (class-of class))
-	     ',name
-	     ',supplied-initarg-names
-	     ;; make-constructor-code-generators is called to return a list
-	     ;; of constructor code generators.  The actual interpretation
-	     ;; of this list is left to compute-constructor-code, but the
-	     ;; general idea is that it should be an plist where the keys
-	     ;; name a kind of constructor code and the values are generator
-	     ;; functions which return the actual constructor code.  The
-	     ;; constructor code is usually a closures over the arguments
-	     ;; to the generator.
-	     ,(make-constructor-code-generators class
-						name
-						lambda-list
-						supplied-initarg-names
-						supplied-initargs))))))
-
-(defun load-constructor (class-name metaclass-name constructor-name
-			 supplied-initarg-names code-generators)
-  (let ((class (find-class class-name nil)))
-    (cond ((null class)
-	   (error "defconstructor form being loaded (or evaluated) before~@
-                   class ~S is defined."
-		  class-name))
-	  ((neq (class-name (class-of class)) metaclass-name)
-	   (error "When defconstructor ~S was compiled, the metaclass of the~@
-                   class ~S was ~S.  The metaclass is now ~S.~@
-                   The constructor must be recompiled."
-		  constructor-name
-		  class-name
-		  metaclass-name
-		  (class-name (class-of class))))
-	  (t
-	   (load-constructor-internal class
-				      constructor-name
-				      supplied-initarg-names
-				      code-generators)
-	   constructor-name))))
-
-;;;
-;;; The actual constructor objects.
-;;; 
-(defclass constructor ()			   
-     ((class					;The class with which this
-	:initarg :class				;constructor is associated.
-	:reader constructor-class)		;The actual class object,
-						;not the class name.
-						;      
-      (name					;The name of this constructor.
-	:initform nil				;This is the symbol in whose
-	:initarg :name				;function cell the constructor
-	:reader constructor-name)		;usually sits.  Of course, this
-						;is optional.  defconstructor
-						;makes named constructors, but
-						;it is possible to manipulate
-						;anonymous constructors also.
-						;
-      (code-type				;The type of code currently in
-	:initform nil				;use by this constructor.  This
-	:accessor constructor-code-type)	;is mostly for debugging and
-						;analysis purposes.
-						;The lazy installer sets this
-						;to LAZY.  The most basic and
-						;least optimized type of code
-						;is called FALLBACK.
-						;
-      (supplied-initarg-names			;The names of the initargs this
-	:initarg :supplied-initarg-names	;constructor supplies when it
-	:reader					;"calls" make-instance.
-	   constructor-supplied-initarg-names)	;
-						;
-      (code-generators				;Generators for the different
-	:initarg :code-generators		;types of code this constructor
-	:reader constructor-code-generators))	;could use.
-  (:metaclass funcallable-standard-class))
-
-
-;;;
-;;; Because the value in the code-type slot should always correspond to the
-;;; funcallable-instance-function of the constructor, this function should
-;;; always be used to set the both at the same time.
-;;;
-(defun set-constructor-code (constructor code type)
-  (set-funcallable-instance-function constructor code)
-  (set-function-name constructor (constructor-name constructor))
-  (setf (constructor-code-type constructor) type))
-
-
-(defmethod print-object ((constructor constructor) stream)
-  (printing-random-thing (constructor stream)
-    (format stream
-	    "~S ~S (~S)"
-	    (or (class-name (class-of constructor)) "Constructor")
-	    (or (constructor-name constructor) "Anonymous")
-	    (constructor-code-type constructor))))
-
-(defmethod describe-object ((constructor constructor) stream)
-  (format stream
-	  "~S is a constructor for the class ~S.~%~
-            The current code type is ~S.~%~
-            Other possible code types are ~S."
-	  constructor (constructor-class constructor)
-	  (constructor-code-type constructor)
-	  (gathering1 (collecting)
-	    (doplist (key val) (constructor-code-generators constructor)
-	      (gather1 key)))))
-
-;;;
-;;; I am not in a hairy enough mood to make this implementation be metacircular
-;;; enough that it can support a defconstructor for constructor objects.
-;;; 
-(defun make-constructor (class name supplied-initarg-names code-generators)
-  (make-instance 'constructor
-		 :class class
-		 :name name
-		 :supplied-initarg-names supplied-initarg-names
-		 :code-generators code-generators))
-
-; This definition actually appears in std-class.lisp.
-;(defmethod class-constructors ((class std-class))
-;  (with-slots (plist) class (getf plist 'constructors)))
-
-(defmethod add-constructor ((class std-class)
-			    (constructor constructor))
-  (with-slots (plist) class
-    (pushnew constructor (getf plist 'constructors))))
-
-(defmethod remove-constructor ((class std-class)
-			       (constructor constructor))
-  (with-slots (plist) class
-    (setf (getf plist 'constructors)
-	  (delete constructor (getf plist 'constructors)))))
-
-(defmethod get-constructor ((class std-class) name &optional (error-p t))
-  (or (dolist (c (class-constructors class))
-	(when (eq (constructor-name c) name) (return c)))
-      (if error-p
-	  (error "Couldn't find a constructor with name ~S for class ~S."
-		 name class)
-	  ())))
-
-;;;
-;;; This is called to actually load a defconstructor constructor.  It must
-;;; install the lazy installer in the function cell of the constructor name,
-;;; and also add this constructor to the list of constructors the class has.
-;;; 
-(defmethod load-constructor-internal
-	   ((class std-class) name initargs generators)
-  (let ((constructor (make-constructor class name initargs generators))
-	(old (get-constructor class name nil)))
-    (when old (remove-constructor class old))
-    (install-lazy-constructor-installer constructor)
-    (add-constructor class constructor)
-    (setf (symbol-function name) constructor)))
-
-(defmethod install-lazy-constructor-installer ((constructor constructor))
-  (let ((class (constructor-class constructor)))
-    (set-constructor-code constructor
-			  #'(lambda (&rest args)
-			      (multiple-value-bind (code type)
-				  (compute-constructor-code class constructor)
-				(prog1 (apply code args)
-				       (set-constructor-code constructor
-							     code
-							     type))))
-			  'lazy)))
-
-;;;
-;;; The interface to keeping the constructors updated.
-;;;
-;;; add-method and remove-method (for standard-generic-function and -method),
-;;; promise to call maybe-update-constructors on the generic function and
-;;; the method.
-;;; 
-;;; The class update code promises to call update-constructors whenever the
-;;; class is changed.  That is, whenever the supers, slots or options change.
-;;; If user defined classes of constructor needs to be updated in more than
-;;; these circumstances, they should use the dependent updating mechanism to
-;;; make sure update-constructors is called.
-;;;
-;;; Bootstrapping concerns force the definitions of maybe-update-constructors
-;;; and update-constructors to be in the file std-class.  For clarity, they
-;;; also appear below.  Be sure to keep the definition here and there in sync.
-;;; 
-;(defvar *initialization-generic-functions*
-;	 (list #'make-instance
-;	       #'default-initargs
-;	       #'allocate-instance
-;	       #'initialize-instance
-;	       #'shared-initialize))
-;
-;(defmethod maybe-update-constructors
-;	   ((generic-function generic-function)
-;	    (method method))
-;  (when (memq generic-function *initialization-generic-functions*)
-;    (labels ((recurse (class)
-;	       (update-constructors class)
-;	       (dolist (subclass (class-direct-subclasses class))
-;		 (recurse subclass))))
-;      (when (classp (car (method-specializers method)))
-;	(recurse (car (method-specializers method)))))))
-;
-;(defmethod update-constructors ((class std-class))
-;  (dolist (cons (class-constructors class))
-;    (install-lazy-constructor-installer cons)))
-;
-;(defmethod update-constructors ((class class))
-;  ())
-
-
-
-;;;
-;;; Here is the actual smarts for making the code generators and then trying
-;;; each generator to get constructor code. This extensible mechanism allows
-;;; new kinds of constructor code types to be added. A programmer defining a
-;;; specialization of the constructor class can either use this mechanism to
-;;; define new code types, or can override this mechanism by overriding the
-;;; methods on make-constructor-code-generators and compute-constructor-code.
-;;;
-;;; The function defined by define-constructor-code-type will receive the
-;;; class object, and the 4 original arguments to defconstructor. It can
-;;; return a constructor code generator, or return nil if this type of code
-;;; is determined to not be appropriate after looking at the defconstructor
-;;; arguments.
-;;;
-;;; When compute-constructor-code is called, it first performs basic checks
-;;; to make sure that the basic assumptions common to all the code types are
-;;; valid.  (For details see method definition).  If any of the tests fail,
-;;; the fallback constructor code type is used.  If none of the tests fail,
-;;; the constructor code generators are called in order.  They receive 5
-;;; arguments:
-;;;
-;;;   CLASS        the class the constructor is making instances of
-;;;   WRAPPER      that class's wrapper
-;;;   DEFAULTS     the result of calling class-default-initargs on class
-;;;   INITIALIZE   the applicable methods on initialize-instance
-;;;   SHARED       the applicable methosd on shared-initialize
-;;;
-;;; The first code generator to return code is used.  The code generators are
-;;; called in reverse order of definition, so define-constructor-code-type
-;;; forms which define better code should appear after ones that define less
-;;; good code.  The fallback code type appears first.  Note that redefining a
-;;; code type does not change its position in the list.  To do that,  define
-;;; a new type at the end with the behavior.
-;;; 
-
-(defvar *constructor-code-types* ())
-
-(defmacro define-constructor-code-type (type arglist &body body)
-  (let ((fn-name (intern (format nil
-				 "CONSTRUCTOR-CODE-GENERATOR ~A ~A"
-				 (package-name (symbol-package type))
-				 (symbol-name type))
-			 *the-clos-package*)))
-    `(progn
-       (defun ,fn-name ,arglist .,body)
-       (load-define-constructor-code-type ',type ',fn-name))))
-
-(defun load-define-constructor-code-type (type generator)
-  (let ((old-entry (assq type *constructor-code-types*)))
-    (if old-entry 
-	(setf (cadr old-entry) generator)
-	(push (list type generator) *constructor-code-types*))
-    type))
-
-(defmethod make-constructor-code-generators
-	   ((class std-class)
-	    name lambda-list supplied-initarg-names supplied-initargs)
-  (cons 'list
-	(gathering1 (collecting)
-	  (dolist (entry *constructor-code-types*)
-	    (let ((generator
-		    (funcall (cadr entry) class name lambda-list 
-					  supplied-initarg-names
-					  supplied-initargs)))
-	      (when generator
-		(gather1 `',(car entry))
-		(gather1 generator)))))))
-
-(defmethod compute-constructor-code ((class std-class)
-				     (constructor constructor))
-  (let* ((proto (class-prototype class))
-	 (wrapper (class-wrapper class))
-	 (defaults (class-default-initargs class))
-         (make
-           (compute-applicable-methods #'make-instance (list class)))
-	 (supplied-initarg-names
-	   (constructor-supplied-initarg-names constructor))
-         (default
-	   (compute-applicable-methods #'default-initargs
-				       (list class supplied-initarg-names))) ;?
-         (allocate
-           (compute-applicable-methods #'allocate-instance (list class)))
-         (initialize
-           (compute-applicable-methods #'initialize-instance (list proto)))
-         (shared
-           (compute-applicable-methods #'shared-initialize (list proto t)))
-         (code-generators
-           (constructor-code-generators constructor))
-	 (code-generators
-	   (constructor-code-generators constructor)))
-    (flet ((call-code-generator (generator)
-	     (when (null generator)
-	       (unless (setq generator (getf code-generators 'fallback))
-		 (error "No FALLBACK generator?")))
-	     (funcall generator class wrapper defaults initialize shared)))
-      (if (or (cdr make)
-	      (cdr default)
-	      (cdr allocate)
-	      (check-initargs class
-			      supplied-initarg-names
-			      defaults
-			      (append initialize shared)))
-	  ;; These are basic shared assumptions, if one of the
-	  ;; has been violated, we have to resort to the fallback
-	  ;; case.  Any of these assumptions could be moved out
-	  ;; of here and into the individual code types if there
-	  ;; was a need to do so.
-	  (values (call-code-generator nil) 'fallback)
-	  ;; Otherwise try all the generators until one produces
-	  ;; code for us.
-	  (doplist (type generator) code-generators
-	    (let ((code (call-code-generator generator)))
-	      (when code (return (values code type)))))))))
-
-;;;
-;;; The facilities are useful for debugging, and to measure the performance
-;;; boost from constructors.
-;;; 
-
-(defun map-constructors (fn)
-  (let ((nclasses 0)
-	(nconstructors 0))
-    (labels ((recurse (class)
-	       (incf nclasses)
-	       (dolist (constructor (class-constructors class))
-		 (incf nconstructors)
-		 (funcall fn constructor))
-	       (dolist (subclass (class-direct-subclasses class))
-		 (recurse subclass))))
-      (recurse (find-class 't))
-      (values nclasses nconstructors))))
-
-(defun reset-constructors ()
-  (multiple-value-bind (nclass ncons)
-      (map-constructors #'install-lazy-constructor-installer )
-    (format t "~&~D classes, ~D constructors." nclass ncons)))
-
-(defun disable-constructors ()
-  (multiple-value-bind (nclass ncons)
-      (map-constructors
-	#'(lambda (c)
-	    (let ((gen (getf (constructor-code-generators c) 'fallback)))
-	      (if (null gen)
-		  (error "No fallback constructor for ~S." c)
-		  (set-constructor-code c
-					(funcall gen
-						 (constructor-class c)
-						 () () () ())
-					'fallback)))))
-    (format t "~&~D classes, ~D constructors." nclass ncons)))
-
-(defun enable-constructors ()
-  (reset-constructors))
-
-
-;;;
-;;; Helper functions and utilities that are shared by all of the code types
-;;; and by the main compute-constructor-code method as well.
-;;; 
-
-(defvar *standard-initialize-instance-method*
-        (get-method #'initialize-instance
-		    ()
-		    (list *the-class-standard-object*)))
-
-(defvar *standard-shared-initialize-method*
-        (get-method #'shared-initialize
-		    ()
-		    (list *the-class-standard-object* *the-class-t*)))
-
-(defun non-clos-initialize-instance-methods-p (methods)
-  (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*))
-	    methods))
-
-(defun non-clos-shared-initialize-methods-p (methods)
-  (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*))
-	    methods))
-
-(defun non-clos-or-after-initialize-instance-methods-p (methods)
-  (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*)
-			      (equal '(:after) (method-qualifiers m))))
-	    methods))
-
-(defun non-clos-or-after-shared-initialize-methods-p (methods)
-  (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*)
-			      (equal '(:after) (method-qualifiers m))))
-	    methods))
-
-
-;;; 
-;;; if initargs are valid return nil, otherwise return t.
-;;;
-(defun check-initargs (class supplied-initarg-names defaults methods)
-  (let ((legal (apply #'append
-		      (mapcar #'slotd-initargs (class-slots class)))))
-    ;; Add to the set of slot-filling initargs the set of
-    ;; initargs that are accepted by the methods.  If at
-    ;; any point we come across &allow-other-keys, we can
-    ;; just quit.
-    (dolist (method methods)
-      (multiple-value-bind (keys allow-other-keys)
-	  (function-keywords method)
-	(when allow-other-keys
-	  (return-from check-initargs nil))
-	(setq legal (append keys legal))))
-    ;; Now check the supplied-initarg-names and the default initargs
-    ;; against the total set that we know are legal.
-    (dolist (key supplied-initarg-names)
-      (unless (memq key legal)
-	(return-from check-initargs t)))
-    (dolist (default defaults)
-      (unless (memq (car default) legal)
-	(return-from check-initargs t)))))
-
-
-;;;
-;;; This returns two values.  The first is a vector which can be used as the
-;;; initial value of the slots vector for the instance. The first is a symbol
-;;; describing the initforms this class has.  
-;;;
-;;;  If the first value is:
-;;;
-;;;    :unsupplied    no slot has an initform
-;;;    :constants     all slots have either a constant initform
-;;;                   or no initform at all
-;;;    t              there is at least one non-constant initform
-;;; 
-(defun compute-constant-vector (class)
-  (declare (values constants flag))
-  (let* ((wrapper (class-wrapper class))
-	 (layout (wrapper-instance-slots-layout wrapper))
-	 (flag :unsupplied)
-	 (constants ()))
-    (dolist (slotd (class-slots class))
-      (let ((name (slotd-name slotd))
-	    (initform (slotd-initform slotd))
-	    (initfn (slotd-initfunction slotd)))
-	(cond ((null (memq name layout)))
-	      ((or (eq initform *slotd-unsupplied*)
-		   (null initfn))
-	       (push (cons name *slot-unbound*) constants))
-	      ((constantp initform)
-	       (push (cons name (eval initform)) constants)
-	       (when (eq flag ':unsupplied) (setq flag ':constants)))
-	      (t
-	       (push (cons name *slot-unbound*) constants)
-	       (setq flag 't)))))
-    (values
-      (apply #'vector
-	     (mapcar #'cdr
-		     (sort constants #'(lambda (x y)
-					 (memq (car y)
-					       (memq (car x) layout))))))
-      flag)))
-
-(defmacro copy-constant-vector (constants)
-  `(copy-seq (the simple-vector ,constants)))
-
-
-;;;
-;;; This takes a class and a list of initarg-names, and returns an alist
-;;; indicating the positions of the slots those initargs may fill.  The
-;;; order of the initarg-names argument is important of course, since we
-;;; have to respect the rules about the leftmost initarg that fills a slot
-;;; having precedence.  This function allows initarg names to appear twice
-;;; in the list, it only considers the first appearance.
-;;;
-(defun compute-initarg-positions (class initarg-names)
-  (let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
-	 (positions
-	   (gathering1 (collecting)
-	     (iterate ((slot-name (list-elements layout))
-		       (position (interval :from 0)))
-	       (gather1 (cons slot-name position)))))
-	 (slot-initargs
-	   (mapcar #'(lambda (slotd)
-		       (list (slotd-initargs slotd)
-			     (or (cdr (assq (slotd-name slotd) positions))
-				 ':class)))
-		   (class-slots class))))
-    ;; Go through each of the initargs, and figure out what position
-    ;; it fills by replacing the entries in slot-initargs it fills.
-    (dolist (initarg initarg-names)
-      (dolist (slot-entry slot-initargs)
-	(let ((slot-initargs (car slot-entry)))
-	  (when (and (listp slot-initargs)
-		     (not (null slot-initargs))
-		     (memq initarg slot-initargs))
-	    (setf (car slot-entry) initarg)))))
-    (gathering1 (collecting)
-      (dolist (initarg initarg-names)
-	(let ((positions (gathering1 (collecting)
-			   (dolist (slot-entry slot-initargs)
-			     (when (eq (car slot-entry) initarg)
-			       (gather1 (cadr slot-entry)))))))
-	  (when positions
-	    (gather1 (cons initarg positions))))))))
-
-
-;;;
-;;; The FALLBACK case allows anything.  This always works, and always appears
-;;; as the last of the generators for a constructor.  It does a full call to
-;;; make-instance.
-;;;
-
-(define-constructor-code-type fallback
-        (class name arglist supplied-initarg-names supplied-initargs)
-  (declare (ignore name supplied-initarg-names))
-  `(function
-     (lambda (&rest ignore)
-       (declare (ignore ignore))
-       (function
-	 (lambda ,arglist
-	   (make-instance
-	     ',(class-name class)
-	     ,@(gathering1 (collecting)
-		 (iterate ((tail (*list-tails supplied-initargs :by #'cddr)))
-		   (gather1 `',(car tail))
-		   (gather1 (cadr tail))))))))))
-
-;;;
-;;; The GENERAL case allows:
-;;;   constant, unsupplied or non-constant initforms
-;;;   constant or non-constant default initargs
-;;;   supplied initargs
-;;;   slot-filling initargs
-;;;   :after methods on shared-initialize and initialize-instance
-;;;   
-(define-constructor-code-type general
-        (class name arglist supplied-initarg-names supplied-initargs)
-  (declare (ignore name))
-  (let ((raw-allocator (raw-instance-allocator class))
-	(slots-fetcher (slots-fetcher class))
-	(wrapper-fetcher (wrapper-fetcher class)))
-    `(function
-       (lambda (class .wrapper. defaults init shared)
-	 (multiple-value-bind (.constants.
-			       .constant-initargs.
-			       .initfns-initargs-and-positions.
-			       .supplied-initarg-positions.
-			       .shared-initfns.
-			       .initfns.)
-	     (general-generator-internal class
-					 defaults
-					 init
-					 shared
-					 ',supplied-initarg-names
-					 ',supplied-initargs)
-	   .supplied-initarg-positions.
-	   (when (and .constants.
-		      (null (non-clos-or-after-initialize-instance-methods-p
-			      init))
-		      (null (non-clos-or-after-shared-initialize-methods-p
-			      shared)))
-	     (function
-	       (lambda ,arglist
-		 (declare (optimize (speed 3) (safety 0)))
-		 (let ((.instance. (,raw-allocator))
-		       (.slots. (copy-constant-vector .constants.))
-		       (.positions. .supplied-initarg-positions.)
-		       (.initargs. .constant-initargs.))		   
-		   .positions.
-		   
-		   (setf (,slots-fetcher .instance.) .slots.)	     
-		   (setf (,wrapper-fetcher .instance.) .wrapper.)
-
-		   (dolist (entry .initfns-initargs-and-positions.)
-		     (let ((val (funcall (car entry)))
-			   (initarg (cadr entry)))
-		       (when initarg
-			 (push val .initargs.)
-			 (push initarg .initargs.))
-		       (dolist (pos (cddr entry))
-			 (setf (%svref .slots. pos) val))))
-
-		   ,@(gathering1 (collecting)
-		       (doplist (initarg value) supplied-initargs
-			 (unless (constantp value)
-			   (gather1 `(let ((.value. ,value))
-				       (push .value. .initargs.)
-				       (push ',initarg .initargs.)
-				       (dolist (.p. (pop .positions.))
-					 (setf (%svref .slots. .p.)
-					       .value.)))))))
-
-		   (dolist (fn .shared-initfns.)
-		     (apply fn .instance. t .initargs.))
-		   (dolist (fn .initfns.)
-		     (apply fn .instance. .initargs.))
-		     
-		   .instance.)))))))))
-
-(defun general-generator-internal
-       (class defaults init shared supplied-initarg-names supplied-initargs)
-  (flet ((bail-out () (return-from general-generator-internal nil)))
-    (let* ((constants (compute-constant-vector class))
-	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
-	   (initarg-positions
-	     (compute-initarg-positions class
-					(append supplied-initarg-names
-						(mapcar #'car defaults))))
-	   (initfns-initargs-and-positions ())
-	   (supplied-initarg-positions ())
-	   (constant-initargs ())
-	   (used-positions ()))
-					       
-      ;;
-      ;; Go through each of the supplied initargs for three reasons.
-      ;;
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If its a constant form, fill the constant vector.
-      ;;   - Otherwise remember the positions no two initargs
-      ;;     will try to fill the same position, since compute
-      ;;     initarg positions already took care of that, but
-      ;;     we do need to know what initforms will and won't
-      ;;     be needed.
-      ;;   
-      (doplist (initarg val) supplied-initargs
-	(let ((positions (cdr (assq initarg initarg-positions))))
-	  (cond ((memq :class positions) (bail-out))
-		((constantp val)
-		 (setq val (eval val))
-		 (push val constant-initargs)
-		 (push initarg constant-initargs)
-		 (dolist (pos positions) (setf (svref constants pos) val)))
-		(t
-		 (push positions supplied-initarg-positions)))
-	  (setq used-positions (append positions used-positions))))
-      ;;
-      ;; Go through each of the default initargs, for three reasons.
-      ;;
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If it is a constant, and it does fill a slot, put that
-      ;;     into the constant vector.
-      ;;   - If it isn't a constant, record its initfn and position.
-      ;;   
-      (dolist (default defaults)
-	(let* ((name (car default))
-	       (initfn (cadr default))
-	       (form (caddr default))
-	       (value ())
-	       (positions (cdr (assq name initarg-positions))))
-	  (unless (memq name supplied-initarg-names)
-	    (cond ((memq :class positions) (bail-out))
-		  ((constantp form)
-		   (setq value (eval form))
-		   (push value constant-initargs)
-		   (push name constant-initargs)
-		   (dolist (pos positions)
-		     (setf (svref constants pos) value)))
-		  (t
-		   (push (list* initfn name positions)
-			 initfns-initargs-and-positions)))
-	    (setq used-positions (append positions used-positions)))))
-      ;;
-      ;; Go through each of the slot initforms:
-      ;;
-      ;;    - If its position has already been filled, do nothing.
-      ;;      The initfn won't need to be called, and the slot won't
-      ;;      need to be touched.
-      ;;    - If it is a class slot, and has an initform, bail out.
-      ;;    - If its a constant or unsupplied, ignore it, it is
-      ;;      already in the constant vector.
-      ;;    - Otherwise, record its initfn and position
-      ;;
-      (dolist (slotd (class-slots class))
-	(let* ((alloc (slotd-allocation slotd))
-	       (name (slotd-name slotd))
-	       (form (slotd-initform slotd))
-	       (initfn (slotd-initfunction slotd))
-	       (position (position name layout)))
-	  (cond ((neq alloc :instance)
-		 (unless (or (eq form *slotd-unsupplied*)
-			     (null initfn))
-		   (bail-out)))
-		((member position used-positions))
-		((or (constantp form)
-		     (eq form *slotd-unsupplied*)))
-		(t
-		 (push (list initfn nil position)
-		       initfns-initargs-and-positions)))))
-
-      (values constants
-	      constant-initargs
-	      (nreverse initfns-initargs-and-positions)
-	      (nreverse supplied-initarg-positions)
-	      (mapcar #'method-function
-		      (remove *standard-shared-initialize-method* shared))
-	      (mapcar #'method-function
-		      (remove *standard-initialize-instance-method* init))))))
-
-
-;;;
-;;; The NO-METHODS case allows:
-;;;   constant, unsupplied or non-constant initforms
-;;;   constant or non-constant default initargs
-;;;   supplied initargs that are arguments to constructor, or constants
-;;;   slot-filling initargs
-;;;
-
-(define-constructor-code-type no-methods
-        (class name arglist supplied-initarg-names supplied-initargs)
-  (declare (ignore name))
-  (let ((raw-allocator (raw-instance-allocator class))
-	(slots-fetcher (slots-fetcher class))
-	(wrapper-fetcher (wrapper-fetcher class)))
-    `(function
-       (lambda (class .wrapper. defaults init shared)
-	 (multiple-value-bind (.constants.
-			       .initfns-and-positions.
-			       .supplied-initarg-positions.)
-	     (no-methods-generator-internal class
-					    defaults
-					    ',supplied-initarg-names
-					    ',supplied-initargs)
-	   .initfns-and-positions.
-	   .supplied-initarg-positions.
-	   (when (and .constants.
-		      (null (non-clos-initialize-instance-methods-p init))
-		      (null (non-clos-shared-initialize-methods-p shared)))
-	     #'(lambda ,arglist
-		 (declare (optimize (speed 3) (safety 0)))
-		 (let ((.instance. (,raw-allocator))
-		       (.slots. (copy-constant-vector .constants.))
-		       (.positions. .supplied-initarg-positions.))
-		   .positions.
-		   (setf (,slots-fetcher .instance.) .slots.)
-		   (setf (,wrapper-fetcher .instance.) .wrapper.)
-
-		   (dolist (entry .initfns-and-positions.)
-		     (let ((val (funcall (car entry))))
-		       (dolist (pos (cdr entry))
-			 (setf (%svref .slots. pos) val))))
-		 
-		   ,@(gathering1 (collecting)
-		       (doplist (initarg value) supplied-initargs
-			 (unless (constantp value)
-			   (gather1
-			     `(let ((.value. ,value))
-				(dolist (.p. (pop .positions.))
-				  (setf (%svref .slots. .p.) .value.)))))))
-		     
-		   .instance.))))))))
-
-(defun no-methods-generator-internal
-       (class defaults supplied-initarg-names supplied-initargs)
-  (flet ((bail-out () (return-from no-methods-generator-internal nil)))
-    (let* ((constants	(compute-constant-vector class))
-	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
-	   (initarg-positions
-	     (compute-initarg-positions class
-					(append supplied-initarg-names
-						(mapcar #'car defaults))))
-	   (initfns-and-positions ())
-	   (supplied-initarg-positions ())
-	   (used-positions ()))
-      ;;
-      ;; Go through each of the supplied initargs for three reasons.
-      ;;
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If its a constant form, fill the constant vector.
-      ;;   - Otherwise remember the positions, no two initargs
-      ;;     will try to fill the same position, since compute
-      ;;     initarg positions already took care of that, but
-      ;;     we do need to know what initforms will and won't
-      ;;     be needed.
-      ;;   
-      (doplist (initarg val) supplied-initargs
-	(let ((positions (cdr (assq initarg initarg-positions))))
-	  (cond ((memq :class positions) (bail-out))
-		((constantp val)
-		 (setq val (eval val))
-		 (dolist (pos positions)
-		   (setf (svref constants pos) val)))
-		(t
-		 (push positions supplied-initarg-positions)))
-	  (setq used-positions (append positions used-positions))))
-      ;;
-      ;; Go through each of the default initargs, for three reasons.
-      ;;
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If it is a constant, and it does fill a slot, put that
-      ;;     into the constant vector.
-      ;;   - If it isn't a constant, record its initfn and position.
-      ;;   
-      (dolist (default defaults)
-	(let* ((name (car default))
-	       (initfn (cadr default))
-	       (form (caddr default))
-	       (value ())
-	       (positions (cdr (assq name initarg-positions))))
-	  (unless (memq name supplied-initarg-names)
-	    (cond ((memq :class positions) (bail-out))
-		  ((constantp form)
-		   (setq value (eval form))
-		   (dolist (pos positions)
-		     (setf (svref constants pos) value)))
-		  (t
-		   (push (cons initfn positions)
-			 initfns-and-positions)))
-	    (setq used-positions (append positions used-positions)))))
-      ;;
-      ;; Go through each of the slot initforms:
-      ;;
-      ;;    - If its position has already been filled, do nothing.
-      ;;      The initfn won't need to be called, and the slot won't
-      ;;      need to be touched.
-      ;;    - If it is a class slot, and has an initform, bail out.
-      ;;    - If its a constant or unsupplied, do nothing, we know
-      ;;      that it is already in the constant vector.
-      ;;    - Otherwise, record its initfn and position
-      ;;
-      (dolist (slotd (class-slots class))
-	(let* ((alloc (slotd-allocation slotd))
-	       (name (slotd-name slotd))
-	       (form (slotd-initform slotd))
-	       (initfn (slotd-initfunction slotd))
-	       (position (position name layout)))
-	  (cond ((neq alloc :instance)
-		 (unless (or (eq form *slotd-unsupplied*) 
-			     (null initfn))
-		   (bail-out)))
-		((member position used-positions))
-		((or (constantp form)
-		     (eq form *slotd-unsupplied*)))
-		(t
-		 (push (list initfn position) initfns-and-positions)))))
-
-      (values constants
-	      (nreverse initfns-and-positions)
-	      (nreverse supplied-initarg-positions)))))
-
-
-;;;
-;;; The SIMPLE-SLOTS case allows:
-;;;   constant or unsupplied initforms
-;;;   constant default initargs
-;;;   supplied initargs
-;;;   slot filling initargs
-;;;
-
-(define-constructor-code-type simple-slots
-        (class name arglist supplied-initarg-names supplied-initargs)
-  (declare (ignore name))
-  (let ((raw-allocator (raw-instance-allocator class))
-	(slots-fetcher (slots-fetcher class))
-	(wrapper-fetcher (wrapper-fetcher class)))
-    `(function
-       (lambda (class .wrapper. defaults init shared)
-	 (when (and (null (non-clos-initialize-instance-methods-p init))
-		    (null (non-clos-shared-initialize-methods-p shared)))
-	   (multiple-value-bind (.constants. .supplied-initarg-positions.)
-	       (simple-slots-generator-internal class
-						defaults
-						',supplied-initarg-names
-						',supplied-initargs)
-	     (when .constants.
-	       (function
-		 (lambda ,arglist
-		   (declare (optimize (speed 3) (safety 0)))
-		   (let ((.instance. (,raw-allocator))
-			 (.slots. (copy-constant-vector .constants.))
-			 (.positions. .supplied-initarg-positions.))
-		     
-		     .positions.
-		     (setf (,slots-fetcher .instance.) .slots.)	     
-		     (setf (,wrapper-fetcher .instance.) .wrapper.)
-		 
-		     ,@(gathering1 (collecting)
-			 (doplist (initarg value) supplied-initargs
-			   (unless (constantp value)
-			     (gather1
-			       `(let ((.value. ,value))
-				  (dolist (.p. (pop .positions.))
-				    (setf (%svref .slots. .p.) .value.)))))))
-		     
-		     .instance.))))))))))
-
-(defun simple-slots-generator-internal
-       (class defaults supplied-initarg-names supplied-initargs)
-  (flet ((bail-out () (return-from simple-slots-generator-internal nil)))
-    (let* ((constants (compute-constant-vector class))
-	   (layout (wrapper-instance-slots-layout (class-wrapper class)))
-	   (initarg-positions
-	     (compute-initarg-positions class
-					(append supplied-initarg-names
-						(mapcar #'car defaults))))
-	   (supplied-initarg-positions ())
-	   (used-positions ()))
-      ;;
-      ;; Go through each of the supplied initargs for three reasons.
-      ;;
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If its a constant form, fill the constant vector.
-      ;;   - Otherwise remember the positions, no two initargs
-      ;;     will try to fill the same position, since compute
-      ;;     initarg positions already took care of that, but
-      ;;     we do need to know what initforms will and won't
-      ;;     be needed.
-      ;;   
-      (doplist (initarg val) supplied-initargs
-	(let ((positions (cdr (assq initarg initarg-positions))))
-	  (cond ((memq :class positions) (bail-out))
-		((constantp val)
-		 (setq val (eval val))
-		 (dolist (pos positions)
-		   (setf (svref constants pos) val)))
-		(t
-		 (push positions supplied-initarg-positions)))
-	  (setq used-positions (append used-positions positions))))
-      ;;
-      ;; Go through each of the default initargs for three reasons.
-      ;; 
-      ;;   - If it isn't a constant form, bail out.
-      ;;   - If it fills a class slot, bail out.
-      ;;   - If it is a constant, and it does fill a slot, put that
-      ;;     into the constant vector.
-      ;;   
-      (dolist (default defaults)
-	(let* ((name (car default))
-	       (form (caddr default))
-	       (value ())
-	       (positions (cdr (assq name initarg-positions))))
-	  (unless (memq name supplied-initarg-names)
-	    (cond ((memq :class positions) (bail-out))
-		  ((not (constantp form))
-		   (bail-out))
-		  (t
-		   (setq value (eval form))
-		   (dolist (pos positions)
-		     (setf (svref constants pos) value)))))))
-      ;;
-      ;; Go through each of the slot initforms:
-      ;;
-      ;;    - If its position has already been filled, do nothing.
-      ;;      The initfn won't need to be called, and the slot won't
-      ;;      need to be touched, we are OK.
-      ;;    - If it has a non-constant initform, bail-out.  This
-      ;;      case doesn't handle those.
-      ;;    - If it has a constant or unsupplied initform we don't
-      ;;      really need to do anything, the value is in the
-      ;;      constants vector.
-      ;;
-      (dolist (slotd (class-slots class))
-	(let* ((alloc (slotd-allocation slotd))
-	       (name (slotd-name slotd))
-	       (form (slotd-initform slotd))
-	       (initfn (slotd-initfunction slotd))
-	       (position (position name layout)))
-	  (cond ((neq alloc :instance)
-		 (unless (or (eq form *slotd-unsupplied*)
-			     (null initfn))
-		   (bail-out)))
-		((member position used-positions))
-		((or (constantp form)
-		     (eq form *slotd-unsupplied*)))
-		(t
-		 (bail-out)))))
-      
-      (values constants (nreverse supplied-initarg-positions)))))
diff --git a/obsolete/clos/2.0/cpl.lisp b/obsolete/clos/2.0/cpl.lisp
deleted file mode 100644
index 9eda3018..00000000
--- a/obsolete/clos/2.0/cpl.lisp
+++ /dev/null
@@ -1,271 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-;;;. Copyright (c) 1991 by Venue
-
-
-(in-package "CLOS")
-
-
-;;; compute-class-precedence-list Knuth section 2.2.3 has some interesting notes on this. What
-;;; appears here is basically the algorithm presented there. The key idea is that we use
-;;; class-precedence-description (CPD) structures to store the precedence information as we proceed.
-;;; The CPD structure for a class stores two critical pieces of information: - a count of the number
-;;; of "reasons" why the class can't go into the class precedence list yet. - a list of the
-;;; "reasons" this class prevents others from going in until after it 
-
-
-
-;; 
-
-
-
-;;; A "reason" is essentially a single local precedence constraint.  If a constraint between two
-;;; classes arises more than once it generates more than one reason.  This makes things simpler,
-;;; linear, and isn't a problem as long as we make sure to keep track of each instance of a
-;;; "reason". This code is divided into three phases. - the first phase simply generates the CPD's
-;;; for each of the class and its superclasses.  The remainder of the code will manipulate these
-;;; CPDs rather than the class objects themselves.  At the end of this pass, the CPD-SUPERS field of
-;;; a CPD is a list of the CPDs of the direct superclasses of the class. - the second phase folds
-;;; all the local constraints into the CPD structure.  The CPD-COUNT of each CPD is built up, and
-;;; the CPD-AFTER fields are augmented to include precedence constraints from the CPD-SUPERS field
-;;; and from the order of classes in other CPD-SUPERS fields. After this phase, the CPD-AFTER field
-;;; of a class includes all the direct superclasses of the class plus any class that immediately
-;;; follows the class in the direct superclasses of another.  There can be duplicates in this list. 
-;;; The CPD-COUNT field is equal to the number of times this class appears in the CPD-AFTER field of
-;;; all the other CPDs. - In the third phase, classes are put into the precedence list one at a
-;;; time, with only those classes with a CPD-COUNT of 0 being candidates for insertion.  When a
-;;; class is inserted , every CPD in its CPD-AFTER field has its count decremented. In the usual
-;;; case, there is only one candidate for insertion at any point.  If there is more than one, the
-;;; specified tiebreaker rule is used to choose among them. 
-
-
-(defmethod compute-class-precedence-list ((root std-class)
-                                          direct-superclasses)
-       (compute-std-cpl root direct-superclasses))
-
-(defstruct (class-precedence-description (:conc-name nil)
-                  (:print-function (lambda (obj str depth)
-                                          (declare (ignore depth))
-                                          (format str "#<CPD ~S ~D>" (class-name (cpd-class obj))
-                                                 (cpd-count obj))))
-                  (:constructor make-cpd nil))
-       (cpd-class nil)
-       (cpd-supers nil)
-       (cpd-after nil)
-       (cpd-count 0))
-
-(defun compute-std-cpl (class supers)
-       (cond ((null supers)
-                                                             ; First two branches of COND
-              (list class))
-                                                             ; are implementing the single
-             ((null (cdr supers))
-                                                             ; inheritance optimization.
-              (cons class (compute-std-cpl (car supers)
-                                 (class-direct-superclasses (car supers)))))
-             (t (multiple-value-bind (all-cpds nclasses)
-                    (compute-std-cpl-phase-1 class supers)
-                  (compute-std-cpl-phase-2 all-cpds)
-                  (compute-std-cpl-phase-3 class all-cpds nclasses)))))
-
-(defvar *compute-std-cpl-class->entry-table-size* 60)
-
-(defun compute-std-cpl-phase-1 (class supers)
-       (let ((nclasses 0)
-             (all-cpds nil)
-             (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test
-                           #'eq)))
-            (labels ((get-cpd (c)
-                            (or (gethash c table)
-                                (setf (gethash c table)
-                                      (make-cpd))))
-                     (walk (c supers)
-                           (if (forward-referenced-class-p c)
-                               (cpl-forward-referenced-class-error class c)
-                               (let ((cpd (get-cpd c)))
-                                    (unless (cpd-class cpd)
-                                                             ; If we have already done this class
-                                                             ; before, we can quit. 
-                                        (setf (cpd-class cpd)
-                                              c)
-                                        (incf nclasses)
-                                        (push cpd all-cpds)
-                                        (setf (cpd-supers cpd)
-                                              (mapcar #'get-cpd supers))
-                                        (dolist (super supers)
-                                            (walk super (class-direct-superclasses super))))))))
-                   (walk class supers)
-                   (values all-cpds nclasses))))
-
-(defun compute-std-cpl-phase-2 (all-cpds)
-       (dolist (cpd all-cpds)
-           (let ((supers (cpd-supers cpd)))
-                (when supers
-                    (setf (cpd-after cpd)
-                          (nconc (cpd-after cpd)
-                                 supers))
-                    (incf (cpd-count (car supers))
-                          1)
-                    (do* ((t1 supers t2)
-                          (t2 (cdr t1)
-                              (cdr t1)))
-                         ((null t2))
-                       (incf (cpd-count (car t2))
-                             2)
-                       (push (car t2)
-                             (cpd-after (car t1))))))))
-
-(defun
- compute-std-cpl-phase-3
- (class all-cpds nclasses)
- (let ((candidates nil)
-       (next-cpd nil)
-       (rcpl nil))
-      
-      ;; We have to bootstrap the collection of those CPD's that have a zero count.  Once we get
-      ;; going, we will maintain this list incrementally. 
-      (dolist (cpd all-cpds)
-          (when (zerop (cpd-count cpd))
-                (push cpd candidates)))
-      (loop (when (null candidates)
-                
-                ;; If there are no candidates, and enough classes have been put into the precedence
-                ;; list, then we are all done.  Otherwise it means there is a consistency problem. 
-                (if (zerop nclasses)
-                    (return (reverse rcpl))
-                    (cpl-inconsistent-error class all-cpds)))
-            
-            ;; Try to find the next class to put in from among the candidates. If there is only one,
-            ;; its easy, otherwise we have to use the famous RPG tiebreaker rule.  There is some
-            ;; hair here to avoid having to call DELETE on the list of candidates.  I dunno if its
-            ;; worth it but what the hell. 
-            (setq next-cpd
-                  (if (null (cdr candidates))
-                      (prog1 (car candidates)
-                             (setq candidates nil))
-                      (block tie-breaker
-                          (dolist (c rcpl)
-                              (let ((supers (class-direct-superclasses c)))
-                                   (if (memq (cpd-class (car candidates))
-                                             supers)
-                                       (return-from tie-breaker (pop candidates))
-                                       (do ((loc candidates (cdr loc)))
-                                           ((null (cdr loc)))
-                                         (let ((cpd (cadr loc)))
-                                              (when (memq (cpd-class cpd)
-                                                          supers)
-                                                  (setf (cdr loc)
-                                                        (cddr loc))
-                                                  (return-from tie-breaker cpd))))))))))
-            (decf nclasses)
-            (push (cpd-class next-cpd)
-                  rcpl)
-            (dolist (after (cpd-after next-cpd))
-                (when (zerop (decf (cpd-count after)))
-                      (push after candidates))))))
-
-
-;;; Support code for signalling nice error messages. 
-
-
-(defun cpl-error (class format-string &rest format-args)
-       (error "While computing the class precedence list of the class ~A.~%~A"
-              (if (class-name class)
-                  (format nil "named ~S" (class-name class))
-                  class)
-              (apply #'format nil format-string format-args)))
-
-(defun cpl-forward-referenced-class-error (class forward-class)
-       (flet ((class-or-name (class)
-                     (if (class-name class)
-                         (format nil "named ~S" (class-name class))
-                         class)))
-             (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class))))
-                   )
-                  (cpl-error class 
-                "The class ~A is a forward referenced class.~@
-                  The class ~A is ~A." (class-or-name forward-class)
-                         (class-or-name forward-class)
-                         (if (null (cdr names))
-                             (format nil "a direct superclass of the class ~A" (class-or-name class))
-                             (format nil "reached from the class ~A by following~@
-                              the direct superclass chain through: ~A~
-                              ~%  ending at the class ~A" (class-or-name class)
-                                    (format nil "~{~%  the class ~A,~}" (butlast names))
-                                    (car (last names))))))))
-
-(defun find-superclass-chain (bottom top)
-       (labels ((walk (c chain)
-                      (if (eq c top)
-                          (return-from find-superclass-chain (nreverse chain))
-                          (dolist (super (class-direct-superclasses c))
-                              (walk super (cons super chain))))))
-              (walk bottom (list bottom))))
-
-(defun cpl-inconsistent-error (class all-cpds)
-       (let ((reasons (find-cycle-reasons all-cpds)))
-            (cpl-error class "It is not possible to compute the class precedence list because~@
-       there ~A in the local precedence relations.~@
-       ~A because:~{~%  ~A~}." (if (cdr reasons)
-                                   "are circularities"
-                                   "is a circularity")
-                   (if (cdr reasons)
-                       "These arise"
-                       "This arises")
-                   (format-cycle-reasons (apply #'append reasons)))))
-
-(defun format-cycle-reasons (reasons)
-       (flet ((class-or-name (cpd)
-                     (let ((class (cpd-class cpd)))
-                          (if (class-name class)
-                              (format nil "named ~S" (class-name class))
-                              class))))
-             (mapcar #'(lambda (reason)
-                              (ecase (caddr reason)
-                                  (:super (format nil 
-                                                 "the class ~A appears in the supers of the class ~A"
-                                                 (class-or-name (cadr reason))
-                                                 (class-or-name (car reason))))
-                                  (:in-supers (format nil 
-                                    "the class ~A follows the class ~A in the supers of the class ~A"
-                                                     (class-or-name (cadr reason))
-                                                     (class-or-name (car reason))
-                                                     (class-or-name (cadddr reason))))))
-                    reasons)))
-
-(defun find-cycle-reasons (all-cpds)
-       (let ((been-here nil)
-                                                             ; List of classes we have visited.
-             (cycle-reasons nil))
-            (labels ((chase (path)
-                            (if (memq (car path)
-                                      (cdr path))
-                                (record-cycle (memq (car path)
-                                                    (nreverse path)))
-                                (unless (memq (car path)
-                                              been-here)
-                                    (push (car path)
-                                          been-here)
-                                    (dolist (after (cpd-after (car path)))
-                                        (chase (cons after path))))))
-                     (record-cycle
-                      (cycle)
-                      (let ((reasons nil))
-                           (do* ((t1 cycle t2)
-                                 (t2 (cdr t1)
-                                     (cdr t1)))
-                                ((null t2))
-                              (let ((c1 (car t1))
-                                    (c2 (car t2)))
-                                   (if (memq c2 (cpd-supers c1))
-                                       (push (list c1 c2 :super)
-                                             reasons)
-                                       (dolist (cpd all-cpds)
-                                           (when (memq c2 (memq c1 (cpd-supers cpd)))
-                                               (return (push (list c1 c2 :in-supers cpd)
-                                                             reasons)))))))
-                           (push (nreverse reasons)
-                                 cycle-reasons))))
-                   (dolist (cpd all-cpds)
-                       (unless (zerop (cpd-count cpd))
-                           (chase (list cpd))))
-                   cycle-reasons)))
diff --git a/obsolete/clos/2.0/ctypes.lisp b/obsolete/clos/2.0/ctypes.lisp
deleted file mode 100644
index 1de6d3a4..00000000
--- a/obsolete/clos/2.0/ctypes.lisp
+++ /dev/null
@@ -1,25 +0,0 @@
-;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-
-(in-package 'clos)
-
-;;;
-;;; The built-in method combination types as taken from page 1-31 of 88-002R.
-;;; Note that the STANDARD method combination type is defined by hand in the
-;;; file combin.lisp.
-;;;
-
-(define-method-combination +      :identity-with-one-argument t)
-(define-method-combination and    :identity-with-one-argument t)
-(define-method-combination append :identity-with-one-argument nil)
-(define-method-combination list   :identity-with-one-argument nil)
-(define-method-combination max    :identity-with-one-argument t)
-(define-method-combination min    :identity-with-one-argument t)
-(define-method-combination nconc  :identity-with-one-argument t)
-(define-method-combination or     :identity-with-one-argument t)
-(define-method-combination progn  :identity-with-one-argument t)
diff --git a/obsolete/clos/2.0/defclass.lisp b/obsolete/clos/2.0/defclass.lisp
deleted file mode 100644
index 4aaf9791..00000000
--- a/obsolete/clos/2.0/defclass.lisp
+++ /dev/null
@@ -1,230 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-;;;. Copyright (c) 1991 by Venue
-(in-package "CLOS")
-
-;;; ************************************************************************* 
-
-
-
-;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. The original
-;;; motiviation for this function was to deal with the bug in the Genera compiler that prevents
-;;; lambda expressions in top-level forms other than DEFUN from being compiled. Now this function is
-;;; used to grab other functionality as well.  This includes: - Preventing the grouping of top-level
-;;; forms.  For example, a DEFCLASS followed by a DEFMETHOD may not want to be grouped into the same
-;;; top-level form. - Telling the programming environment what the pretty version of the name of
-;;; this form is.  This is used by WARN. 
-
-
-(defun make-top-level-form (name times form)
-       (flet ((definition-name nil (if (and (listp name)
-                                            (memq (car name)
-                                                  '(defmethod defclass class method 
-                                                          method-combination)))
-                                       (format nil "~A~{ ~S~}" (capitalize-words (car name)
-                                                                      nil)
-                                              (cdr name))
-                                       (format nil "~S" name))))
-             (definition-name)
-             (make-progn `',name `(eval-when ,times ,form))))
-
-(defun make-progn (&rest forms)
-       (let ((progn-form nil))
-            (labels ((collect-forms (forms)
-                            (unless (null forms)
-                                (collect-forms (cdr forms))
-                                (if (and (listp (car forms))
-                                         (eq (caar forms)
-                                             'progn))
-                                    (collect-forms (cdar forms))
-                                    (push (car forms)
-                                          progn-form)))))
-                   (collect-forms forms)
-                   (cons 'progn progn-form))))
-
-
-;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed. DEFCLASS always expands
-;;; into a call to LOAD-DEFCLASS.  Until the meta- braid is set up, LOAD-DEFCLASS has a special
-;;; definition which simply collects all class definitions up, when the metabraid is initialized it
-;;; is done from those class definitions. After the metabraid has been setup, and the protocol for
-;;; defining classes has been defined, the real definition of LOAD-DEFCLASS is installed by the file
-;;; defclass.lisp 
-
-
-(defmacro defclass (name direct-superclasses direct-slots &rest options)
-       (declare (indentation 2 4 3 1))
-       (expand-defclass name direct-superclasses direct-slots options))
-
-(defun expand-defclass (name supers slots options)
-       (setq supers (copy-tree supers)
-             slots
-             (copy-tree slots)
-             options
-             (copy-tree options))
-       (let ((metaclass 'standard-class))
-            (dolist (option options)
-                (if (not (listp option))
-                    (error "~S is not a legal defclass option." option)
-                    (when (eq (car option)
-                              ':metaclass)
-                        (unless (legal-class-name-p (cadr option))
-                            (error 
-        "The value of the :metaclass option (~S) is not a~%~
-                      legal class name." (cadr option)))
-                        (setq metaclass (cadr option))
-                        (setf options (remove option options))
-                        (return t))))
-            (let ((*initfunctions* nil)
-                  (*accessors* nil))
-                                                             ; Truly a crock, but we got to have it
-                                                             ; to live nicely. 
-                 (declare (special *initfunctions* *accessors*))
-                 (let ((canonical-slots (mapcar #'(lambda (spec)
-                                                         (canonicalize-slot-specification name spec))
-                                               slots))
-                       (other-initargs (mapcar #'(lambda (option)
-                                                        (canonicalize-defclass-option name option))
-                                              options)))
-                      (do-standard-defsetfs-for-defclass *accessors*)
-;		      (load-defclass name metaclass supers
-;				     canonical-slots (apply #'append
-;							    other-initargs) *accessors*)))))
-                      (make-top-level-form `(defclass ,name nil nil)
-                             *defclass-times*
-                             `(let ,(mapcar #'cdr *initfunctions*)
-                                   (load-defclass ',name ',metaclass ',supers (list 
-                                                                                    ,@canonical-slots
-                                                                                    )
-                                          (list ,@(apply #'append other-initargs))
-                                          ',*accessors*)))))))
-
-(defun make-initfunction (initform)
-       (declare (special *initfunctions*))
-       (cond ((or (eq initform 't)
-                  (equal initform ''t))
-              '#'true)
-             ((or (eq initform 'nil)
-                  (equal initform ''nil))
-              '#'false)
-             ((or (eql initform '0)
-                  (equal initform ''0))
-              '#'zero)
-             (t (let ((entry (assoc initform *initfunctions* :test #'equal)))
-                     (unless entry
-                         (setq entry (list initform (gensym)
-                                           `#'(lambda nil ,initform)))
-                         (push entry *initfunctions*))
-                     (cadr entry)))))
-
-(defun canonicalize-slot-specification (class-name spec)
-       (declare (special *accessors*))
-       (cond ((and (symbolp spec)
-                   (not (keywordp spec))
-                   (not (memq spec '(t nil))))
-              `'(:name ,spec))
-             ((not (consp spec))
-              (error "~S is not a legal slot specification." spec))
-             ((null (cdr spec))
-              `'(:name ,(car spec)))
-             ((null (cddr spec))
-              (error 
-        "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
-                 Convert it to ~S" class-name spec (list (car spec)
-                                                         :initform
-                                                         (cadr spec))))
-             (t (let* ((name (pop spec))
-                       (readers nil)
-                       (writers nil)
-                       (initargs nil)
-                       (unsupplied (list nil))
-                       (initform (getf spec :initform unsupplied)))
-                      (doplist (key val)
-                             spec
-                             (case key
-                                 (:accessor 
-                                    (push val *accessors*)
-                                    (push val readers)
-                                    (push `(setf ,val)
-                                          writers))
-                                 (:reader (push val readers))
-                                 (:writer (push val writers))
-                                 (:initarg (push val initargs))))
-                      (loop (unless (remf spec :accessor)
-                                   (return)))
-                      (loop (unless (remf spec :reader)
-                                   (return)))
-                      (loop (unless (remf spec :writer)
-                                   (return)))
-                      (loop (unless (remf spec :initarg)
-                                   (return)))
-                      (setq spec `(:name ',name :readers ',readers
-				   :writers ',writers :initargs
-                                         ',initargs
-                                         ',spec))
-                      (if (eq initform unsupplied)
-                          `(list* ,@spec)
-                          `(list* :initfunction ,(make-initfunction initform)
-                                  ,@spec))))))
-
-(defun canonicalize-defclass-option (class-name option)
-       (declare (ignore class-name))
-       (case (car option)
-           (:default-initargs (let ((canonical nil))
-                                   (let (key val (tail (cdr option)))
-                                        (loop (when (null tail)
-                                                    (return nil))
-                                              (setq key (pop tail)
-                                                    val
-                                                    (pop tail))
-                                              (push ``(,',key ,,(make-initfunction val)
-                                                             ,',val)
-                                                    canonical))
-                                        `(':direct-default-initargs (list ,@(nreverse canonical))))))
-           (otherwise `(',(car option)
-                        ',(cdr option)))))
-
-
-;;; This is the early definition of load-defclass.  It just collects up all the class definitions in
-;;; a list.  Later, in the file braid1.lisp, these are actually defined. Each entry in
-;;; *early-class-definitions* is an early-class-definition. 
-
-
-(defparameter *early-class-definitions* nil)
-
-(defun make-early-class-definition (name source metaclass superclass-names canonical-slots 
-                                         other-initargs)
-       (list 'early-class-definition name source metaclass superclass-names canonical-slots 
-             other-initargs))
-
-(defun ecd-class-name (ecd)
-       (nth 1 ecd))
-
-(defun ecd-source (ecd)
-       (nth 2 ecd))
-
-(defun ecd-metaclass (ecd)
-       (nth 3 ecd))
-
-(defun ecd-superclass-names (ecd)
-       (nth 4 ecd))
-
-(defun ecd-canonical-slots (ecd)
-       (nth 5 ecd))
-
-(defun ecd-other-initargs (ecd)
-       (nth 6 ecd))
-
-(proclaim '(notinline load-defclass))
-
-(defun load-defclass (name metaclass supers canonical-slots canonical-options accessor-names)
-       (setq supers (copy-tree supers)
-             canonical-slots
-             (copy-tree canonical-slots)
-             canonical-options
-             (copy-tree canonical-options))
-       (do-standard-defsetfs-for-defclass accessor-names)
-       (let ((ecd (make-early-class-definition name (load-truename)
-                         metaclass supers canonical-slots (apply #'append canonical-options)))
-             (existing (find name *early-class-definitions* :key #'ecd-class-name)))
-            (setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*)))
-            ecd))
diff --git a/obsolete/clos/2.0/defcombin.lisp b/obsolete/clos/2.0/defcombin.lisp
deleted file mode 100644
index 5bb69ebd..00000000
--- a/obsolete/clos/2.0/defcombin.lisp
+++ /dev/null
@@ -1,410 +0,0 @@
-;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-
-(in-package 'clos)
-
-;;;
-;;; DEFINE-METHOD-COMBINATION
-;;;
-
-(defmacro define-method-combination (&whole form &rest args)
-  (declare (ignore args))
-  (if (and (cddr form)
-	   (listp (caddr form)))
-      (expand-long-defcombin form)
-      (expand-short-defcombin form)))
-
-
-;;;
-;;; STANDARD method combination
-;;;
-;;; The STANDARD method combination type is implemented directly by the class
-;;; STANDARD-METHOD-COMBINATION.  The method on COMPUTE-EFFECTIVE-METHOD does
-;;; standard method combination directly and is defined by hand in the file
-;;; combin.lisp.  The method for FIND-METHOD-COMBINATION must appear in this
-;;; file for bootstrapping reasons.
-;;;
-;;; A commented out copy of this definition appears in combin.lisp.
-;;; If you change this definition here, be sure to change it there
-;;; also.
-;;;
-(defmethod find-method-combination ((generic-function generic-function)
-				    (type (eql 'standard))
-				    options)
-  (when options
-    (method-combination-error
-      "The method combination type STANDARD accepts no options."))
-  *standard-method-combination*)
-
-
-
-;;;
-;;; short method combinations
-;;;
-;;; Short method combinations all follow the same rule for computing the
-;;; effective method.  So, we just implement that rule once.  Each short
-;;; method combination object just reads the parameters out of the object
-;;; and runs the same rule.
-;;;
-;;;
-(defclass short-method-combination (standard-method-combination)
-     ((operator
-	:reader short-combination-operator
-	:initarg :operator)
-      (identity-with-one-argument
-	:reader short-combination-identity-with-one-argument
-	:initarg :identity-with-one-argument)))
-
-(define-gf-predicate short-method-combination-p short-method-combination)
-
-(defun expand-short-defcombin (whole)
-  (let* ((type (cadr whole))
-	 (documentation
-	   (getf (cddr whole) :documentation ""))
-	 (identity-with-one-arg
-	   (getf (cddr whole) :identity-with-one-argument nil))
-	 (operator 
-	   (getf (cddr whole) :operator type)))
-    (make-top-level-form `(define-method-combination ,type)
-			 '(load eval)
-      `(load-short-defcombin
-	 ',type ',operator ',identity-with-one-arg ',documentation))))
-
-(defun load-short-defcombin (type operator ioa doc)
-  (let* ((truename (load-truename))
-	 (specializers
-	   (list (find-class 'generic-function)
-		 (make-instance 'eql-specializer :object type)
-		 *the-class-t*))
-	 (old-method
-	   (get-method #'find-method-combination () specializers nil))
-	 (new-method nil))
-    (setq new-method
-	  (make-instance 'standard-method
-	    :qualifiers ()
-	    :specializers specializers
-	    :lambda-list '(generic-function type options)
-	    :function #'(lambda (gf type options)
-			  (declare (ignore gf))
-			  (do-short-method-combination
-			    type options operator ioa new-method doc))
-	    :definition-source `((define-method-combination ,type) ,truename)))
-    (when old-method
-      (remove-method #'find-method-combination old-method))
-    (add-method #'find-method-combination new-method)))
-
-(defun do-short-method-combination (type options operator ioa method doc)
-  (cond ((null options) (setq options '(:most-specific-first)))
-	((equal options '(:most-specific-first)))
-	((equal options '(:most-specific-last)))
-	(t
-	 (method-combination-error
-	   "Illegal options to a short method combination type.~%~
-            The method combination type ~S accepts one option which~%~
-            must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
-	   type)))
-  (make-instance 'short-method-combination
-		 :type type
-		 :options options
-		 :operator operator
-		 :identity-with-one-argument ioa
-		 :definition-source method
-		 :documentation doc))
-
-(defmethod compute-effective-method ((generic-function generic-function)
-				     (combin short-method-combination)
-				     applicable-methods)
-  (let ((type (method-combination-type combin))
-	(operator (short-combination-operator combin))
-	(ioa (short-combination-identity-with-one-argument combin))
-	(around ())
-	(primary ()))
-    (dolist (m applicable-methods)
-      (let ((qualifiers (method-qualifiers m)))
-	(flet ((lose (method why)
-		 (invalid-method-error
-		   method
-		   "The method ~S ~A.~%~
-                    The method combination type ~S was defined with the~%~
-                    short form of DEFINE-METHOD-COMBINATION and so requires~%~
-                    all methods have either the single qualifier ~S or the~%~
-                    single qualifier :AROUND."
-		   method why type type)))
-	  (cond ((null qualifiers)
-		 (lose m "has no qualifiers"))
-		((cdr qualifiers)
-		 (lose m "has more than one qualifier"))
-		((eq (car qualifiers) :around)
-		 (push m around))
-		((eq (car qualifiers) type)
-		 (push m primary))
-		(t
-		 (lose m "has an illegal qualifier"))))))
-    (setq around (nreverse around)
-	  primary (nreverse primary))
-    (let ((main-method
-	    (if (and (null (cdr primary))
-		     (not (null ioa)))
-		`(call-method ,(car primary) ())
-		`(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
-				      primary)))))
-      (cond ((null primary)
-	     `(error "No ~S methods for the generic function ~S."
-		     ',type ',generic-function))
-	    ((null around) main-method)
-	    (t
-	     `(call-method ,(car around)
-			   (,@(cdr around) (make-method ,main-method))))))))
-
-
-;;;
-;;; long method combinations
-;;;
-;;;
-
-(defclass long-method-combination (standard-method-combination)
-     ((function :initarg :function
-		:reader long-method-combination-function)))
-
-(defun expand-long-defcombin (form)
-  (let ((type (cadr form))
-	(lambda-list (caddr form))
-	(method-group-specifiers (cadddr form))
-	(body (cddddr form))
-	(arguments-option ())
-	(gf-var nil))
-    (when (and (consp (car body)) (eq (caar body) :arguments))
-      (setq arguments-option (cdr (pop body))))
-    (when (and (consp (car body)) (eq (caar body) :generic-function))
-      (setq gf-var (cadr (pop body))))
-    (multiple-value-bind (documentation function)
-	(make-long-method-combination-function
-	  type lambda-list method-group-specifiers arguments-option gf-var
-	  body)
-      (make-top-level-form `(define-method-combination ,type)
-			   '(load eval)
-	`(load-long-defcombin ',type ',documentation #',function)))))
-
-(defvar *long-method-combination-functions* (make-hash-table :test #'eq))
-
-(defun load-long-defcombin (type doc function)
-  (let* ((specializers
-	   (list (find-class 'generic-function)
-		 (make-instance 'eql-specializer :object type)
-		 *the-class-t*))
-	 (old-method
-	   (get-method #'find-method-combination () specializers nil))
-	 (new-method
-	   (make-instance 'standard-method
-	     :qualifiers ()
-	     :specializers specializers
-	     :lambda-list '(generic-function type options)
-	     :function #'(lambda (generic-function type options)
-			   (declare (ignore generic-function))
-			   (make-instance 'long-method-combination
-			     :type type
-			     :documentation doc
-			     :options options))
-	     :definition-source `((define-method-combination ,type)
-				  ,(load-truename)))))
-    (setf (gethash type *long-method-combination-functions*) function)
-    (when old-method (remove-method #'find-method-combination old-method))
-    (add-method #'find-method-combination new-method)))
-
-(defmethod compute-effective-method ((generic-function generic-function)
-				     (combin long-method-combination)
-				     applicable-methods)
-  (funcall (gethash (method-combination-type combin)
-		    *long-method-combination-functions*)
-	   generic-function
-	   combin
-	   applicable-methods))
-
-;;;
-;;;
-;;;
-(defun make-long-method-combination-function
-       (type ll method-group-specifiers arguments-option gf-var body)
-  (declare (ignore type) (values documentation function))
-  (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations body)
-
-    (let ((wrapped-body
-	    (wrap-method-group-specifier-bindings method-group-specifiers
-						  declarations
-						  real-body)))
-      (when gf-var
-	(push `(,gf-var .generic-function.) (cadr wrapped-body)))
-      
-      (when arguments-option
-	(setq wrapped-body (deal-with-arguments-option wrapped-body
-						       arguments-option)))
-
-      (when ll
-	(setq wrapped-body
-	      `(apply #'(lambda ,ll ,wrapped-body)
-		      (method-combination-options .method-combination.))))
-
-      (values
-	documentation
-	`(lambda (.generic-function. .method-combination. .applicable-methods.)
-	   (progn .generic-function. .method-combination. .applicable-methods.)
-	   (block .long-method-combination-function. ,wrapped-body))))))
-;;
-;; parse-method-group-specifiers parse the method-group-specifiers
-;;
-
-(defun wrap-method-group-specifier-bindings
-       (method-group-specifiers declarations real-body)
-  (with-gathering ((names (collecting))
-		   (specializer-caches (collecting))
-		   (cond-clauses (collecting))
-		   (required-checks (collecting))
-		   (order-cleanups (collecting)))
-      (dolist (method-group-specifier method-group-specifiers)
-	(multiple-value-bind (name tests description order required)
-	    (parse-method-group-specifier method-group-specifier)
-	  (declare (ignore description))
-	  (let ((specializer-cache (gensym)))
-	    (gather name names)
-	    (gather specializer-cache specializer-caches)
-	    (gather `((or ,@tests)
-		      (if  (equal ,specializer-cache .specializers.)
-			   (return-from .long-method-combination-function.
-			     '(error "More than one method of type ~S ~
-                                      with the same specializers."
-				     ',name))
-			   (setq ,specializer-cache .specializers.))
-		      (push .method. ,name))
-		    cond-clauses)
-	    (when required
-	      (gather `(when (null ,name)
-			 (return-from .long-method-combination-function.
-			   '(error "No ~S methods." ',name)))
-		      required-checks))
-	    (loop (unless (and (constantp order)
-			       (neq order (setq order (eval order))))
-		    (return t)))
-	    (gather (cond ((eq order :most-specific-first)
-			   `(setq ,name (nreverse ,name)))
-			  ((eq order :most-specific-last) ())
-			  (t
-			   `(ecase ,order
-			      (:most-specific-first
-				(setq ,name (nreverse ,name)))
-			      (:most-specific-last))))
-		    order-cleanups))))
-   `(let (,@names ,@specializer-caches)
-      ,@declarations
-      (dolist (.method. .applicable-methods.)
-	(let ((.qualifiers. (method-qualifiers .method.))
-	      (.specializers. (method-specializers .method.)))
-	  (progn .qualifiers. .specializers.)
-	  (cond ,@cond-clauses)))
-      ,@required-checks
-      ,@order-cleanups
-      ,@real-body)))
-   
-(defun parse-method-group-specifier (method-group-specifier)
-  (declare (values name tests description order required))
-  (let* ((name (pop method-group-specifier))
-	 (patterns ())
-	 (tests 
-	   (gathering1 (collecting)
-	     (block collect-tests
-	       (loop
-		 (if (or (null method-group-specifier)
-			 (memq (car method-group-specifier)
-			       '(:description :order :required)))
-		     (return-from collect-tests t)
-		     (let ((pattern (pop method-group-specifier)))
-		       (push pattern patterns)
-		       (gather1 (parse-qualifier-pattern name pattern)))))))))
-    (values name
-	    tests
-	    (getf method-group-specifier :description
-		  (make-default-method-group-description patterns))
-	    (getf method-group-specifier :order :most-specific-first)
-	    (getf method-group-specifier :required nil))))
-
-(defun parse-qualifier-pattern (name pattern)
-  (cond ((eq pattern '()) `(null .qualifiers.))
-	((eq pattern '*) 't)
-	((symbolp pattern) `(,pattern .qualifiers.))
-	((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
-	(t (error "In the method group specifier ~S,~%~
-                   ~S isn't a valid qualifier pattern."
-		  name pattern))))
-
-(defun qualifier-check-runtime (pattern qualifiers)
-  (loop (cond ((and (null pattern) (null qualifiers))
-	       (return t))
-	      ((eq pattern '*) (return t))
-	      ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
-	       (pop pattern)
-	       (pop qualifiers))	      
-	      (t (return nil)))))
-
-(defun make-default-method-group-description (patterns)
-  (if (cdr patterns)
-      (format nil
-	      "methods matching one of the patterns: ~{~S, ~} ~S"
-	      (butlast patterns) (car (last patterns)))
-      (format nil
-	      "methods matching the pattern: ~S"
-	      (car patterns))))
-
-
-
-;;;
-;;; This baby is a complete mess.  I can't believe we put it in this
-;;; way.  No doubt this is a large part of what drives MLY crazy.
-;;;
-;;; At runtime (when the effective-method is run), we bind an intercept
-;;; lambda-list to the arguments to the generic function.
-;;; 
-;;; At compute-effective-method time, the symbols in the :arguments
-;;; option are bound to the symbols in the intercept lambda list.
-;;;
-(defun deal-with-arguments-option (wrapped-body arguments-option)
-  (let* ((intercept-lambda-list
-	   (gathering1 (collecting)
-	     (dolist (arg arguments-option)
-	       (if (memq arg lambda-list-keywords)
-		   (gather1 arg)
-		   (gather1 (gensym))))))
-	 (intercept-rebindings
-	   (gathering1 (collecting)
-	     (iterate ((arg (list-elements arguments-option))
-		       (int (list-elements intercept-lambda-list)))
-	       (unless (memq arg lambda-list-keywords)
-		 (gather1 `(,arg ',int)))))))
-    ;;
-    ;;
-    (setf (cadr wrapped-body)
-	  (append intercept-rebindings (cadr wrapped-body)))
-    ;;
-    ;; Be sure to fill out the intercept lambda list so that it can
-    ;; be too short if it wants to.
-    ;; 
-    (cond ((memq '&rest intercept-lambda-list))
-	  ((memq '&allow-other-keys intercept-lambda-list))
-	  ((memq '&key intercept-lambda-list)
-	   (setq intercept-lambda-list
-		 (append intercept-lambda-list '(&allow-other-keys))))
-	  (t
-	   (setq intercept-lambda-list
-		 (append intercept-lambda-list '(&rest .ignore.)))))
-
-    `(let ((inner-result. ,wrapped-body))
-       `(apply #'(lambda ,',intercept-lambda-list
-		   ,,(when (memq '.ignore. intercept-lambda-list)
-		       ''(declare (ignore .ignore.)))
-		   ,inner-result.)
-	       .combined-method-args.))))
-
diff --git a/obsolete/clos/2.0/defs.lisp b/obsolete/clos/2.0/defs.lisp
deleted file mode 100644
index e0f2a047..00000000
--- a/obsolete/clos/2.0/defs.lisp
+++ /dev/null
@@ -1,570 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-;;;. Copyright (c) 1991 by Venue
-
-
-(in-package "CLOS")
-
-(eval-when (compile load eval)
-       (defvar *defclass-times* '(load eval compile))	;Probably have to change this
-						;if you use defconstructor.
-(defvar *defmethod-times*  '(load eval compile))
-(defvar *defgeneric-times* '(load eval compile))
-)
-
-
-;;; Convert a function name to its standard setf function name.  We have to do this hack because not
-;;; all Common Lisps have yet converted to having setf function specs. In a port that does have setf
-;;; function specs you can use those just by making the obvious simple changes to these functions. 
-;;; The rest of CLOS believes that there are function names like (SETF <foo>), this is the only place
-;;; that knows about this hack. 
-
-
-(eval-when (compile load eval)
-       (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
-(defun get-setf-function-name (name)
-  (or (gethash name *setf-function-names*)
-      (setf (gethash name *setf-function-names*)
-	    (intern (format nil
-			    "SETF ~A ~A"
-			    (package-name (symbol-package name))
-			    (symbol-name name))
-		    *the-clos-package*))))
-
-;;;
-;;; Call this to define a setf macro for a function with the same behavior as
-;;; specified by the SETF function cleanup proposal.  Specifically, this will
-;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
-;;;
-;;; do-standard-defsetf                  A macro interface for use at top level
-;;;                                      in files.  Unfortunately, users may
-;;;                                      have to use this for a while.
-;;;                                      
-;;; do-standard-defsetfs-for-defclass    A special version called by defclass.
-;;; 
-;;; do-standard-defsetf-1                A functional interface called by the
-;;;                                      above, defmethod and defgeneric.
-;;;                                      Since this is all a crock anyways,
-;;;                                      users are free to call this as well.
-;;;
-(defmacro do-standard-defsetf (&rest function-names)
-  `(eval-when (compile load eval)
-     (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
-
-(defun do-standard-defsetfs-for-defclass (accessors)
-  (dolist (name accessors) (do-standard-defsetf-1 name)))
-
-(defun do-standard-defsetf-1 (function-name)
-  (unless (setfboundp function-name)
-    (let* ((setf-function-name (get-setf-function-name function-name)))
-    
-  (flet ((setf-expander (body env)
-	       (declare (ignore env))
-	       (let ((temps
-		       (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
-			       (cdr body)))
-		     (forms (cdr body))
-		     (vars (list (gensym))))
-		 (values temps
-			 forms
-			 vars
-			 `(,setf-function-name ,@vars ,@temps)
-			 `(,function-name ,@temps)))))
-	(let ((setf-method-expander (intern (concatenate 'string
-						         (symbol-name function-name)
-						         "-setf-expander")
-				     (symbol-package function-name))))
-	  (setf (get function-name :setf-method-expander) setf-method-expander
-		(symbol-function setf-method-expander) #'setf-expander)))
-
-     )))
-(defun setfboundp (symbol)
-(or (get symbol :setf-inverse)
-	       (get symbol 'il:setf-inverse)
-	       (get symbol 'il:setfn)
-	       (get symbol :shared-setf-inverse)
-	       (get symbol :setf-method-expander)
-	       (get symbol 'il:setf-method-expander)))
-)
-
-                                                             ; eval-when
-
-
-
-;;; CLOS, like user code, must endure the fact that we don't have a properly working setf.  Many
-;;; things work because they get mentioned by a defclass or defmethod before they are used, but
-;;; others have to be done by hand. 
-
-
-(do-standard-defsetf 
-	class-wrapper                           ; ***
-     generic-function-name 
-	method-function-plist 
-	method-function-get 
-	gdefinition 
-     slot-value-using-class)
-
-(defsetf slot-value set-slot-value)
-
-
-;;; This is like fdefinition on the Lispm.  If Common Lisp had something like function specs I
-;;; wouldn't need this.  On the other hand, I don't like the way this really works so maybe function
-;;; specs aren't really right either? I also don't understand the real implications of a Lisp-1 on
-;;; this sort of thing.  Certainly some of the lossage in all of this is because these SPECs name
-;;; global definitions. Note that this implementation is set up so that an implementation which has
-;;; a 'real' function spec mechanism can use that instead and in that way get rid of setf generic
-;;; function names. 
-
-
-(defmacro parse-gspec (spec (non-setf-var . non-setf-case)
-                            (setf-var . setf-case))
-              (once-only (spec)
-              `(cond ((symbolp ,spec)
-                      (let ((,non-setf-var ,spec))
-                           ,@non-setf-case))
-                     ((and (listp ,spec)
-                           (eq (car ,spec)
-                               'setf)
-                           (symbolp (cadr ,spec)))
-                      (let ((,setf-var (cadr ,spec)))
-                           ,@setf-case))
-                     (t (error "Can't understand ~S as a generic function specifier.~%~
-               It must be either a symbol which can name a function or~%~
-               a list like ~S, where the car is the symbol ~S and the cadr~%~
-               is a symbol which can name a generic function." ,spec '(setf <foo>)
-                               'setf)))))
-
-
-;;; If symbol names a function which is traced or advised, return the unadvised, traced etc.
-;;; definition.  This lets me get at the generic function object even when it is traced. 
-
-
-(defun unencapsulated-fdefinition (symbol)
-       (il:virginfn symbol))
-
-
-;;; If symbol names a function which is traced or advised, redefine the `real' definition without
-;;; affecting the advise. 
-
-
-(defun fdefine-carefully (symbol new-definition)
-       (let ((advisedp (member symbol il:advisedfns :test #'eq))
-             (brokenp (member symbol il:brokenfns :test #'eq)))
-            
-            ;; In XeroxLisp (late of envos) tracing is implemented as a special case of "breaking". 
-            ;; Advising, however, is treated specially. 
-            (xcl:unadvise-function symbol :no-error t)
-            (xcl:unbreak-function symbol :no-error t)
-            (setf (symbol-function symbol)
-                  new-definition)
-            (when brokenp (xcl:rebreak-function symbol))
-            (when advisedp (xcl:readvise-function symbol)))
-       new-definition)
-
-(defun gboundp (spec)
-       (parse-gspec spec (name (fboundp name))
-              (name (fboundp (get-setf-function-name name)))))
-
-(defun gmakunbound (spec)
-       (parse-gspec spec (name (fmakunbound name))
-              (name (fmakunbound (get-setf-function-name name)))))
-
-(defun gdefinition (spec)
-       (parse-gspec spec (name (or (macro-function name)
-                                                             ; ??
-                                   (unencapsulated-fdefinition name)))
-              (name (unencapsulated-fdefinition (get-setf-function-name name)))))
-
-(defun SETF\ CLOS\ GDEFINITION (new-value spec)
-       (parse-gspec spec (name (fdefine-carefully name new-value))
-              (name (fdefine-carefully (get-setf-function-name name)
-                           new-value))))
-
-
-;;; These functions are a pale imitiation of their namesake.  They accept class objects or types
-;;; where they should. 
-
-
-(defun *typep (object type)
-       (if (classp type)
-           (let ((class (class-of object)))
-                (if class
-                    (memq type (class-precedence-list class))
-                    nil))
-           (let ((class (find-class type nil)))
-                (if class
-                    (*typep object class)
-                    (typep object type)))))
-
-(defun *subtypep (type1 type2)
-       (let ((c1 (if (classp type1)
-                     type1
-                     (find-class type1 nil)))
-             (c2 (if (classp type2)
-                     type2
-                     (find-class type2 nil))))
-            (if (and c1 c2)
-                (memq c2 (class-precedence-list c1))
-                (if (or c1 c2)
-                    nil
-                                                             ; This isn't quite right, but...
-                    (subtypep type1 type2)))))
-
-(defun do-satisfies-deftype (name predicate)
-       (let* ((specifier `(satisfies ,predicate))
-              (expand-fn #'(lambda (&rest ignore)
-                                  (declare (ignore ignore))
-                                  specifier)))
-             
-             ;; Specific ports can insert their own way of doing this.  Many ports may find the
-             ;; expand-fn defined above useful. 
-             (or 
-                 ;; This is the default for ports for which we don't know any better.  Note that for
-                 ;; most ports, providing this definition should just speed up class definition.  It
-                 ;; shouldn't have an effect on performance of most user code. 
-                 (eval `(deftype ,name nil '(satisfies ,predicate))))))
-
-(defun make-type-predicate-name (name)
-       (intern (format nil "TYPE-PREDICATE ~A ~A" (package-name (symbol-package name))
-                      (symbol-name name))
-              *the-clos-package*))
-
-(proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string* 
-                  *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* 
-                  *the-class-null* *the-class-list* *the-class-integer* *the-class-float* 
-                  *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* 
-                  *the-class-array* *the-class-standard-object* *the-class-class* *the-class-method*
-                  *the-class-generic-function* *the-class-standard-class* *the-class-standard-method*
-                  *the-class-standard-generic-function* 
-                  *the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots*))
-
-(proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* 
-                  *the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational* 
-                  *the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null* 
-                  *the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float* 
-                  *the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character* 
-                  *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
-
-(defvar *built-in-class-symbols* nil)
-
-(defvar *built-in-wrapper-symbols* nil)
-
-(defun get-built-in-class-symbol (class-name)
-       (or (cadr (assq class-name *built-in-class-symbols*))
-           (let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name))
-                                *the-clos-package*)))
-                (push (list class-name symbol)
-                      *built-in-class-symbols*)
-                symbol)))
-
-(defun get-built-in-wrapper-symbol (class-name)
-       (or (cadr (assq class-name *built-in-wrapper-symbols*))
-           (let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name))
-                                *the-clos-package*)))
-                (push (list class-name symbol)
-                      *built-in-wrapper-symbols*)
-                symbol)))
-
-(pushnew 'class *variable-declarations*)
-
-(pushnew 'variable-rebinding *variable-declarations*)
-
-(defun variable-class (var env)
-       (caddr (variable-declaration 'class var env)))
-
-(defvar *boot-state* nil)
-                                                             ; NIL EARLY BRAID COMPLETE 
-
-
-(eval-when (load eval)
-       (when (eq *boot-state* 'complete)
-             (error "Trying to load (or compile) CLOS in an environment in which it~%~
-            has already been loaded.  This doesn't work, you will have to~%~
-            get a fresh lisp (reboot) and then load CLOS."))
-       (when *boot-state* (cerror "Try loading (or compiling) CLOS anyways." "Trying to load (or compile) CLOS in an environment in which it~%~
-             has already been partially loaded.  This may not work, you may~%~
-             need to get a fresh lisp (reboot) and then load CLOS.")))
-
-
-;;; This is used by combined methods to communicate the next methods to the methods they call.  This
-;;; variable is captured by a lexical variable of the methods to give it the proper lexical scope. 
-
-
-(defvar *next-methods* nil)
-
-(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
-
-(defvar *umi-gfs*)
-
-(defvar *umi-complete-classes*)
-
-(defvar *umi-reorder*)
-
-(defvar *invalidate-discriminating-function-force-p* nil)
-
-(defvar *invalid-dfuns-on-stack* nil)
-
-(defvar *standard-method-combination*)
-
-(defvar *slotd-unsupplied* (list '*slotd-unsupplied*))
-
-                                                             ; ***
-
-
-(defmacro define-gf-predicate (predicate &rest classes)
-       `(progn (defmethod ,predicate ((x t))
-                      nil)
-               ,@(mapcar #'(lambda (c)
-                                  `(defmethod ,predicate ((x ,c))
-                                          t))
-                        classes)))
-
-(defmacro plist-value (object name)
-       `(with-slots (plist)
-               ,object
-               (getf plist ,name)))
-
-(defsetf plist-value (object name)
-       (new-value)
-       (once-only (new-value)
-              `(with-slots (plist)
-                      ,object
-                      (if ,new-value
-                          (setf (getf plist ,name)
-                                ,new-value)
-                          (progn (remf plist ,name)
-                                 nil)))))
-
-(defvar *built-in-classes* 
-
-       ;; name       supers     subs                     cdr of cpl 
-       '((number (t) (complex float rational)
-                (t))
-         (complex (number)
-                nil
-                (number t))
-         (float (number)
-                nil
-                (number t))
-         (rational (number)
-                (integer ratio)
-                (number t))
-         (integer (rational)
-                nil
-                (rational number t))
-         (ratio (rational)
-                nil
-                (rational number t))
-         (sequence (t)
-                (list vector)
-                (t))
-         (list (sequence)
-               (cons null)
-               (sequence t))
-         (cons (list)
-               nil
-               (list sequence t))
-         (array (t)
-                (vector)
-                (t))
-         (vector (array sequence)
-                (string bit-vector)
-                (array sequence t))
-         (string (vector)
-                nil
-                (vector array sequence t))
-         (bit-vector (vector)
-                nil
-                (vector array sequence t))
-         (character (t)
-                nil
-                (t))
-         (symbol (t)
-                (null)
-                (t))
-         (null (symbol)
-               nil
-               (symbol list sequence t))))
-
-
-;;; The classes that define the kernel of the metabraid. 
-
-
-(defclass t nil nil (:metaclass built-in-class))
-
-(defclass standard-object (t)
-       nil)
-
-(defclass metaobject (standard-object)
-       nil)
-
-(defclass specializer (metaobject)
-       nil)
-
-(defclass definition-source-mixin (standard-object)
-       ((source :initform (load-truename)
-               :reader definition-source :initarg :definition-source)))
-
-(defclass plist-mixin (standard-object)
-       ((plist :initform nil)))
-
-(defclass documentation-mixin (plist-mixin)
-       nil)
-
-(defclass dependent-update-mixin (plist-mixin)
-       nil)
-
-
-;;; The class CLASS is a specified basic class.  It is the common superclass of any kind of class. 
-;;; That is any class that can be a metaclass must have the class CLASS in its class precedence
-;;; list. 
-
-
-(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer)
-       ((name :initform nil :initarg :name :accessor class-name)
-        (direct-superclasses :initform nil :reader class-direct-superclasses)
-        (direct-subclasses :initform nil :reader class-direct-subclasses)
-        (direct-methods :initform (cons nil nil))))
-
-
-;;; The class CLOS-CLASS is an implementation-specific common superclass of all specified subclasses
-;;; of the class CLASS. 
-
-
-(defclass clos-class (class)
-       ((class-precedence-list :initform nil)
-        (wrapper :initform nil)))
-
-
-;;; The class STD-CLASS is an implementation-specific common superclass of the classes
-;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. 
-
-
-(defclass std-class (clos-class)
-       ((direct-slots :initform nil :accessor class-direct-slots)
-        (slots :initform nil :accessor class-slots)
-        (no-of-instance-slots                                ; *** MOVE TO WRAPPER ***
-               :initform 0 :accessor class-no-of-instance-slots)
-        (prototype :initform nil)))
-
-(defclass standard-class (std-class)
-       nil)
-
-(defclass funcallable-standard-class (std-class)
-       nil)
-
-(defclass forward-referenced-class (clos-class)
-       nil)
-
-(defclass built-in-class (clos-class)
-       nil)
-
-
-;;; Slot definitions. Note that throughout CLOS, "SLOT-DEFINITION" is abbreviated as "SLOTD". 
-
-
-(defclass slot-definition (metaobject)
-       nil)
-
-(defclass direct-slot-definition (slot-definition)
-       nil)
-
-(defclass effective-slot-definition (slot-definition)
-       nil)
-;
-(defclass standard-slot-definition (slot-definition)
-       ((name :initform nil :accessor slotd-name)
-        (initform :initform *slotd-unsupplied* :accessor slotd-initform)
-        (initfunction :initform *slotd-unsupplied* :accessor slotd-initfunction)
-        (readers :initform nil :accessor slotd-readers)
-        (writers :initform nil :accessor slotd-writers)
-        (initargs :initform nil :accessor slotd-initargs)
-        (allocation :initform nil :accessor slotd-allocation)
-        (type :initform nil :accessor slotd-type)
-        (documentation :initform "" :initarg :documentation)
-        (class :initform nil :accessor slotd-class)
-        (instance-index :initform nil :accessor slotd-instance-index)))
-
-(defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition)
-       nil)
-
-                                                             ; Adding slots here may involve extra
-                                                             ; work to the code in braid.lisp 
-
-
-(defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition)
-       nil)
-
-                                                             ; Adding slots here may involve extra
-                                                             ; work to the code in braid.lisp 
-
-
-(defclass eql-specializer (specializer)
-       ((object :initarg :object :reader eql-specializer-object)))
-
-
-;;; 
-
-
-(defmacro dolist-carefully ((var list improper-list-handler)
-                            &body body)
-       `(let ((,var nil)
-              (.dolist-carefully. ,list))
-             (loop (when (null .dolist-carefully.)
-                         (return nil))
-                   (if (consp .dolist-carefully.)
-                       (progn (setq ,var (pop .dolist-carefully.))
-                              ,@body)
-                       (,improper-list-handler)))))
-
-(defun legal-std-documentation-p (x)
-       (if (or (null x)
-               (stringp x))
-           t
-           "a string or NULL"))
-
-(defun legal-std-lambda-list-p (x)
-       (declare (ignore x))
-       t)
-
-(defun legal-std-method-function-p (x)
-       (if (functionp x)
-           t
-           "a function"))
-
-(defun legal-std-qualifiers-p (x)
-       (flet ((improper-list nil (return-from legal-std-qualifiers-p "Is not a proper list.")))
-             (dolist-carefully (q x improper-list)
-                    (let ((ok (legal-std-qualifier-p q)))
-                         (unless (eq ok t)
-                             (return-from legal-std-qualifiers-p (format nil "Contains ~S which ~A" q
-                                                                        ok)))))
-             t))
-
-(defun legal-std-qualifier-p (x)
-       (if (and x (atom x))
-           t
-           "is not a non-null atom"))
-
-(defun legal-std-slot-name-p (x)
-       (cond ((not (symbolp x))
-              "is not a symbol and so cannot be bound")
-             ((keywordp x)
-              "is a keyword and so cannot be bound")
-             ((memq x '(t nil))
-              "cannot be bound")
-             (t t)))
-
-(defun legal-std-specializers-p (x)
-       (flet ((improper-list nil (return-from legal-std-specializers-p "Is not a proper list.")))
-             (dolist-carefully (s x improper-list)
-                    (let ((ok (legal-std-specializer-p s)))
-                         (unless (eq ok t)
-                             (return-from legal-std-specializers-p (format nil "Contains ~S which ~A"
-                                                                          s ok)))))
-             t))
-
-(defun legal-std-specializer-p (x)
-       (if (or (classp x)
-               (eql-specializer-p x))
-           t
-           "is neither a class object nor an eql specializer"))
diff --git a/obsolete/clos/2.0/defsys.lisp b/obsolete/clos/2.0/defsys.lisp
deleted file mode 100644
index c8a5f6f7..00000000
--- a/obsolete/clos/2.0/defsys.lisp
+++ /dev/null
@@ -1,757 +0,0 @@
-;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-;;; Some support stuff for compiling and loading CLOS.  It would be nice if
-;;; there was some portable make-system we could all agree to share for a
-;;; while.  At least until people really get databases and stuff.
-;;;
-;;; ***                                                               ***
-;;; ***        DIRECTIONS FOR INSTALLING CLOS AT YOUR SITE             ***
-;;; ***                                                               ***
-;;;
-;;; To get CLOS working at your site you should:
-;;; 
-;;;  - Get all the CLOS source files from Xerox.  The complete list of source
-;;;    file names can be found in the defsystem for CLOS which appears towards
-;;;    the end of this file.
-;;; 
-;;;  - Edit the variable *clos-directory* below to specify the directory at
-;;;    your site where the clos sources and binaries will be.  This variable
-;;;    can be found by searching from this point for the string "***" in
-;;;    this file.
-;;; 
-;;;  - Use the function (clos::compile-clos) to compile CLOS for your site.
-;;; 
-;;;  - Once CLOS has been compiled it can be loaded with (clos::load-clos).
-;;;    Note that CLOS cannot be loaded on top of itself, nor can it be
-;;;    loaded into the same world it was compiled in.
-;;;
-
-(in-package "CLOS" :use (list (or (find-package :walker)
-				 (make-package :walker :use '(:lisp)))
-			     (or (find-package :iterate)
-				 (make-package :iterate
-					       :use '(:lisp :walker)))
-			     (find-package :lisp)))
-
-(export (intern (symbol-name :iterate)		;Have to do this here,
-		(find-package :iterate))	;because in the defsystem
-	(find-package :iterate))		;(later in this file)
-						;we use the symbol iterate
-						;to name the file
-
-;;;
-;;; Sure, its weird for this to be here, but in order to follow the rules
-;;; about order of export and all that stuff, we can't put it in PKG before
-;;; we want to use it.
-;;; 
-(defvar *the-clos-package* (find-package :clos))
-
-(defvar *clos-system-date* "5/10/91 Interim CLOS release")
-
-
-;;;
-;;; Various hacks to get people's *features* into better shape.
-;;; 
-(eval-when (compile load eval)
-  #+(and Symbolics Lispm)
-  (multiple-value-bind (major minor) (sct:get-release-version)
-    (etypecase minor
-      (integer)
-      (string (setf minor (parse-integer minor :junk-allowed t))))
-    (pushnew :genera *features*)
-    (ecase major
-      ((6)
-       (pushnew :genera-release-6 *features*))
-      ((7)
-       (pushnew :genera-release-7 *features*)
-       (ecase minor
-	 ((0 1) (pushnew :genera-release-7-1 *features*))
-	 ((2)   (pushnew :genera-release-7-2  *features*))
-	 ((3)   (pushnew :genera-release-7-3  *features*))
-	 ((4)   (pushnew :genera-release-7-4  *features*))))
-      ((8)
-       (pushnew :genera-release-8 *features*)
-       (ecase minor
-	 ((0) (pushnew :genera-release-8-0 *features*))
-	 ((1) (pushnew :genera-release-8-1 *features*))))))
-  
-  #+CLOE-Runtime
-  (let ((version (lisp-implementation-version)))
-    (when (string-equal version "2.0" :end1 (min 3 (length version)))
-      (pushnew :cloe-release-2 *features*)))
-
-  (dolist (feature *features*)
-    (when (and (symbolp feature)                ;3600!!
-               (equal (symbol-name feature) "CMU"))
-      (pushnew :CMU *features*)))
-  
-  #+TI
-  (if (eq (si:local-binary-file-type) :xld)
-      (pushnew ':ti-release-3 *features*)
-      (pushnew ':ti-release-2 *features*))
-
-  #+Lucid
-  (when (search "IBM RT PC" (machine-type))
-    (pushnew :ibm-rt-pc *features*))
-
-  #+ExCL
-  (cond ((search "sun3" (lisp-implementation-version))
-	 (push :sun3 *features*))
-	((search "sun4" (lisp-implementation-version))
-	 (push :sun4 *features*)))
-
-  #+(and HP Lucid)
-  (push :HP-Lucid *features*)
-  #+(and HP (not Lucid))
-  (push :HP-HPLabs *features*)
-
-  #+Xerox
-  (case il:makesysname
-    (:lyric (push :Xerox-Lyric *features*))
-    (otherwise (pushnew :Xerox-Medley *features*)))
-;;;
-;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features*
-;;; if you have installed turbo-closure patch.  See the file kcl-mods.text
-;;; for details.
-;;;
-;;; The xkcl version of KCL has this fixed already.
-;;; 
-
-  #+xkcl(pushnew :turbo-closure *features*)
-
-  )
-
-
-
-;;; Yet Another Sort Of General System Facility and friends.
-;;;
-;;; The entry points are defsystem and operate-on-system.  defsystem is used
-;;; to define a new system and the files with their load/compile constraints.
-;;; Operate-on-system is used to operate on a system defined that has been
-;;; defined by defsystem.  For example:
-#||
-
-(defsystem my-very-own-system
-	   "/usr/myname/lisp/"
-  ((classes   (precom)           ()                ())
-   (methods   (precom classes)   (classes)         ())
-   (precom    ()                 (classes methods) (classes methods))))
-
-This defsystem should be read as follows:
-
-* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries
-  should be in the directory "/usr/me/lisp/".  There are three files
-  in the system, there are named classes, methods and precom.  (The
-  extension the filenames have depends on the lisp you are running in.)
-  
-* For the first file, classes, the (precom) in the line means that
-  the file precom should be loaded before this file is loaded.  The
-  first () means that no other files need to be loaded before this
-  file is compiled.  The second () means that changes in other files
-  don't force this file to be recompiled.
-
-* For the second file, methods, the (precom classes) means that both
-  of the files precom and classes must be loaded before this file
-  can be loaded.  The (classes) means that the file classes must be
-  loaded before this file can be compiled.  The () means that changes
-  in other files don't force this file to be recompiled.
-
-* For the third file, precom, the first () means that no other files
-  need to be loaded before this file is loaded.  The first use of
-  (classes methods)  means that both classes and methods must be
-  loaded before this file can be compiled.  The second use of (classes
-  methods) mean that whenever either classes or methods changes precom
-  must be recompiled.
-
-Then you can compile your system with:
-
- (operate-on-system 'my-very-own-system :compile)
-
-and load your system with:
-
- (operate-on-system 'my-very-own-system :load)
-
-||#
-
-;;; 
-(defvar *system-directory*)
-
-;;;
-;;; *port* is a list of symbols (in the CLOS package) which represent the
-;;; Common Lisp in which we are now running.  Many of the facilities in
-;;; defsys use the value of *port* rather than #+ and #- to conditionalize
-;;; the way they work.
-;;; 
-(defvar *port*
-        '(#+Genera               Genera
-;         #+Genera-Release-6     Rel-6
-;         #+Genera-Release-7-1   Rel-7
-          #+Genera-Release-7-2   Rel-7
-	  #+Genera-Release-7-3   Rel-7
-          #+Genera-Release-7-1   Rel-7-1
-          #+Genera-Release-7-2   Rel-7-2
-	  #+Genera-Release-7-3   Rel-7-2	;OK for now
-	  #+Genera-Release-7-4   Rel-7-2	;OK for now
-	  #+Genera-Release-8	 Rel-8
-	  #+imach                Ivory
-	  #+Cloe-Runtime	 Cloe
-          #+Lucid                Lucid
-          #+Xerox                Xerox
-	  #+Xerox-Lyric          Xerox-Lyric
-	  #+Xerox-Medley         Xerox-Medley
-          #+TI                   TI
-          #+(and dec vax common) Vaxlisp
-          #+KCL                  KCL
-          #+IBCL                 IBCL
-          #+excl                 excl
-	  #+(and excl sun4)      excl-sun4
-          #+:CMU                 CMU
-          #+HP-HPLabs            HP-HPLabs
-          #+:gclisp              gclisp
-          #+pyramid              pyramid
-          #+:coral               coral))
-
-;;;
-;;; When you get a copy of CLOS (by tape or by FTP), the sources files will
-;;; have extensions of ".lisp" in particular, this file will be defsys.lisp.
-;;; The preferred way to install clos is to rename these files to have the
-;;; extension which your lisp likes to use for its files.  Alternately, it
-;;; is possible not to rename the files.  If the files are not renamed to
-;;; the proper convention, the second line of the following defvar should
-;;; be changed to:
-;;;     (let ((files-renamed-p nil)
-;;;
-;;; Note: Something people installing CLOS on a machine running Unix
-;;;       might find useful.  If you want to change the extensions
-;;;       of the source files from ".lisp" to ".lsp", *all* you have
-;;;       to do is the following:
-;;;
-;;;       % foreach i (*.lisp)
-;;;       ? mv $i $i:r.lsp
-;;;       ? end
-;;;       %
-;;;
-;;;       I am sure that a lot of people already know that, and some
-;;;       Unix hackers may say, "jeez who doesn't know that".  Those
-;;;       same Unix hackers are invited to fix mv so that I can type
-;;;       "mv *.lisp *.lsp".
-;;;
-(defvar *pathname-extensions*
-  (let ((files-renamed-p t)
-        (proper-extensions
-          (car
-           '(#+(and Genera (not imach))          ("lisp"  . "bin")
-	     #+(and Genera imach)                ("lisp"  . "ibin")
-	     #+Cloe-Runtime			 ("l"	  . "fasl")
-             #+(and dec common vax (not ultrix)) ("LSP"   . "FAS")
-             #+(and dec common vax ultrix)       ("lsp"   . "fas")
-             #+KCL                               ("lsp"   . "o")
-             #+IBCL                              ("lsp"   . "o")
-             #+Xerox                             ("lisp"  . "dfasl")
-             #+(and Lucid MC68000)               ("lisp"  . "lbin")
-             #+(and Lucid VAX)                   ("lisp"  . "vbin")
-             #+(and Lucid Prime)                 ("lisp"  . "pbin")
-	     #+(and Lucid SUNRise)               ("lisp"  . "sbin")
-	     #+(and Lucid SPARC)                 ("lisp"  . "sbin")
-             #+(and Lucid IBM-RT-PC)             ("lisp"  . "bbin")
-             #+(and Lucid MIPS)                  ("lisp"  . "mbin")
-             #+(and Lucid PRISM)                 ("lisp"  . "abin")
-             #+(and Lucid PA)                    ("lisp"  . "hbin")
-	     #+excl                              ("cl"    . "fasl")
-             #+:CMU                              ("slisp" . "sfasl")
-             #+HP                                ("l"     . "b")
-             #+TI ("lisp" . #.(string (si::local-binary-file-type)))
-             #+:gclisp                           ("LSP"   . "F2S")
-             #+pyramid                           ("clisp" . "o")
-             #+:coral                            ("lisp"  . "fasl")
-             ))))
-    (cond ((null proper-extensions) '("l" . "lbin"))
-          ((null files-renamed-p) (cons "lisp" (cdr proper-extensions)))
-          (t proper-extensions))))
-
-(eval-when (compile load eval)
-
-(defun get-system (name)
-  (get name 'system-definition))
-
-(defun set-system (name new-value)
-  (setf (get name 'system-definition) new-value))
-
-(defmacro defsystem (name directory files)
-  `(set-system ',name (list #'(lambda () ,directory)
-			    (make-modules ',files)
-			    ',(mapcar #'car files))))
-
-)
-
-
-;;;
-;;; The internal datastructure used when operating on a system.
-;;; 
-(defstruct (module (:constructor make-module (name))
-                   (:print-function
-                     (lambda (m s d)
-                       (declare (ignore d))
-                       (format s "#<Module ~A>" (module-name m)))))
-  name
-  load-env
-  comp-env
-  recomp-reasons)
-
-(defun make-modules (system-description)
-  (let ((modules ()))
-    (labels ((get-module (name)
-               (or (find name modules :key #'module-name)
-                   (progn (setq modules (cons (make-module name) modules))
-                          (car modules))))
-             (parse-spec (spec)
-               (if (eq spec 't)
-                   (reverse (cdr modules))
-		   (case (car spec)
-		     (+ (append (reverse (cdr modules)) (mapcar #'get-module (cdr spec))))
-		     (- (let ((rem (mapcar #'get-module (cdr spec))))
-			  (remove-if #'(lambda (m) (member m rem)) (reverse (cdr modules)))))
-		     (otherwise (mapcar #'get-module spec))))))
-      (dolist (file system-description)
-        (let* ((name (car file))
-               (port (car (cddddr file)))
-               (module nil))
-          (when (or (null port)
-                    (member port *port*))
-            (setq module (get-module name))
-            (setf (module-load-env module) (parse-spec (cadr file))
-                  (module-comp-env module) (parse-spec (caddr file))
-                  (module-recomp-reasons module) (parse-spec
-                                                   (cadddr file))))))
-      (let ((filenames (mapcar #'car system-description)))
-	(sort modules #'(lambda (name1 name2)
-			  (member name2 (member name1 filenames)))
-	      :key #'module-name)))))
-
-
-(defun make-transformations (modules filter make-transform)
-  (let ((transforms (list nil)))
-    (dolist (m modules)
-      (when (funcall filter m transforms) (funcall make-transform m transforms)))
-    (reverse (cdr transforms))))
-
-(defun make-compile-transformation (module transforms)
-  (unless (dolist (trans transforms)
-	    (and (eq (car trans) ':compile)
-		 (eq (cadr trans) module)
-		 (return t)))
-    (dolist (c (module-comp-env module)) (make-load-transformation c transforms))
-    (setf (cdr transforms)
-	  (remove-if #'(lambda (trans) (and (eq (car trans) :load) (eq (cadr trans) module)))
-		     (cdr transforms)))
-    (push `(:compile ,module) (cdr transforms))))
-
-(defvar *being-loaded* ())
-
-(defun make-load-transformation (module transforms)
-  (if (assoc module *being-loaded*)
-      (throw module (setf (cdr transforms) (cdr (assoc module *being-loaded*))))
-      (let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*)))
-	(catch module
-	  (unless (dolist (trans transforms)
-		    (when (and (eq (car trans) ':load)
-			       (eq (cadr trans) module))
-		      (return t)))
-	    (dolist (l (module-load-env module)) (make-load-transformation l transforms))
-	    (push `(:load ,module) (cdr transforms)))))))
-
-(defun make-load-without-dependencies-transformation (module transforms)
-  (unless (dolist (trans transforms)
-            (and (eq (car trans) ':load)
-                 (eq (cadr trans) module)
-                 (return trans)))
-    (push `(:load ,module) (cdr transforms))))
-
-(defun compile-filter (module transforms)
-  (or (dolist (r (module-recomp-reasons module))
-        (when (dolist (transform transforms)
-                (when (and (eq (car transform) ':compile)
-                           (eq (cadr transform) r))
-                  (return t)))
-          (return t)))
-      (null (probe-file (make-binary-pathname (module-name module))))
-      (> (file-write-date (make-source-pathname (module-name module)))
-         (file-write-date (make-binary-pathname (module-name module))))))
-
-(defun operate-on-system (name mode &optional arg print-only)
-  (let ((system (get-system name)))
-    (unless system (error "Can't find system with name ~S." name))
-    (let ((*system-directory* (funcall (car system)))
-	  (modules (cadr system))
-	  (transformations ()))
-      (labels ((load-source (name pathname)
-		 (format t "~&Loading source of ~A..." name)
-		 (or print-only (load pathname)))
-	       (load-binary (name pathname)
-		 (format t "~&Loading binary of ~A..." name)
-		 (or print-only (load pathname)))	       
-	       (load-module (m)
-		 (let* ((name (module-name m))
-			(*load-verbose* nil)
-			(binary (make-binary-pathname name)))
-		   (load-binary name binary)))
-	       (compile-module (m)
-		 (format t "~&Compiling ~A..." (module-name m))
-		 (unless print-only
-		   (let  ((name (module-name m)))
-		     (compile-file (make-source-pathname name)
-				   :output-file
-				   (make-pathname :defaults
-						  (make-binary-pathname name)
-						  :version :newest)))))
-	       (xcl:true (&rest ignore) (declare (ignore ignore)) 't))
-	
-	(setq transformations
-	      (ecase mode
-		(:compile
-		  ;; Compile any files that have changed and any other files
-		  ;; that require recompilation when another file has been
-		  ;; recompiled.
-		  (make-transformations
-		    modules
-		    #'compile-filter
-		    #'make-compile-transformation))
-		(:recompile
-		  ;; Force recompilation of all files.
-		  (make-transformations
-		    modules
-		    #'xcl:true
-		    #'make-compile-transformation))
-		(:recompile-some
-		  ;; Force recompilation of some files.  Also compile the
-		  ;; files that require recompilation when another file has
-		  ;; been recompiled.
-		  (make-transformations
-		    modules
-		    #'(lambda (m transforms)
-			(or (member (module-name m) arg)
-			    (compile-filter m transforms)))
-		    #'make-compile-transformation))
-		(:query-compile
-		  ;; Ask the user which files to compile.  Compile those
-		  ;; and any other files which must be recompiled when
-		  ;; another file has been recompiled.
-		  (make-transformations
-		    modules
-		    #'(lambda (m transforms)
-			(or (compile-filter m transforms)
-			    (y-or-n-p "Compile ~A?"
-				      (module-name m))))
-		    #'make-compile-transformation))
-		(:confirm-compile
-		  ;; Offer the user a chance to prevent a file from being
-		  ;; recompiled.
-		  (make-transformations
-		    modules
-		    #'(lambda (m transforms)
-			(and (compile-filter m transforms)
-			     (y-or-n-p "Go ahead and compile ~A?"
-				       (module-name m))))
-		    #'make-compile-transformation))
-		(:load
-		  ;; Load the whole system.
-		  (make-transformations
-		    modules
-		    #'xcl:true
-		    #'make-load-transformation))
-		(:query-load
-		  ;; Load only those files the user says to load.
-		  (make-transformations
-		    modules
-		    #'(lambda (m transforms)
-			(declare (ignore transforms))
-			(y-or-n-p "Load ~A?" (module-name m)))
-		    #'make-load-without-dependencies-transformation))))
-	
-	(#+Genera
-	 compiler:compiler-warnings-context-bind
-	 #+TI
-	 COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
-	 #+:LCL3.0
-	 lucid-common-lisp:with-deferred-warnings
-	 #-(or Genera TI :LCL3.0)
-	 progn
-	 (loop (when (null transformations) (return t))
-	       (let ((transform (pop transformations)))
-		 (ecase (car transform)
-		   (:compile (compile-module (cadr transform)))
-		   (:load (load-module (cadr transform)))))))))))
-
-
-(defun make-source-pathname (name) (make-pathname-internal name :source))
-(defun make-binary-pathname (name) (make-pathname-internal name :binary))
-
-(defun make-pathname-internal (name type)
-  (let* ((extension (ecase type
-                      (:source (car *pathname-extensions*))
-                      (:binary (cdr *pathname-extensions*))))
-         (directory (pathname
-		      (etypecase *system-directory*
-			(string *system-directory*)
-			(pathname *system-directory*)
-			(cons (ecase type
-				(:source (car *system-directory*))
-				(:binary (cdr *system-directory*)))))))
-         (pathname
-           (make-pathname
-             :name (string-downcase (string name))
-             :type extension
-             :defaults directory :version :newest)))
-
-    #+Genera
-    (setq pathname (zl:send pathname :new-raw-name (pathname-name pathname))
-          pathname (zl:send pathname :new-raw-type (pathname-type pathname)))
-
-    pathname))
-
-
-
-;;; ***                SITE SPECIFIC CLOS DIRECTORY                        ***
-;;;
-;;; *clos-directory* is a variable which specifies the directory clos is stored
-;;; in at your site.  If the value of the variable is a single pathname, the
-;;; sources and binaries should be stored in that directory.  If the value of
-;;; that directory is a cons, the CAR should be the source directory and the
-;;; CDR should be the binary directory.
-;;;
-;;; By default, the value of *clos-directory* is set to the directory that
-;;; this file is loaded from.  This makes it simple to keep multiple copies
-;;; of CLOS in different places, just load defsys from the same directory as
-;;; the copy of CLOS you want to use.
-;;;
-;;; Note that the value of *CLOS-DIRECTORY* is set using a DEFVAR.  This is
-;;; done to make it possible for users to set it in their init file and then
-;;; load this file.  The value set in the init file will override the value
-;;; here.
-;;;
-;;; ***                                                                   ***
-
-(defun load-truename (&optional (errorp nil))
-  (flet ((bad-time ()
-	   (when errorp
-	     (error "LOAD-TRUENAME called but a file isn't being loaded."))))
-    #+Lispm  (or sys:fdefine-file-pathname (bad-time))
-    #+excl   excl::*source-pathname*
-    #+Xerox  (pathname (or (il:fullname *standard-input*) (bad-time)))
-    #+(and dec vax common) (truename (sys::source-file #'load-truename))
-    ;;
-    ;; The following use of  `lucid::' is a kludge for 2.1 and 3.0
-    ;; compatibility.  In 2.1 it was in the SYSTEM package, and i
-    ;; 3.0 it's in the LUCID-COMMON-LISP package.
-    ;;
-    #+LUCID (or lucid::*source-pathname* (bad-time))
-    #-(or Lispm excl Xerox (and dec vax common) LUCID) nil))
-
-#-Symbolics
-(defvar *clos-directory*
-	(or (load-truename t)
-	    (error "Because load-truename is not implemented in this port~%~
-                    of CLOS, you must manually edit the definition of the~%~
-                    variable *clos-directory* in the file defsys.lisp.")))
-
-#+Genera
-(defvar *clos-directory*
-	(let ((source (load-truename t)))
-	  (flet ((subdir (name)
-		   (scl:send source :new-pathname :raw-directory
-			     (append (scl:send source :raw-directory)
-				     (list name)))))
-	    (cons source
-		  #+genera-release-7-2       (subdir "rel-7-2")
-		  #+genera-release-7-3       (subdir "rel-7-3") 
-		  #+genera-release-7-4       (subdir "rel-7-4")
-		  #+genera-release-8-0       (subdir "rel-8-0")
-		  #+genera-release-8-1       (subdir "rel-8-1")
-		  ))))
-
-#+Cloe-Runtime
-(defvar *clos-directory* (pathname "/usr3/hornig/clos/"))
-
-(defsystem clos	   
-           *clos-directory*
-  ;;
-  ;; file         load           compile      files which       port
-  ;;              environment    environment  force the of
-  ;;                                          recompilation
-  ;;                                          of this file
-  ;;                                          
-  (
-   (patch           t            t            ()                xerox)
-   (pkg             t            t            ())
-   (walk            (pkg)        (pkg)        ())
-   (iterate         t            t            ())
-   (macros          t            t            ())
-   (low             (pkg macros) t            (macros))
-   (low2          (low)         (low)        (low)            Xerox)
-   (fin         t                                   t (low))
-   (defclass    t                                   t (low))
-   (defs        t                                   t (defclass macros iterate))
-   (fngen       t                                   t (low))
-   (lap         t                                   t (low))
-   (plap        t                                   t (low))
-   (cache       t                                   t (low defs))
-   (dlap        t                                   t (defs low fin cache lap))
-   (boot        t                                   t (defs fin))
-   (vector      t                                   t (boot defs cache fin))
-   (slots       t                                   t (vector boot defs low cache fin))
-   (init        t                                   t (vector boot defs low cache fin))
-   (std-class   t                                   t (vector boot defs low cache fin slots))
-   (cpl         t                                   t (vector boot defs low cache fin slots))
-   (braid       t                                   t (boot defs low fin cache))
-   (fsc         t                                   t (defclass boot defs low fin cache))
-   (methods     t                                   t (defclass boot defs low fin cache))
-   (combin      t                                   t (defclass boot defs low fin cache))
-   (dfun        t                                   t (dlap))
-   (fixup       (+ precom1 precom2 precom4)         t (boot defs low fin))
-   (defcombin   t                                   t (defclass boot defs low fin))
-   (ctypes      t                                   t (defclass defcombin))
-   (construct   t                                   t (defclass boot defs low))
-   (env         t                                   t (defclass boot defs low fin))
-   (compat      t                                   t ())
-   (precom1     (dlap)                              t (defs low cache fin dfun))
-   (precom2     (dlap)                              t (defs low cache fin dfun))
-   (precom4     (dlap)                              t (defs low cache fin dfun))
-   ))
-
-(defun compile-clos (&optional m)
-  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
-	#+Lucid (lcl:*redefinition-action* nil)
-	#+excl  (excl::*redefinition-warnings* nil)
-	#+Genera (sys:inhibit-fdefine-warnings t)
-	)
-    (cond ((null m)        (operate-on-system 'clos :compile))
-	  ((eq m :print)   (operate-on-system 'clos :compile () t))
-	  ((eq m :query)   (operate-on-system 'clos :query-compile))
-	  ((eq m :confirm) (operate-on-system 'clos :confirm-compile))
-	  ((eq m 't)       (operate-on-system 'clos :recompile))        
-	  ((listp m)       (operate-on-system 'clos :compile-from m))
-	  ((symbolp m)     (operate-on-system 'clos :recompile-some `(,m))))))
-
-(defun load-clos (&optional m)
-  (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
-	#+Lucid (lcl:*redefinition-action* nil)
-	#+excl  (excl::*redefinition-warnings* nil)
-	#+Genera (sys:inhibit-fdefine-warnings t)
-	)
-    (cond ((null m)      (operate-on-system 'clos :load))
-	  ((eq m :query) (operate-on-system 'clos :query-load)))
-    (pushnew :clos *features*)))
-
-#+Genera
-;;; Make sure Genera bug mail contains the CLOS bug data.  A little
-;;; kludgy, but what the heck.  If they didn't mean for people to do
-;;; this, they wouldn't have made private patch notes be flavored
-;;; objects, right?  Right.
-(progn
-  (scl:defflavor clos-private-patch-info ((description)) ())
-  (scl:defmethod (sct::private-patch-info-description clos-private-patch-info) ()
-    (or description
-	(setf description (string-append "CLOS version: " *clos-system-date*))))
-  (scl:defmethod (sct::private-patch-info-pathname clos-private-patch-info) ()
-    *clos-directory*)
-  (unless (find-if #'(lambda (x) (typep x 'clos-private-patch-info))
-		   sct::*private-patch-info*)
-    (push (scl:make-instance 'clos-private-patch-info)
-	  sct::*private-patch-info*)))
-
-(defun bug-report-info (&optional (stream *standard-output*))
-  (format stream "~&CLOS system date: ~A~
-                  ~&Lisp Implementation type: ~A~
-                  ~&Lisp Implementation version: ~A~
-                  ~&*features*: ~S"
-	  *clos-system-date*
-	  (lisp-implementation-type)
-	  (lisp-implementation-version)
-	  *features*))
-
-
-
-;;;;
-;;;
-;;; This stuff is not intended for external use.
-;;; 
-(defun rename-clos ()
-  (dolist (f (cadr (get-system 'clos)))
-    (let ((old nil)
-          (new nil))
-      (let ((*system-directory* *default-pathname-defaults*))
-        (setq old (make-source-pathname (car f))))
-      (setq new  (make-source-pathname (car f)))
-      (rename-file old new))))
-
-#+Genera
-(defun edit-clos ()
-  (dolist (f (cadr (get-system 'clos)))
-    (let ((*system-directory* *clos-directory*))
-      (zwei:find-file (make-source-pathname (car f))))))
-
-#+Genera
-(defun hardcopy-clos (&optional query-p)
-  (let ((files (mapcar #'(lambda (f)
-                           (setq f (car f))
-                           (and (or (not query-p)
-                                    (y-or-n-p "~A? " f))
-                                f))
-		       (cadr (get-system 'clos))))
-        (b zwei:*interval*))
-    (unwind-protect
-        (dolist (f files)
-          (when f
-            (multiple-value-bind (ignore b)
-                (zwei:find-file (make-source-pathname f))
-              (zwei:hardcopy-buffer b))))
-      (zwei:make-buffer-current b))))
-
-
-;;;
-;;; unido!ztivax!dae@seismo.css.gov
-;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet
-;;; Victor@carmen.uu.se
-;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET
-;;; 
-#+Genera
-(defun mail-clos (to)
-  (let* ((original-buffer zwei:*interval*)
-	 (*system-directory* (pathname "vaxc:/user/ftp/pub/clos/")
-			    ;(funcall (car (get-system 'clos)))
-			     )
-         (files (list* 'defsys
-			'test
-			(caddr (get-system 'clos))))
-         (total-number (length files))
-         (file nil)
-	 (number-of-lines 0)
-         (i 0)
-         (mail-buffer nil))
-    (unwind-protect
-        (loop
-           (when (null files) (return nil))
-           (setq file (pop files))
-           (incf i)
-           (multiple-value-bind (ignore b)
-               (zwei:find-file (make-source-pathname file))
-	     (setq number-of-lines (zwei:count-lines b))
-             (zwei:com-mail-internal t
-                                     :initial-to to
-                                     :initial-body b
-				     :initial-subject
-                                     (format nil
-				       "CLOS file   ~A   (~A of ~A) ~D lines"
-				       file i total-number number-of-lines))
-             (setq mail-buffer zwei:*interval*)
-             (zwei:com-exit-com-mail)
-             (format t "~&Just sent ~A  (~A of ~A)." b i total-number)
-             (zwei:kill-buffer mail-buffer)))
-      (zwei:make-buffer-current original-buffer))))
-
-
diff --git a/obsolete/clos/2.0/dfun.lisp b/obsolete/clos/2.0/dfun.lisp
deleted file mode 100644
index 1e958a30..00000000
--- a/obsolete/clos/2.0/dfun.lisp
+++ /dev/null
@@ -1,606 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-;;;. Copyright (c) 1991 by Venue
-
-(in-package "CLOS")
-
-                                                             
-                                                             ; ************************************************************************
-                                                             ; temporary for data gathering         
-                                                             ; temporary for data gathering
-                                                             ; ************************************************************************
-
-
-(defvar *dfun-states* (make-hash-table :test #'eq))
-
-(defun notice-dfun-state (generic-function state &optional nkeys valuep)
-       (setf (gethash generic-function *dfun-states*)
-             (cons state (when nkeys (list nkeys valuep)))))
-
-                                                             
-                                                             ; ************************************************************************
-                                                             ; temporary for data gathering         
-                                                             ; temporary for data gathering
-                                                             ; ************************************************************************
-
-
-(defvar *dfun-constructors* nil)
-
-                                                             ; An alist in which each entry is of
-                                                             ; the form (<generator> . (<subentry>
-                                                             ; ...)) Each subentry is of the form:
-                                                             ; (<args> <constructor> <system>) 
-
-
-(defvar *enable-dfun-constructor-caching* t)
-
-                                                             ; If this is NIL, then the whole
-                                                             ; mechanism for caching dfun
-                                                             ; constructors is turned off.  The only
-                                                             ; time that makes sense is when
-                                                             ; debugging LAP code. 
-
-
-(defun show-dfun-constructors nil (format t "~&DFUN constructor caching is ~A." (if 
-                                                                    *enable-dfun-constructor-caching*
-                                                                                    "enabled"
-                                                                                    "disabled"))
-       (dolist (generator-entry *dfun-constructors*)
-           (dolist (args-entry (cdr generator-entry))
-               (format t "~&~S ~S" (cons (car generator-entry)
-                                         (caar args-entry))
-                      (caddr args-entry)))))
-
-(defun get-dfun-constructor (generator &rest args)
-       (let* ((generator-entry (assq generator *dfun-constructors*))
-              (args-entry (assoc args (cdr generator-entry)
-                                 :test
-                                 #'equal)))
-             (if (null *enable-dfun-constructor-caching*)
-                 (apply (symbol-function generator)
-                        args)
-                 (or (cadr args-entry)
-                     (let ((new (apply (symbol-function generator)
-                                       args)))
-                          (if generator-entry
-                              (push (list (copy-list args)
-                                          new nil)
-                                    (cdr generator-entry))
-                              (push (list generator (list (copy-list args)
-                                                          new nil))
-                                    *dfun-constructors*))
-                          new)))))
-
-(defun load-precompiled-dfun-constructor (generator args system constructor)
-       (let* ((generator-entry (assq generator *dfun-constructors*))
-              (args-entry (assoc args (cdr generator-entry)
-                                 :test
-                                 #'equal)))
-             (unless args-entry
-                 (if generator-entry
-                     (push (list args constructor system)
-                           (cdr generator-entry))
-                     (push (list generator (list args constructor system))
-                           *dfun-constructors*)))))
-
-(defmacro
- precompile-dfun-constructors
- (&optional system)
- (let
-  ((*precompiling-lap* t))
-  `(progn
-    ,@(gathering1 (collecting)
-             (dolist (generator-entry *dfun-constructors*)
-                 (dolist (args-entry (cdr generator-entry))
-                     (when (or (null (caddr args-entry))
-                               (eq (caddr args-entry)
-                                   system))
-                         (multiple-value-bind (closure-variables arguments iregs vregs tregs lap)
-                             (apply (symbol-function (car generator-entry))
-                                    (car args-entry))
-                           (gather1 (make-top-level-form `(precompile-dfun-constructor
-                                                           ,(car generator-entry))
-                                           '(load)
-                                           `(load-precompiled-dfun-constructor
-                                             ',(car generator-entry)
-                                             ',(car args-entry)
-                                             ',system
-                                             (precompile-lap-closure-generator ,closure-variables
-                                                    ,arguments
-                                                    ,iregs
-                                                    ,vregs
-                                                    ,tregs
-                                                    ,lap))))))))))))
-
-(defun make-initial-dfun (generic-function)
-       #'(lambda (&rest args)
-                (initial-dfun args generic-function)))
-
-
-;;; When all the methods of a generic function are automatically generated reader or writer methods
-;;; a number of special optimizations are possible. These are important because of the large number
-;;; of generic functions of this type. There are a number of cases: ONE-CLASS-ACCESSOR In this case,
-;;; the accessor generic function has only been called with one class of argument.  There is no
-;;; cache vector, the wrapper of the one class, and the slot index are stored directly as closure
-;;; variables of the discriminating function.  This case can convert to either of the next kind.
-;;; TWO-CLASS-ACCESSOR Like above, but two classes.  This is common enough to do specially. There is
-;;; no cache vector.  The two classes are stored a separate closure variables. ONE-INDEX-ACCESSOR In
-;;; this case, the accessor generic function has seen more than one class of argument, but the index
-;;; of the slot is the same for all the classes that have been seen.  A cache vector is used to
-;;; store the wrappers that have been seen, the slot index is stored directly as a closure variable
-;;; of the discriminating function.  This case can convert to the next kind. N-N-ACCESSOR This is
-;;; the most general case.  In this case, the accessor generic function has seen more than one class
-;;; of argument and more than one slot index.  A cache vector stores the wrappers and corresponding
-;;; slot indexes.  Because each cache line is more than one element long, a cache lock count is
-;;; used. ONE-CLASS-ACCESSOR 
-
-
-(defun update-to-one-class-readers-dfun (generic-function wrapper index)
-       (let ((constructor (get-dfun-constructor 'emit-one-class-reader (consp index))))
-            (notice-dfun-state generic-function `(one-class readers ,(consp index)))
-                                                             ; ***
-            (update-dfun generic-function (funcall constructor wrapper index
-                                                 #'(lambda (arg)
-                                                          (declare (clos-fast-call))
-                                                          (one-class-readers-miss arg 
-                                                                 generic-function index wrapper))))))
-
-(defun update-to-one-class-writers-dfun (generic-function wrapper index)
-       (let ((constructor (get-dfun-constructor 'emit-one-class-writer (consp index))))
-            (notice-dfun-state generic-function `(one-class writers ,(consp index)))
-                                                             ; ***
-            (update-dfun generic-function (funcall constructor wrapper index
-                                                 #'(lambda (new-value arg)
-                                                          (declare (clos-fast-call))
-                                                          (one-class-writers-miss new-value arg 
-                                                                 generic-function index wrapper))))))
-
-(defun one-class-readers-miss (arg generic-function index wrapper)
-       (accessor-miss generic-function 'one-class 'reader nil arg index wrapper nil nil nil))
-
-(defun one-class-writers-miss (new arg generic-function index wrapper)
-       (accessor-miss generic-function 'one-class 'writer new arg index wrapper nil nil nil))
-
-
-;;; TWO-CLASS-ACCESSOR 
-
-
-(defun update-to-two-class-readers-dfun (generic-function wrapper-0 wrapper-1 index)
-       (let ((constructor (get-dfun-constructor 'emit-two-class-reader (consp index))))
-            (notice-dfun-state generic-function `(two-class readers ,(consp index)))
-                                                             ; ***
-            (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
-                                                 #'(lambda (arg)
-                                                          (declare (clos-fast-call))
-                                                          (two-class-readers-miss arg 
-                                                                 generic-function index wrapper-0 
-                                                                 wrapper-1))))))
-
-(defun update-to-two-class-writers-dfun (generic-function wrapper-0 wrapper-1 index)
-       (let ((constructor (get-dfun-constructor 'emit-two-class-writer (consp index))))
-            (notice-dfun-state generic-function `(two-class writers ,(consp index)))
-                                                             ; ***
-            (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
-                                                 #'(lambda (new-value arg)
-                                                          (declare (clos-fast-call))
-                                                          (two-class-writers-miss new-value arg 
-                                                                 generic-function index wrapper-0 
-                                                                 wrapper-1))))))
-
-(defun two-class-readers-miss (arg generic-function index w0 w1)
-       (accessor-miss generic-function 'two-class 'reader nil arg index w0 w1 nil nil))
-
-(defun two-class-writers-miss (new arg generic-function index w0 w1)
-       (accessor-miss generic-function 'two-class 'writer new arg index w0 w1 nil nil))
-
-
-;;; std accessors same index dfun 
-
-
-(defun update-to-one-index-readers-dfun (generic-function index &optional field cache)
-       (unless field
-           (setq field (wrapper-field 'number)))
-       (let ((constructor (get-dfun-constructor 'emit-one-index-readers (consp index))))
-            (multiple-value-bind (mask size)
-                (compute-cache-parameters 1 nil (or cache 4))
-              (unless cache
-                  (setq cache (get-cache size)))
-              (notice-dfun-state generic-function `(one-index readers ,(consp index)))
-                                                             ; ***
-              (update-dfun generic-function (funcall constructor field cache mask size index
-                                                   #'(lambda (arg)
-                                                            (declare (clos-fast-call))
-                                                            (one-index-readers-miss arg 
-                                                                   generic-function index field cache
-                                                                   )))
-                     cache))))
-
-(defun update-to-one-index-writers-dfun (generic-function index &optional field cache)
-       (unless field
-           (setq field (wrapper-field 'number)))
-       (let ((constructor (get-dfun-constructor 'emit-one-index-writers (consp index))))
-            (multiple-value-bind (mask size)
-                (compute-cache-parameters 1 nil (or cache 4))
-              (unless cache
-                  (setq cache (get-cache size)))
-              (notice-dfun-state generic-function `(one-index writers ,(consp index)))
-                                                             ; ***
-              (update-dfun generic-function (funcall constructor field cache mask size index
-                                                   #'(lambda (new-value arg)
-                                                            (declare (clos-fast-call))
-                                                            (one-index-writers-miss new-value arg 
-                                                                   generic-function index field cache
-                                                                   )))
-                     cache))))
-
-(defun one-index-readers-miss (arg gf index field cache)
-       (accessor-miss gf 'one-index 'reader nil arg index nil nil field cache))
-
-(defun one-index-writers-miss (new arg gf index field cache)
-       (accessor-miss gf 'one-index 'writer new arg index nil nil field cache))
-
-(defun one-index-limit-fn (nlines)
-       (default-limit-fn nlines))
-
-(defun update-to-n-n-readers-dfun (generic-function &optional field cache)
-       (unless field
-           (setq field (wrapper-field 'number)))
-       (let ((constructor (get-dfun-constructor 'emit-n-n-readers)))
-            (multiple-value-bind (mask size)
-                (compute-cache-parameters 1 t (or cache 2))
-              (unless cache
-                  (setq cache (get-cache size)))
-              (notice-dfun-state generic-function `(n-n readers))
-                                                             ; ***
-              (update-dfun generic-function (funcall constructor field cache mask size
-                                                   #'(lambda (arg)
-                                                            (declare (clos-fast-call))
-                                                            (n-n-readers-miss arg generic-function 
-                                                                   field cache)))
-                     cache))))
-
-(defun update-to-n-n-writers-dfun (generic-function &optional field cache)
-       (unless field
-           (setq field (wrapper-field 'number)))
-       (let ((constructor (get-dfun-constructor 'emit-n-n-writers)))
-            (multiple-value-bind (mask size)
-                (compute-cache-parameters 1 t (or cache 2))
-              (unless cache
-                  (setq cache (get-cache size)))
-              (notice-dfun-state generic-function `(n-n writers))
-                                                             ; ***
-              (update-dfun generic-function (funcall constructor field cache mask size
-                                                   #'(lambda (new arg)
-                                                            (declare (clos-fast-call))
-                                                            (n-n-writers-miss new arg 
-                                                                   generic-function field cache)))
-                     cache))))
-
-(defun n-n-readers-miss (arg gf field cache)
-       (accessor-miss gf 'n-n 'reader nil arg nil nil nil field cache))
-
-(defun n-n-writers-miss (new arg gf field cache)
-       (accessor-miss gf 'n-n 'writer new arg nil nil nil field cache))
-
-(defun n-n-accessors-limit-fn (nlines)
-       (default-limit-fn nlines))
-
-
-;;; 
-
-
-(defun update-to-checking-dfun (generic-function function &optional field cache)
-       (unless field
-           (setq field (wrapper-field 'number)))
-       (let* ((arg-info (gf-arg-info generic-function))
-              (metatypes (arg-info-metatypes arg-info))
-              (applyp (arg-info-applyp arg-info))
-              (nkeys (arg-info-nkeys arg-info)))
-             (if (every #'(lambda (mt)
-                                 (eq mt 't))
-                        metatypes)
-                 (progn (notice-dfun-state generic-function `(default-method-only))
-                                                             ; ***
-                        (update-dfun generic-function function))
-                 (multiple-value-bind (mask size)
-                     (compute-cache-parameters nkeys nil (or cache 2))
-                   (unless cache
-                       (setq cache (get-cache size)))
-                   (let ((constructor (get-dfun-constructor 'emit-checking metatypes applyp)))
-                        (notice-dfun-state generic-function '(checking)
-                               nkeys nil)
-                                                             ; ****
-                        (update-dfun generic-function
-                               (funcall constructor field cache mask size function
-                                      #'(lambda (&rest args)
-                                               (declare (clos-fast-call))
-                                               (checking-miss generic-function args function field 
-                                                      cache)))
-                               cache))))))
-
-(defun checking-limit-fn (nlines)
-       (default-limit-fn nlines))
-
-
-;;; 
-
-
-(defun update-to-caching-dfun (generic-function &optional field cache)
-       (unless field
-           (setq field (wrapper-field 'number)))
-       (let* ((arg-info (gf-arg-info generic-function))
-              (metatypes (arg-info-metatypes arg-info))
-              (applyp (arg-info-applyp arg-info))
-              (nkeys (arg-info-nkeys arg-info))
-              (constructor (get-dfun-constructor 'emit-caching metatypes applyp)))
-             (multiple-value-bind (mask size)
-                 (compute-cache-parameters nkeys t (or cache 2))
-               (unless cache
-                   (setq cache (get-cache size)))
-               (notice-dfun-state generic-function '(caching)
-                      nkeys t)
-                                                             ; ****
-               (update-dfun generic-function (funcall constructor field cache mask size
-                                                    #'(lambda (&rest args)
-                                                             (declare (clos-fast-call))
-                                                             (caching-miss generic-function args 
-                                                                    field cache)))
-                      cache))))
-
-(defun caching-limit-fn (nlines)
-       (default-limit-fn nlines))
-
-
-;;; The dynamically adaptive method lookup algorithm is implemented is implemented as a kind of
-;;; state machine.  The kinds of discriminating function is the state, the various kinds of reasons
-;;; for a cache miss are the state transitions. The code which implements the transitions is all in
-;;; the miss handlers for each kind of dfun.  Those appear here. Note that within the states that
-;;; cache, there are dfun updates which simply select a new cache or cache field.  Those are not
-;;; considered as state transitions. 
-
-
-(defun initial-dfun (args generic-function)
-       (protect-cache-miss-code generic-function args
-              (multiple-value-bind (wrappers invalidp nfunction applicable)
-                  (cache-miss-values generic-function args)
-                (multiple-value-bind (ntype nindex)
-                    (accessor-miss-values generic-function applicable args)
-                  (cond ((null applicable)
-                         (apply #'no-applicable-method generic-function args))
-                        (invalidp (apply nfunction args))
-                        ((and ntype nindex)
-                         (ecase ntype
-                             (reader (update-to-one-class-readers-dfun generic-function wrappers 
-                                            nindex))
-                             (writer (update-to-one-class-writers-dfun generic-function wrappers 
-                                            nindex)))
-                         (apply nfunction args))
-                        (ntype (apply nfunction args))
-                        (t (update-to-checking-dfun generic-function nfunction)
-                           (apply nfunction args)))))))
-
-(defun
- accessor-miss
- (gf ostate otype new object oindex ow0 ow1 field cache)
- (declare (ignore ow1))
- (let ((args (ecase otype                                    ; The congruence rules assure
-                 (reader (list object))                      ; us that this is safe despite
-                 (writer (list new object)))))
-                                                             ; not knowing the new type yet.
-      (protect-cache-miss-code
-       gf args
-       (multiple-value-bind (wrappers invalidp nfunction applicable)
-           (cache-miss-values gf args)
-         (multiple-value-bind (ntype nindex)
-             (accessor-miss-values gf applicable args)
-           
-           ;; The following lexical functions change the state of the dfun to that which is their
-           ;; name.  They accept arguments which are the parameters of the new state, and get other
-           ;; information from the lexical variables bound above. 
-           (flet ((two-class (index w0 w1)
-                         (when (zerop (random 2))
-                               (psetf w0 w1 w1 w0))
-                         (ecase ntype
-                             (reader (update-to-two-class-readers-dfun gf w0 w1 index))
-                             (writer (update-to-two-class-writers-dfun gf w0 w1 index))))
-                  (one-index (index &optional field cache)
-                         (ecase ntype
-                             (reader (update-to-one-index-readers-dfun gf index field cache))
-                             (writer (update-to-one-index-writers-dfun gf index field cache))))
-                  (n-n (&optional field cache)
-                       (ecase ntype
-                           (reader (update-to-n-n-readers-dfun gf field cache))
-                           (writer (update-to-n-n-writers-dfun gf field cache))))
-                  (checking nil (update-to-checking-dfun gf nfunction))
-                  
-                  ;; 
-                  (do-fill (valuep limit-fn update-fn)
-                         (multiple-value-bind (nfield ncache)
-                             (fill-cache field cache 1 valuep limit-fn wrappers nindex)
-                           (unless (and (= nfield field)
-                                        (eq ncache cache))
-                                  (funcall update-fn nfield ncache)))))
-                 (cond ((null nfunction)
-                        (apply #'no-applicable-method gf args))
-                       ((null ntype)
-                        (checking)
-                        (apply nfunction args))
-                       ((or invalidp (null nindex))
-                        (apply nfunction args))
-                       ((not (or (std-instance-p object)
-                                 (fsc-instance-p object)))
-                        (checking)
-                        (apply nfunction args))
-                       ((neq ntype otype)
-                        (checking)
-                        (apply nfunction args))
-                       (t (ecase ostate
-                              (one-class (if (eql nindex oindex)
-                                             (two-class nindex ow0 wrappers)
-                                             (n-n)))
-                              (two-class (if (eql nindex oindex)
-                                             (one-index nindex)
-                                             (n-n)))
-                              (one-index (if (eql nindex oindex)
-                                             (do-fill nil #'one-index-limit-fn
-                                                    #'(lambda (nfield ncache)
-                                                             (one-index nindex nfield ncache)))
-                                             (n-n)))
-                              (n-n (unless (consp nindex)
-                                       (do-fill t #'n-n-accessors-limit-fn #'n-n))))
-                          (apply nfunction args)))))))))
-
-(defun checking-miss (generic-function args ofunction field cache)
-       (protect-cache-miss-code generic-function args
-              (let* ((arg-info (gf-arg-info generic-function))
-                     (nkeys (arg-info-nkeys arg-info)))
-                    (multiple-value-bind (wrappers invalidp nfunction)
-                        (cache-miss-values generic-function args)
-                      (cond (invalidp (apply nfunction args))
-                            ((null nfunction)
-                             (apply #'no-applicable-method generic-function args))
-                            ((eq ofunction nfunction)
-                             (multiple-value-bind (nfield ncache)
-                                 (fill-cache field cache nkeys nil #'checking-limit-fn wrappers nil)
-                               (unless (and (= nfield field)
-                                            (eq ncache cache))
-                                      (update-to-checking-dfun generic-function nfunction nfield 
-                                             ncache)))
-                             (apply nfunction args))
-                            (t (update-to-caching-dfun generic-function)
-                               (apply nfunction args)))))))
-
-(defun caching-miss (generic-function args ofield ocache)
-       (protect-cache-miss-code generic-function args
-              (let* ((arg-info (gf-arg-info generic-function))
-                     (nkeys (arg-info-nkeys arg-info)))
-                    (multiple-value-bind (wrappers invalidp function)
-                        (cache-miss-values generic-function args)
-                      (cond (invalidp (apply function args))
-                            ((null function)
-                             (apply #'no-applicable-method generic-function args))
-                            (t (multiple-value-bind (nfield ncache)
-                                   (fill-cache ofield ocache nkeys t #'caching-limit-fn wrappers 
-                                          function)
-                                 (unless (and (= nfield ofield)
-                                              (eq ncache ocache))
-                                        (update-to-caching-dfun generic-function nfield ncache)))
-                               (apply function args)))))))
-
-
-;;; Some useful support functions which are shared by the implementations of the different kinds of
-;;; dfuns. Given a generic function and a set of arguments to that generic function, returns a mess
-;;; of values. <wrappers>   Is a single wrapper if the generic function has only one key, that is
-;;; arg-info-nkeys of the arg-info is 1. Otherwise a list of the wrappers of the specialized
-;;; arguments to the generic function. Note that all these wrappers are valid.  This function does
-;;; invalid wrapper traps when it finds an invalid wrapper and then returns the new, valid wrapper.
-;;; <invalidp>   True if any of the specialized arguments had an invalid wrapper, false otherwise.
-;;; <function>   The compiled effective method function for this set of arguments.  Gotten from
-;;; get-secondary-dispatch-function so effective-method-function caching is in effect, and that is
-;;; important since it is what keeps us in checking dfun state when possible. <type>       READER or
-;;; WRITER when the only method that would be run is a standard reader or writer method.  To be
-;;; specific, the value is READER when the method combination is eq to
-;;; *standard-method-combination*; there are no applicable :before, :after or :around methods; and
-;;; the most specific primary method is a standard reader method. <index>      If <type> is READER
-;;; or WRITER, and the slot accessed is an :instance slot, this is the index number of that slot in
-;;; the object argument. <applicable> Sorted list of applicable methods. 
-
-
-(defun cache-miss-values (generic-function args)
-       (declare (values wrappers invalidp function applicable))
-       (multiple-value-bind (function appl arg-info)
-           (get-secondary-dispatch-function generic-function args)
-         (multiple-value-bind (wrappers invalidp)
-             (get-wrappers generic-function args arg-info)
-           (values wrappers invalidp (cache-miss-values-function generic-function function)
-                  appl))))
-
-(defun get-wrappers (generic-function args &optional arg-info)
-       (let* ((invalidp nil)
-              (wrappers nil)
-              (arg-info (or arg-info (gf-arg-info generic-function)))
-              (metatypes (arg-info-metatypes arg-info))
-              (nkeys (arg-info-nkeys arg-info)))
-             (flet ((get-valid-wrapper (x)
-                           (let ((wrapper (wrapper-of x)))
-                                (cond ((invalid-wrapper-p wrapper)
-                                       (setq invalidp t)
-                                       (check-wrapper-validity x))
-                                      (t wrapper)))))
-                   (setq wrappers (block collect-wrappers
-                                      (gathering1 (collecting)
-                                             (iterate ((arg (list-elements args))
-                                                       (metatype (list-elements metatypes)))
-                                                    (when (neq metatype 't)
-                                                        (if (= nkeys 1)
-                                                            (return-from collect-wrappers
-                                                                   (get-valid-wrapper arg))
-                                                            (gather1 (get-valid-wrapper arg))))))))
-                   (values wrappers invalidp))))
-
-(defun cache-miss-values-function (generic-function function)
-       (if (eq *generate-random-code-segments* generic-function)
-           (progn (setq *generate-random-code-segments* nil)
-                  #'(lambda (&rest args)
-                           (declare (ignore args))
-                           nil))
-           function))
-
-(defun generate-random-code-segments (generic-function)
-       (dolist (arglist (generate-arglists generic-function))
-           (let ((*generate-random-code-segments* generic-function))
-                (apply generic-function arglist))))
-
-(defun generate-arglists (generic-function)
-       
-       ;; Generate arglists using class-prototypes and eql-specializer-objects to get all the
-       ;; "different" values that could be returned by get-secondary-dispatch-function for this
-       ;; generic-function. 
-       (let ((methods (generic-function-methods generic-function)))
-            (mapcar #'(lambda (class-list)
-                             (mapcar #'(lambda (specializer)
-                                              (if (eql-specializer-p specializer)
-                                                  (eql-specializer-object specializer)
-                                                  (class-prototype specializer)))
-                                    (method-specializers (find class-list methods :test
-                                                               #'(lambda (class-list method)
-                                                                        (every 
-                                                                               #'
-                                                                 specializer-applicable-using-class-p
-                                                                               (method-specializers
-                                                                                method)
-                                                                               class-list))))))
-                   (generate-arglist-classes generic-function))))
-
-(defun generate-arglist-classes (generic-function)
-       (let ((methods (generic-function-methods generic-function)))
-            (declare (ignore methods))
-            
-            ;; Finish this sometime.
-            nil))
-
-(defun accessor-miss-values (generic-function applicable args)
-       (declare (values type index))
-       (let ((type (and (eq (generic-function-method-combination generic-function)
-                            *standard-method-combination*)
-                        (every #'(lambda (m)
-                                        (null (method-qualifiers m)))
-                               applicable)
-                        (let ((method (car applicable)))
-                             (cond ((standard-reader-method-p method)
-                                    (and (optimize-slot-value-by-class-p (class-of (car args))
-                                                (accessor-method-slot-name method)
-                                                nil)
-                                         'reader))
-                                   ((standard-writer-method-p method)
-                                    (and (optimize-slot-value-by-class-p (class-of (cadr args))
-                                                (accessor-method-slot-name method)
-                                                t)
-                                         'writer))
-                                   (t nil))))))
-            (values type (and type (let ((wrapper (wrapper-of (case type
-                                                                  (reader (car args))
-                                                                  (writer (cadr args)))))
-                                         (slot-name (accessor-method-slot-name (car applicable))))
-                                        (or (instance-slot-index wrapper slot-name)
-                                            (assq slot-name (wrapper-class-slots wrapper))))))))
diff --git a/obsolete/clos/2.0/dlap.lisp b/obsolete/clos/2.0/dlap.lisp
deleted file mode 100644
index e50f0bb8..00000000
--- a/obsolete/clos/2.0/dlap.lisp
+++ /dev/null
@@ -1,492 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-;;; Copyright (c) 1991 by Venue
-
-(in-package "CLOS")
-
-;;;
-
-(defun emit-one-class-reader (class-slot-p)
-       (emit-reader/writer :reader 1 class-slot-p))
-
-(defun emit-one-class-writer (class-slot-p)
-       (emit-reader/writer :writer 1 class-slot-p))
-
-(defun emit-two-class-reader (class-slot-p)
-       (emit-reader/writer :reader 2 class-slot-p))
-
-(defun emit-two-class-writer (class-slot-p)
-       (emit-reader/writer :writer 2 class-slot-p))
-
-(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
-       (let ((instance nil)
-             (arglist nil)
-             (closure-variables nil)
-             (field (wrapper-field 'number)))
-                                                             ; we need some field to do the fast
-                                                             ; obsolete check 
-            (ecase reader/writer
-                (:reader (setq instance (dfun-arg-symbol 0)
-                               arglist
-                               (list instance)))
-                (:writer (setq instance (dfun-arg-symbol 1)
-                               arglist
-                               (list (dfun-arg-symbol 0)
-                                     instance))))
-            (ecase 1-or-2-class
-                (1 (setq closure-variables '(wrapper-0 index miss-fn)))
-                (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
-            (generating-lap
-             closure-variables arglist
-             (with-lap-registers ((inst t)
-                                                             ; reg for the instance
-                                  (wrapper vector)
-                                                             ; reg for the wrapper
-                                  (cache-no index))
-                                                             ; reg for the cache no
-                    (let ((index cache-no)
-                                                             ; This register is used for different
-                                                             ; values at different times. 
-                          (slots (and (null class-slot-p)
-                                      (allocate-register 'vector)))
-                          (csv (and class-slot-p (allocate-register t))))
-                         (prog1 (flatten-lap (opcode :move (operand :arg instance)
-                                                    inst)
-                                                             ; get the instance
-                                       (opcode :std-instance-p inst 'std-instance)
-                                                             ; if not either std-inst
-                                       (opcode :fsc-instance-p inst 'fsc-instance)
-                                                             ; or fsc-instance then
-                                       (opcode :go 'trap)
-                                                             ; we lose
-                                       (opcode :label 'fsc-instance)
-                                       (opcode :move (operand :fsc-wrapper inst)
-                                              wrapper)
-                                       (and slots (opcode :move (operand :fsc-slots inst)
-                                                         slots))
-                                       (opcode :go 'have-wrapper)
-                                       (opcode :label 'std-instance)
-                                       (opcode :move (operand :std-wrapper inst)
-                                              wrapper)
-                                       (and slots (opcode :move (operand :std-slots inst)
-                                                         slots))
-                                       (opcode :label 'have-wrapper)
-                                       (opcode :move (operand :cref wrapper field)
-                                              cache-no)
-                                       (opcode :izerop cache-no 'trap)
-                                                             ; obsolete wrapper?
-                                       (ecase 1-or-2-class
-                                           (1 (emit-check-1-class-wrapper wrapper 'wrapper-0
-                                                     'trap))
-                                           (2 (emit-check-2-class-wrapper wrapper 'wrapper-0
-                                                     'wrapper-1
-                                                     'trap)))
-                                       (if class-slot-p
-                                           (flatten-lap (opcode :move (operand :cvar 'index)
-                                                               csv)
-                                                  (ecase reader/writer
-                                                      (:reader (emit-get-class-slot csv 'trap inst))
-                                                      (:writer (emit-set-class-slot csv (car arglist)
-                                                                      inst))))
-                                           (flatten-lap (opcode :move (operand :cvar 'index)
-                                                               index)
-                                                  (ecase reader/writer
-                                                      (:reader (emit-get-slot slots index
-                                                                      'trap inst))
-                                                      (:writer (emit-set-slot slots index
-                                                                      (car arglist)
-                                                                      inst)))))
-                                       (opcode :label 'trap)
-                                       (emit-miss 'miss-fn))
-                             (when slots (deallocate-register slots))
-                             (when csv (deallocate-register csv))))))))
-
-(defun emit-one-index-readers (class-slot-p)
-       (let ((arglist (list (dfun-arg-symbol 0))))
-            (generating-lap '(field cache mask size index miss-fn)
-                   arglist
-                   (with-lap-registers ((slots vector))
-                          (emit-dlap arglist '(standard-instance)
-                                 'trap
-                                 (with-lap-registers ((index index))
-                                        (flatten-lap (opcode :move (operand :cvar 'index)
-                                                            index)
-                                               (if class-slot-p
-                                                   (emit-get-class-slot index 'trap slots)
-                                                   (emit-get-slot slots index 'trap))))
-                                 (flatten-lap (opcode :label 'trap)
-                                        (emit-miss 'miss-fn))
-                                 nil
-                                 (and (null class-slot-p)
-                                      (list slots)))))))
-
-(defun emit-one-index-writers (class-slot-p)
-       (let ((arglist (list (dfun-arg-symbol 0)
-                            (dfun-arg-symbol 1))))
-            (generating-lap '(field cache mask size index miss-fn)
-                   arglist
-                   (with-lap-registers ((slots vector))
-                          (emit-dlap arglist '(t standard-instance)
-                                 'trap
-                                 (with-lap-registers ((index index))
-                                        (flatten-lap (opcode :move (operand :cvar 'index)
-                                                            index)
-                                               (if class-slot-p
-                                                   (emit-set-class-slot index (dfun-arg-symbol 0)
-                                                          slots)
-                                                   (emit-set-slot slots index (dfun-arg-symbol 0)))))
-                                 (flatten-lap (opcode :label 'trap)
-                                        (emit-miss 'miss-fn))
-                                 nil
-                                 (and (null class-slot-p)
-                                      (list nil slots)))))))
-
-(defun emit-n-n-readers nil (let ((arglist (list (dfun-arg-symbol 0))))
-                                 (generating-lap '(field cache mask size miss-fn)
-                                        arglist
-                                        (with-lap-registers ((slots vector)
-                                                             (index index))
-                                               (emit-dlap arglist '(standard-instance)
-                                                      'trap
-                                                      (emit-get-slot slots index 'trap)
-                                                      (flatten-lap (opcode :label 'trap)
-                                                             (emit-miss 'miss-fn))
-                                                      index
-                                                      (list slots))))))
-
-(defun emit-n-n-writers nil (let ((arglist (list (dfun-arg-symbol 0)
-                                                 (dfun-arg-symbol 1))))
-                                 (generating-lap '(field cache mask size miss-fn)
-                                        arglist
-                                        (with-lap-registers ((slots vector)
-                                                             (index index))
-                                               (flatten-lap (emit-dlap arglist '(t standard-instance)
-                                                                   'trap
-                                                                   (emit-set-slot slots index
-                                                                          (dfun-arg-symbol 0))
-                                                                   (flatten-lap (opcode :label
-                                                                                       'trap)
-                                                                          (emit-miss 'miss-fn))
-                                                                   index
-                                                                   (list nil slots)))))))
-
-(defun emit-checking (metatypes applyp)
-       (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
-            (generating-lap '(field cache mask size function miss-fn)
-                   dlap-lambda-list
-                   (emit-dlap (remove '&rest dlap-lambda-list)
-                          metatypes
-                          'trap
-                          (with-lap-registers (#'t)
-                                 (flatten-lap (opcode :move (operand :cvar 'function)
-                                                     function)
-                                        (opcode :jmp function)))
-                          (with-lap-registers ((miss-function t))
-                                 (flatten-lap (opcode :label 'trap)
-                                        (opcode :move (operand :cvar 'miss-fn)
-                                               miss-function)
-                                        (opcode :jmp miss-function)))
-                          nil))))
-
-(defun emit-caching (metatypes applyp)
-       (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
-            (generating-lap '(field cache mask size miss-fn)
-                   dlap-lambda-list
-                   (with-lap-registers (#'t)
-                          (emit-dlap (remove '&rest dlap-lambda-list)
-                                 metatypes
-                                 'trap
-                                 (flatten-lap (opcode :jmp function))
-                                 (with-lap-registers ((miss-function t))
-                                        (flatten-lap (opcode :label 'trap)
-                                               (opcode :move (operand :cvar 'miss-fn)
-                                                      miss-function)
-                                               (opcode :jmp miss-function)))
-                                 function)))))
-
-(defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label)
-       (with-lap-registers ((cwrapper vector))
-              (flatten-lap (opcode :move (operand :cvar cwrapper-0)
-                                  cwrapper)
-                     (opcode :neq wrapper cwrapper miss-label))))
-
-                                                             ; wrappers not eq, trap
-
-
-(defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label)
-       (with-lap-registers ((cwrapper vector))
-              (flatten-lap (opcode :move (operand :cvar cwrapper-0)
-                                  cwrapper)
-                                                             ; This is an OR.  Isn't
-                     (opcode :eq wrapper cwrapper 'hit-internal)
-                                                             ; assembly code fun
-                     (opcode :move (operand :cvar cwrapper-1)
-                            cwrapper)
-                                                             ; 
-                     (opcode :neq wrapper cwrapper miss-label)
-                                                             ; 
-                     (opcode :label 'hit-internal))))
-
-(defun emit-get-slot (slots index trap-label &optional temp)
-       (let ((slot-unbound (operand :constant *slot-unbound*)))
-            (with-lap-registers ((val t :reuse temp))
-                   (flatten-lap (opcode :move (operand :iref slots index)
-                                       val)
-                                                             ; get slot value
-                          (opcode :eq val slot-unbound trap-label)
-                                                             ; is the slot unbound?
-                          (opcode :return val)))))
-
-                                                             ; return the slot value
-
-
-(defun emit-set-slot (slots index new-value-arg &optional temp)
-       (with-lap-registers ((new-val t :reuse temp))
-              (flatten-lap (opcode :move (operand :arg new-value-arg)
-                                  new-val)
-                                                             ; get new value into a reg
-                     (opcode :move new-val (operand :iref slots index))
-                                                             ; set slot value
-                     (opcode :return new-val))))
-
-(defun emit-get-class-slot (index trap-label &optional temp)
-       (let ((slot-unbound (operand :constant *slot-unbound*)))
-            (with-lap-registers ((val t :reuse temp))
-                   (flatten-lap (opcode :move (operand :cdr index)
-                                       val)
-                          (opcode :eq val slot-unbound trap-label)
-                          (opcode :return val)))))
-
-(defun emit-set-class-slot (index new-value-arg &optional temp)
-       (with-lap-registers ((new-val t :reuse temp))
-              (flatten-lap (opcode :move (operand :arg new-value-arg)
-                                  new-val)
-                     (opcode :move new-val (operand :cdr index))
-                     (opcode :return new-val))))
-
-(defun emit-miss (miss-fn)
-       (with-lap-registers ((miss-fn-reg t))
-              (flatten-lap (opcode :move (operand :cvar miss-fn)
-                                  miss-fn-reg)
-                                                             ; get the miss function
-                     (opcode :jmp miss-fn-reg))))
-
-                                                             ; and call it
-
-
-(defun dlap-wrappers (metatypes)
-       (mapcar #'(lambda (x)
-                        (and (neq x 't)
-                             (allocate-register 'vector)))
-              metatypes))
-
-(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
-       (gathering1 (collecting)
-              (iterate ((mt (list-elements metatypes))
-                        (arg (list-elements args))
-                        (wrapper (list-elements wrappers))
-                        (i (interval :from 0)))
-                     (when wrapper
-                         (gather1 (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))
-              ))
-
-(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
-       (let* ((wrappers (dlap-wrappers metatypes))
-              (nwrappers (remove nil wrappers))
-              (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs)))
-             (prog1 (emit-dlap-internal nwrappers wrapper-moves hit miss miss-label value-reg)
-                 (mapc #'deallocate-register nwrappers))))
-
-(defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg)
-       (cond ((cdr wrapper-regs)
-              (emit-greater-than-1-dlap wrapper-regs wrapper-moves hit miss miss-label value-reg))
-             ((null value-reg)
-              (emit-1-nil-dlap (car wrapper-regs)
-                     (car wrapper-moves)
-                     hit miss miss-label))
-             (t (emit-1-t-dlap (car wrapper-regs)
-                       (car wrapper-moves)
-                       hit miss miss-label value-reg))))
-
-(defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label)
-       (with-lap-registers ((location index)
-                            (primary index)
-                            (cache vector))
-              (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
-                                               cache)
-                     (with-lap-registers ((wrapper-cache-no index))
-                            (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper 
-                                                primary wrapper-cache-no)
-                                   (opcode :move primary location)
-                                   (emit-check-1-wrapper-in-cache cache location wrapper hit)
-                                                             ; inline hit code
-                                   (opcode :izerop wrapper-cache-no miss-label)))
-                     (with-lap-registers ((size index))
-                            (flatten-lap (opcode :move (operand :cvar 'size)
-                                                size)
-                                   (opcode :label 'loop)
-                                   (opcode :move (operand :i1+ location)
-                                          location)
-                                   (opcode :fix= location primary miss-label)
-                                   (opcode :fix= location size 'set-location-to-min)
-                                   (opcode :label 'continue)
-                                   (emit-check-1-wrapper-in-cache cache location wrapper hit)
-                                   (opcode :go 'loop)
-                                   (opcode :label 'set-location-to-min)
-                                   (opcode :izerop primary miss-label)
-                                   (opcode :move (operand :constant (index-value->index 0))
-                                          location)
-                                   (opcode :go 'continue)))
-                     miss)))
-
-
-;;; The function below implements CACHE-LOCK-COUNT as the first entry in a cache (svref cache 0). 
-;;; This should probably be abstracted. 
-
-
-(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value)
-       (with-lap-registers ((location index)
-                            (primary index)
-                            (cache vector)
-                            (initial-lock-count t))
-              (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
-                                               cache)
-                     (with-lap-registers ((wrapper-cache-no index))
-                            (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper 
-                                                primary wrapper-cache-no)
-                                   (opcode :move primary location)
-                                   (opcode :move (operand :cref cache 0)
-                                          initial-lock-count)
-                                                             ; get lock-count
-                                   (emit-check-cache-entry cache location wrapper 'hit-internal)
-                                   (opcode :izerop wrapper-cache-no miss-label)))
-                                                             ; check for obsolescence
-                     (with-lap-registers ((size index))
-                            (flatten-lap (opcode :move (operand :cvar 'size)
-                                                size)
-                                   (opcode :label 'loop)
-                                   (opcode :move (operand :i1+ location)
-                                          location)
-                                   (opcode :move (operand :i1+ location)
-                                          location)
-                                   (opcode :label 'continue)
-                                   (opcode :fix= location primary miss-label)
-                                   (opcode :fix= location size 'set-location-to-min)
-                                   (emit-check-cache-entry cache location wrapper 'hit-internal)
-                                   (opcode :go 'loop)
-                                   (opcode :label 'set-location-to-min)
-                                   (opcode :izerop primary miss-label)
-                                   (opcode :move (operand :constant (index-value->index 2))
-                                          location)
-                                   (opcode :go 'continue)))
-                     (opcode :label 'hit-internal)
-                     (opcode :move (operand :i1+ location)
-                            location)
-                                                             ; position for getting value
-                     (opcode :move (emit-cache-ref cache location)
-                            value)
-                     (emit-lock-count-test initial-lock-count cache 'hit)
-                     miss
-                     (opcode :label 'hit)
-                     hit)))
-
-(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
-       (let ((cache-line-size (compute-line-size (+ (length wrappers)
-                                                    (if value
-                                                        1
-                                                        0)))))
-            (with-lap-registers ((location index)
-                                 (primary index)
-                                 (cache vector)
-                                 (initial-lock-count t)
-                                 (next-location index)
-                                 (line-size index))
-                                                             ; Line size holds a constant that can
-                                                             ; be folded in if there was a way to
-                                                             ; add a constant to an index register 
-                   (flatten-lap (apply #'flatten-lap wrapper-moves)
-                          (opcode :move (operand :constant cache-line-size)
-                                 line-size)
-                          (opcode :move (operand :cvar 'cache)
-                                 cache)
-                          (emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label)
-                          (opcode :move primary location)
-                          (opcode :move location next-location)
-                          (opcode :move (operand :cref cache 0)
-                                 initial-lock-count)
-                                                             ; get the lock-count
-                          (with-lap-registers ((size index))
-                                 (flatten-lap (opcode :move (operand :cvar 'size)
-                                                     size)
-                                        (opcode :label 'continue)
-                                        (opcode :move (operand :i+ location line-size)
-                                               next-location)
-                                        (emit-check-cache-line cache location wrappers 'hit)
-                                        (emit-adjust-location location next-location primary size
-                                               'continue miss-label)
-                                        (opcode :label 'hit)
-                                        (and value (opcode :move (emit-cache-ref cache location)
-                                                          value))
-                                        (emit-lock-count-test initial-lock-count cache 'hit-internal)
-                                        miss
-                                        (opcode :label 'hit-internal)
-                                        hit))))))
-
-
-;;; Cache related lap code 
-
-
-(defun emit-check-1-wrapper-in-cache (cache location wrapper hit-code)
-       (let ((exit-emit-check-1-wrapper-in-cache (make-symbol "exit-emit-check-1-wrapper-in-cache")))
-            (with-lap-registers ((cwrapper vector))
-                   (flatten-lap (opcode :move (emit-cache-ref cache location)
-                                       cwrapper)
-                          (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache)
-                          hit-code
-                          (opcode :label exit-emit-check-1-wrapper-in-cache)))))
-
-(defun emit-check-cache-entry (cache location wrapper hit-label)
-       (with-lap-registers ((cwrapper vector))
-              (flatten-lap (opcode :move (emit-cache-ref cache location)
-                                  cwrapper)
-                     (opcode :eq cwrapper wrapper hit-label))))
-
-(defun emit-check-cache-line (cache location wrappers hit-label)
-       (let ((checks (flatten-lap (gathering1 (flattening-lap)
-                                         (iterate ((wrapper (list-elements wrappers)))
-                                                (with-lap-registers ((cwrapper vector))
-                                                       (gather1 (flatten-lap (opcode :move
-                                                                                    (emit-cache-ref
-                                                                                     cache location)
-                                                                                    cwrapper)
-                                                                       (opcode :neq cwrapper wrapper
-                                                                              
-                                                                              '
-                                                                           exit-emit-check-cache-line
-                                                                              )
-                                                                       (opcode :move (operand :i1+ 
-                                                                                            location)
-                                                                              location)))))))))
-            (flatten-lap checks (opcode :go hit-label)
-                   (opcode :label 'exit-emit-check-cache-line))))
-
-(defun emit-lock-count-test (initial-lock-count cache hit-label)
-       
-       ;; jumps to hit-label if cache-lock-count consistent, otherwise, continues 
-       (with-lap-registers ((new-lock-count t))
-              (flatten-lap (opcode :move (operand :cref cache 0)
-                                  new-lock-count)
-                                                             ; get new cache-lock-count
-                     (opcode :fix= new-lock-count initial-lock-count hit-label))))
-
-(defun emit-adjust-location (location next-location primary size cont-label miss-label)
-       (flatten-lap (opcode :move next-location location)
-              (opcode :fix= location size 'at-end-of-cache)
-              (opcode :fix= location primary miss-label)
-              (opcode :go cont-label)
-              (opcode :label 'at-end-of-cache)
-              (opcode :fix= primary (operand :constant (index-value->index 1))
-                     miss-label)
-              (opcode :move (operand :constant (index-value->index 1))
-                     location)
-              (opcode :go cont-label)))
diff --git a/obsolete/clos/2.0/env.lisp b/obsolete/clos/2.0/env.lisp
deleted file mode 100644
index 15bf87f2..00000000
--- a/obsolete/clos/2.0/env.lisp
+++ /dev/null
@@ -1,200 +0,0 @@
-;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-;;; Basic environmental stuff.
-;;;
-
-(in-package 'clos)
-
-
-
-;;;
-;;;
-;;;
-
-(defgeneric describe-object (object stream))
-
-
-(defmethod describe-object ((object standard-object) stream)
-  (let* ((class (class-of object))
-	 (slotds (slots-to-inspect class object))
-	 (max-slot-name-length 0)
-	 (instance-slotds ())
-	 (class-slotds ())
-	 (other-slotds ()))
-    (flet ((adjust-slot-name-length (name)
-	     (setq max-slot-name-length
-		   (max max-slot-name-length
-			(length (the string (symbol-name name))))))
-	   (describe-slot (name value &optional (allocation () alloc-p))
-	     (if alloc-p
-		 (format stream
-			 "~% ~A ~S ~VT  ~S"
-			 name allocation (+ max-slot-name-length 7) value)
-		 (format stream
-			 "~% ~A~VT  ~S"
-			 name max-slot-name-length value))))
-      ;; Figure out a good width for the slot-name column.
-      (dolist (slotd slotds)
-	(adjust-slot-name-length (slotd-name slotd))
-	(case (slotd-allocation slotd)
-	  (:instance (push slotd instance-slotds))
-	  (:class  (push slotd class-slotds))
-	  (otherwise (push slotd other-slotds))))
-      (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
-      (format stream "~%~S is an instance of class ~S:" object class)
-
-      (when instance-slotds
-	(format stream "~% The following slots have :INSTANCE allocation:")
-	(dolist (slotd (nreverse instance-slotds))
-	  (describe-slot (slotd-name slotd)
-			 (slot-value-or-default object (slotd-name slotd)))))
-
-      (when class-slotds
-	(format stream "~% The following slots have :CLASS allocation:")
-	(dolist (slotd (nreverse class-slotds))
-	  (describe-slot (slotd-name slotd)
-			 (slot-value-or-default object (slotd-name slotd)))))
-
-      (when other-slotds 
-	(format stream "~% The following slots have allocation as shown:")
-	(dolist (slotd (nreverse other-slotds))
-	  (describe-slot (slotd-name slotd)
-			 (slot-value-or-default object (slotd-name slotd))
-			 (slotd-allocation slotd))))
-      (values))))
-
-(defmethod slots-to-inspect ((class std-class) (object standard-object))
-  (class-slots class))
-
-;;;
-;;;
-;;;
-(defmethod describe-object ((class class) stream)
-  (flet ((pretty-class (c) (or (class-name c) c)))
-    (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
-      (ft "~&~S is a class, it is an instance of ~S.~%"
-	  class (pretty-class (class-of class)))
-      (let ((name (class-name class)))
-	(if name
-	    (if (eq class (find-class name nil))
-		(ft "Its proper name is ~S.~%" name)
-		(ft "Its name is ~S, but this is not a proper name.~%" name))
-	    (ft "It has no name (the name is NIL).~%")))
-      (ft "The direct superclasses are: ~:S, and the direct~%~
-           subclasses are: ~:S.  The class precedence list is:~%~S~%~
-           There are ~D methods specialized for this class."
-	  (mapcar #'pretty-class (class-direct-superclasses class))
-	  (mapcar #'pretty-class (class-direct-subclasses class))
-	  (mapcar #'pretty-class (class-precedence-list class))
-	  (length (specializer-methods class))))))
-
-
-
-;;;
-;;; trace-method and untrace-method accept method specs as arguments.  A
-;;; method-spec should be a list like:
-;;;   (<generic-function-spec> qualifiers* (specializers*))
-;;; where <generic-function-spec> should be either a symbol or a list
-;;; of (SETF <symbol>).
-;;;
-;;;   For example, to trace the method defined by:
-;;;
-;;;     (defmethod foo ((x spaceship)) 'ss)
-;;;
-;;;   You should say:
-;;;
-;;;     (trace-method '(foo (spaceship)))
-;;;
-;;;   You can also provide a method object in the place of the method
-;;;   spec, in which case that method object will be traced.
-;;;
-;;; For untrace-method, if an argument is given, that method is untraced.
-;;; If no argument is given, all traced methods are untraced.
-;;;
-(defclass traced-method (method)
-     ((method :initarg :method)
-      (function :initarg :function
-		:reader method-function)
-      (generic-function :initform nil
-			:accessor method-generic-function)))
-
-(defmethod method-lambda-list ((m traced-method))
-  (with-slots (method) m (method-lambda-list method)))
-
-(defmethod method-specializers ((m traced-method))
-  (with-slots (method) m (method-specializers method)))
-
-(defmethod method-qualifiers ((m traced-method))
-  (with-slots (method) m (method-qualifiers method)))
-
-(defmethod method-qualifiers ((m traced-method))
-  (with-slots (method) m (method-qualifiers method)))
-
-(defmethod accessor-method-slot-name ((m traced-method))
-  (with-slots (method) m (accessor-method-slot-name method)))
-
-(defvar *traced-methods* ())
-
-(defun trace-method (spec &rest options)
-  (multiple-value-bind (gf omethod name)
-      (parse-method-or-spec spec)
-    (let* ((tfunction (trace-method-internal (method-function omethod)
-					     name
-					     options))
-	   (tmethod (make-instance 'traced-method
-				   :method omethod
-				   :function tfunction)))
-      (remove-method gf omethod)
-      (add-method gf tmethod)
-      (pushnew tmethod *traced-methods*)
-      tmethod)))
-
-(defun untrace-method (&optional spec)  
-  (flet ((untrace-1 (m)
-	   (let ((gf (method-generic-function m)))
-	     (when gf
-	       (remove-method gf m)
-	       (add-method gf (slot-value m 'method))
-	       (setq *traced-methods* (remove m *traced-methods*))))))
-    (if (not (null spec))
-	(multiple-value-bind (gf method)	    
-	    (parse-method-or-spec spec)
-	  (declare (ignore gf))
-	  (if (memq method *traced-methods*)
-	      (untrace-1 method)
-	      (error "~S is not a traced method?" method)))
-	(dolist (m *traced-methods*) (untrace-1 m)))))
-
-(defun trace-method-internal (ofunction name options)
-  (eval `(untrace ,name))
-  (setf (symbol-function name) ofunction)
-  (eval `(trace ,name ,@options))
-  (symbol-function name))
-
-
-
-
-;(defun compile-method (spec)
-;  (multiple-value-bind (gf method name)
-;      (parse-method-or-spec spec)
-;    (declare (ignore gf))
-;    (compile name (method-function method))
-;    (setf (method-function method) (symbol-function name))))
-
-(defmacro undefmethod (&rest args)
-  #+(or (not :lucid) :lcl3.0)
-  (declare (arglist name {method-qualifier}* specializers))
-  `(undefmethod-1 ',args))
-
-(defun undefmethod-1 (args)
-  (multiple-value-bind (gf method)
-      (parse-method-or-spec args)
-    (when (and gf method)
-      (remove-method gf method)
-      method)))
-
diff --git a/obsolete/clos/2.0/fin.lisp b/obsolete/clos/2.0/fin.lisp
deleted file mode 100644
index c8de5102..00000000
--- a/obsolete/clos/2.0/fin.lisp
+++ /dev/null
@@ -1,235 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;; File converted on 26-Mar-91 10:33:34 from source fin
-;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>fin.;3 created 19-Feb-91 16:21:49
-
-;;;. Copyright (c) 1991 by Venue
-
-
-
-
-(in-package "CLOS")
-
-;;; Shadow, Export, Require, Use-package, and Import forms should follow here
-
-
-
-
-
-
-;; 
-
-
-
-;;; FUNCALLABLE INSTANCES
-
-
-
-;; 
-
-
-
-;;; The first part of the file contains the implementation dependent code to implement funcallable
-;;; instances.  Each implementation must provide the following functions and macros:
-;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 () should create and return a new funcallable instance.  The
-;;; funcallable-instance-data slots must be initialized to NIL. This is called by
-;;; allocate-funcallable-instance and by the bootstrapping code. FUNCALLABLE-INSTANCE-P (x) the
-;;; obvious predicate.  This should be an INLINE function. it must be funcallable, but it would be
-;;; nice if it compiled open. SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value) change the fin so
-;;; that when it is funcalled, the new-value function is called.  Note that it is legal for
-;;; new-value to be copied before it is installed in the fin, specifically there is no accessor for
-;;; a FIN's function so this function does not have to preserve the actual new value.  The new-value
-;;; argument can be any funcallable thing, a closure, lambda compiled code etc.  This function must
-;;; coerce those values if necessary. NOTE: new-value is almost always a compiled closure.  This is
-;;; the important case to optimize. FUNCALLABLE-INSTANCE-DATA-1 (fin data-name) should return the
-;;; value of the data named data-name in the fin. data-name is one of the symbols in the list which
-;;; is the value of funcallable-instance-data.  Since data-name is almost always a quoted symbol and
-;;; funcallable-instance-data is a constant, it is possible (and worthwhile) to optimize the
-;;; computation of data-name's offset in the data part of the fin. This must be SETF'able. 
-
-
-(defconstant funcallable-instance-data '(wrapper slots)
-       "These are the 'data-slots' which funcallable instances have so that
-   the meta-class funcallable-standard-class can store class, and static
-   slots in them.")
-
-(defmacro funcallable-instance-data-position (data)
-       (if (and (consp data)
-                (eq (car data)
-                    'quote)
-                (boundp 'funcallable-instance-data))
-           (or (position (cadr data)
-                      funcallable-instance-data :test #'eq)
-               (progn (warn "Unknown funcallable-instance data: ~S." (cadr data))
-                      `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
-           `(position ,data funcallable-instance-data :test #'eq)))
-
-(defun called-fin-without-function nil (error "Attempt to funcall a funcallable-instance without first~%~
-          setting its funcallable-instance-function."))
-
-
-;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and CCODEP.  The environment
-;;; is represented as a block.  There is space in the top 8 bits of the pointers to the CCODE and
-;;; the environment to use to mark the closure as being a FIN. To help the debugger figure out when
-;;; it has found a FIN on the stack, we reserve the last element of the closure environment to use
-;;; to point back to the actual fin. Note that there is code in xerox-low which lets us access the
-;;; fields of compiled-closures and which defines the closure-overlay record.  That code is there
-;;; because there are some clients of it in that file. 
-
-
-
-;; Don't be fooled.  We actually allocate one bigger than this to have a place to store the
-;; backpointer to the fin.  -smL 
-
-
-(defconstant funcallable-instance-closure-size 15)
-
-(defvar *fin-env-type* (type-of (il:\\allocblock (1+ funcallable-instance-closure-size)
-                                       t)))
-
-
-;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
-
-
-(defstruct fin-env-pointer (pointer nil :type il:fullxpointer))
-
-(defun fin-env-fin (fin-env)
-       (fin-env-pointer-pointer (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
-
-(defun |set fin-env-fin| (fin-env new-value)
-       (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
-              (make-fin-env-pointer :pointer new-value))
-       new-value)
-
-(defsetf fin-env-fin |set fin-env-fin|)
-
-
-;; The finalization function that will clean up the backpointer from the fin-env to the fin.  This
-;; needs to be careful to not cons at all.  This depends on there being no other finalization
-;; function on compiled-closures, since there is only one finalization function per datatype.  Too
-;; bad.  -smL 
-
-
-(defun finalize-fin (fin)
-       
-       ;; This could use the fn funcallable-instance-p, but if we get here we know that this is a
-       ;; closure, so we can skip that test. 
-       (when (il:fetch (closure-overlay funcallable-instance-p)
-                    il:of fin)
-           (let ((env (il:fetch (il:compiled-closure il:environment)
-                             il:of fin)))
-                (when env
-                    (setq env (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
-                    (when (typep env 'fin-env-pointer)
-                        (setf (fin-env-pointer-pointer env)
-                              nil)))))
-       nil)
-
-(eval-when (load)
-       
-       ;; Install the above finalization function.
-       (when (fboundp 'finalize-fin)
-           (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
-
-(defun allocate-funcallable-instance-1 nil (let* ((env (il:\\allocblock (1+ 
-                                                                    funcallable-instance-closure-size
-                                                                            )
-                                                              t))
-                                                  (fin (il:make-compiled-closure nil env)))
-                                                 (setf (fin-env-fin env)
-                                                       fin)
-                                                 (il:replace (closure-overlay funcallable-instance-p)
-                                                        il:of fin il:with 't)
-                                                 (set-funcallable-instance-function
-                                                  fin
-                                                  #'(lambda (&rest ignore)
-                                                           (declare (ignore ignore))
-                                                           (called-fin-without-function)))
-                                                 fin))
-
-(xcl:definline funcallable-instance-p (x)
-       (and (typep x 'il:compiled-closure)
-            (il:fetch (closure-overlay funcallable-instance-p)
-                   il:of x)))
-
-(defun set-funcallable-instance-function (fin new)
-       (cond ((not (funcallable-instance-p fin))
-              (error "~S is not a funcallable-instance" fin))
-             ((not (functionp new))
-              (error "~S is not a function." new))
-             ((typep new 'il:compiled-closure)
-              (let* ((fin-env (il:fetch (il:compiled-closure il:environment)
-                                     il:of fin))
-                     (new-env (il:fetch (il:compiled-closure il:environment)
-                                     il:of new))
-                     (new-env-size (if new-env
-                                       (il:\\#blockdatacells new-env)
-                                       0))
-                     (fin-env-size (- funcallable-instance-closure-size (length 
-                                                                            funcallable-instance-data
-                                                                               ))))
-                    (cond ((and new-env (<= new-env-size fin-env-size))
-                           (dotimes (i fin-env-size)
-                               (il:\\rplptr fin-env (* i 2)
-                                      (if (< i new-env-size)
-                                          (il:\\getbaseptr new-env (* i 2))
-                                          nil)))
-                           (setf (compiled-closure-fnheader fin)
-                                 (compiled-closure-fnheader new)))
-                          (t (set-funcallable-instance-function fin (make-trampoline new))))))
-             (t (set-funcallable-instance-function fin (make-trampoline new)))))
-
-(defun make-trampoline (function)
-       #'(lambda (&rest args)
-                (apply function args)))
-
-(defmacro funcallable-instance-data-1 (fin data)
-       `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment)
-                                il:of
-                                ,fin)
-               (* (- funcallable-instance-closure-size (funcallable-instance-data-position
-                                                        ,data)
-                     1)
-                                                             ; Reserve last element to point back to
-                                                             ; actual FIN! 
-                  2)))
-
-(defsetf funcallable-instance-data-1 (fin data)
-       (new-value)
-       `(il:\\rplptr (il:fetch (il:compiled-closure il:environment)
-                            il:of
-                            ,fin)
-               (* (- funcallable-instance-closure-size (funcallable-instance-data-position
-                                                        ,data)
-                     1)
-                  2)
-               ,new-value))
-
-                                                             ; end of #+Xerox
-
-
-
-;;; 
-
-
-(defmacro fsc-instance-p (fin)
-       `(funcallable-instance-p ,fin))
-
-(defmacro fsc-instance-class (fin)
-       `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
-
-(defmacro fsc-instance-wrapper (fin)
-       `(funcallable-instance-data-1 ,fin 'wrapper))
-
-(defmacro fsc-instance-slots (fin)
-       `(funcallable-instance-data-1 ,fin 'slots))
-
-(defun allocate-funcallable-instance (wrapper number-of-static-slots)
-       (let ((fin (allocate-funcallable-instance-1))
-             (slots (%allocate-static-slot-storage--class number-of-static-slots)))
-            (setf (fsc-instance-wrapper fin)
-                  wrapper
-                  (fsc-instance-slots fin)
-                  slots)
-            fin))
diff --git a/obsolete/clos/2.0/fixup.lisp b/obsolete/clos/2.0/fixup.lisp
deleted file mode 100644
index 13d1c52c..00000000
--- a/obsolete/clos/2.0/fixup.lisp
+++ /dev/null
@@ -1,15 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;;. Copyright (c) 1991 by Venue
-
-(in-package "CLOS")
-
-
-(eval-when (compile load eval)
-       (fix-early-generic-functions)
-       (setq *boot-state* 'complete))
-
-(defun print-std-instance (instance stream depth)
-       (declare (ignore depth))
-       (print-object instance stream))
diff --git a/obsolete/clos/2.0/fngen.lisp b/obsolete/clos/2.0/fngen.lisp
deleted file mode 100644
index 09e6d0da..00000000
--- a/obsolete/clos/2.0/fngen.lisp
+++ /dev/null
@@ -1,172 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-;;;. Copyright (c) 1991 by Venue
-
-(in-package "CLOS")
-
-
-
-;;; GET-FUNCTION is the main user interface to this code.  If it is called with a lambda expression
-;;; only, it will return a corresponding function. The optional constant-converter argument, can be
-;;; a function which will be called to convert each constant appearing in the lambda to whatever
-;;; value should appear in the function. Whether the returned function is actually compiled depends
-;;; on whether the compiler is present (see COMPILE-LAMBDA) and whether this shape of code was
-;;; precompiled. 
-
-
-(defun get-function (lambda &optional (test-converter #'default-test-converter)
-                           (code-converter #'default-code-converter)
-                           (constant-converter #'default-constant-converter))
-       (apply (get-function-generator lambda test-converter code-converter)
-              (compute-constants lambda constant-converter)))
-
-(defun default-test-converter (form)
-       (if (not (constantp form))
-           form
-           '.constant.))
-
-(defun default-code-converter (form)
-       (if (not (constantp form))
-           form
-           (let ((gensym (gensym)))
-                (values gensym (list gensym)))))
-
-(defun default-constant-converter (form)
-       (and (constantp form)
-            (list (if (and (consp form)
-                           (eq (car form)
-                               'quote))
-                                                             ; This had better
-                      (cadr form)
-                                                             ; do the same as
-                      form))))
-
-                                                             ; EVAL would have.
-
-
-
-;;; *fgens* is a list of all the function generators we have so far.  Each element is a FGEN
-;;; structure as implemented below.  Don't ever touch this list by hand, use STORE-FGEN. 
-
-
-(defvar *fgens* nil)
-
-(defun store-fgen (fgen)
-       (setq *fgens* (nconc *fgens* (list fgen))))
-
-(defun lookup-fgen (test)
-       (find test (the list *fgens*)
-             :key
-             #'fgen-test :test #'equal))
-
-(defun make-fgen (test gensyms generator generator-lambda system)
-       (let ((new (make-array 6)))
-            (setf (svref new 0)
-                  test
-                  (svref new 1)
-                  gensyms
-                  (svref new 2)
-                  generator
-                  (svref new 3)
-                  generator-lambda
-                  (svref new 4)
-                  system)
-            new))
-
-(defun fgen-test (fgen)
-       (svref fgen 0))
-
-(defun fgen-gensyms (fgen)
-       (svref fgen 1))
-
-(defun fgen-generator (fgen)
-       (svref fgen 2))
-
-(defun fgen-generator-lambda (fgen)
-       (svref fgen 3))
-
-(defun fgen-system (fgen)
-       (svref fgen 4))
-
-(defun get-function-generator (lambda test-converter code-converter)
-       (let* ((test (compute-test lambda test-converter))
-              (fgen (lookup-fgen test)))
-             (if fgen
-                 (fgen-generator fgen)
-                 (get-new-function-generator lambda test code-converter))))
-
-(defun get-new-function-generator (lambda test code-converter)
-       (multiple-value-bind (gensyms generator-lambda)
-              (get-new-function-generator-internal lambda code-converter)
-              (let* ((generator (compile-lambda generator-lambda))
-                     (fgen (make-fgen test gensyms generator generator-lambda nil)))
-                    (store-fgen fgen)
-                    generator)))
-
-(defun get-new-function-generator-internal (lambda code-converter)
-       (multiple-value-bind (code gensyms)
-              (compute-code lambda code-converter)
-              (values gensyms `(lambda ,gensyms #',code))))
-
-(defun compute-test (lambda test-converter)
-       (walk-form lambda nil #'(lambda (f c e)
-                                      (declare (ignore e))
-                                      (if (neq c :eval)
-                                          f
-                                          (let ((converted (funcall test-converter f)))
-                                               (values converted (neq converted f)))))))
-
-(defun compute-code (lambda code-converter)
-       (let ((gensyms nil))
-            (values (walk-form lambda nil #'(lambda (f c e)
-                                                   (declare (ignore e))
-                                                   (if (neq c :eval)
-                                                       f
-                                                       (multiple-value-bind
-                                                        (converted gens)
-                                                        (funcall code-converter f)
-                                                        (when gens
-                                                            (setq gensyms (append gensyms gens)))
-                                                        (values converted (neq converted f))))))
-                   gensyms)))
-
-(defun compute-constants (lambda constant-converter)
-       (macrolet ((appending nil `(let ((result nil))
-                                       (values #'(lambda (value)
-                                                        (setq result (append result value)))
-                                              #'(lambda nil result)))))
-              (gathering1 (appending)
-                     (walk-form lambda nil #'(lambda (f c e)
-                                                    (declare (ignore e))
-                                                    (if (neq c :eval)
-                                                        f
-                                                        (let ((consts (funcall constant-converter f))
-                                                              )
-                                                             (if consts
-                                                                 (progn (gather1 consts)
-                                                                        (values f t))
-                                                                 f))))))))
-
-
-;;; 
-
-
-(defmacro
- precompile-function-generators
- (&optional system)
- (make-top-level-form
-  `(precompile-function-generators ,system)
-  '(load)
-  `(progn ,@(gathering1 (collecting)
-                   (dolist (fgen *fgens*)
-                       (when (or (null (fgen-system fgen))
-                                 (eq (fgen-system fgen)
-                                     system))
-                           (gather1 `(load-function-generator ',(fgen-test fgen)
-                                            ',(fgen-gensyms fgen)
-                                            #',(fgen-generator-lambda fgen)
-                                            ',(fgen-generator-lambda fgen)
-                                            ',system))))))))
-
-(defun load-function-generator (test gensyms generator generator-lambda system)
-       (store-fgen (make-fgen test gensyms generator generator-lambda system)))
diff --git a/obsolete/clos/2.0/fsc.lisp b/obsolete/clos/2.0/fsc.lisp
deleted file mode 100644
index a2670af9..00000000
--- a/obsolete/clos/2.0/fsc.lisp
+++ /dev/null
@@ -1,72 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-;;;. Copyright (c) 1991 by Venue
-
-
-(in-package "CLOS")
-
-
-;;; This file contains the
-;;; definition of the FUNCALLABLE-STANDARD-CLASS metaclass.  Much of the implementation of this
-;;; metaclass is actually defined on the class STD-CLASS.  What appears in this file is a modest
-;;; number of simple methods related to the low-level differences in the implementation of standard
-;;; and funcallable-standard instances. As it happens, none of these differences are the ones
-;;; reflected in the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS share all
-;;; their specified methods at STD-CLASS. workings of this metaclass and the standard-class
-;;; metaclass. 
-
-
-(defmethod wrapper-fetcher ((class funcallable-standard-class))
-       'fsc-instance-wrapper)
-
-(defmethod slots-fetcher ((class funcallable-standard-class))
-       'fsc-instance-slots)
-
-(defmethod raw-instance-allocator ((class funcallable-standard-class))
-       'allocate-funcallable-instance-1)
-
-
-;;; 
-
-
-(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class)
-                                                (class standard-class))
-       (null (wrapper-instance-slots-layout (class-wrapper class))))
-
-(defmethod allocate-instance ((class funcallable-standard-class)
-                              &rest initargs)
-       (declare (ignore initargs))
-       (unless (class-finalized-p class)
-              (finalize-inheritance class))
-       (let ((class-wrapper (class-wrapper class)))
-            (allocate-funcallable-instance class-wrapper (class-no-of-instance-slots class))))
-
-(defmethod make-reader-method-function ((class funcallable-standard-class)
-                                        slot-name)
-       (make-std-reader-method-function slot-name))
-
-(defmethod make-writer-method-function ((class funcallable-standard-class)
-                                        slot-name)
-       (make-std-writer-method-function slot-name))
-
-                                                             ; See the comment about
-                                                             ; reader-function--std and
-                                                             ; writer-function--sdt.
-                                                             ; (define-function-template
-                                                             ; reader-function--fsc () '(slot-name)
-                                                             ; `(function (lambda (instance)
-                                                             ; (slot-value-using-class
-                                                             ; (wrapper-class (get-wrapper
-                                                             ; instance)) instance slot-name))))
-                                                             ; (define-function-template
-                                                             ; writer-function--fsc () '(slot-name)
-                                                             ; `(function (lambda (nv instance)
-                                                             ; (setf (slot-value-using-class
-                                                             ; (wrapper-class (get-wrapper
-                                                             ; instance)) instance slot-name) nv))))
-                                                             ; (eval-when (load)
-                                                             ; (pre-make-templated-function-constructor
-                                                             ; reader-function--fsc)
-                                                             ; (pre-make-templated-function-constructor
-                                                             ; writer-function--fsc)) 
-
diff --git a/obsolete/clos/2.0/init.lisp b/obsolete/clos/2.0/init.lisp
deleted file mode 100644
index d44e50ef..00000000
--- a/obsolete/clos/2.0/init.lisp
+++ /dev/null
@@ -1,183 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-;;;. Copyright (c) 1991 by Venue
-
-(in-package "CLOS")
-
-;;; this file defines the
-;;; initialization and related protocols. 
-
-
-(defmethod make-instance ((class std-class)
-                          &rest initargs)
-       (unless (class-finalized-p class)
-              (finalize-inheritance class))
-       (setq initargs (default-initargs class initargs))
-       (when initargs
-           (when (and (eq *boot-state* 'complete)
-                      (let ((tail initargs))
-                           (loop (unless tail (return t))
-                                 (when (eq (car tail)
-                                           ':allow-other-keys)
-                                       (return nil))
-                                 (setq tail (cddr tail)))))
-               (check-initargs-1 class initargs (append (compute-applicable-methods 
-                                                               #'allocate-instance (list class))
-                                                       (compute-applicable-methods
-                                                        #'initialize-instance
-                                                        (list (class-prototype class)))
-                                                       (compute-applicable-methods
-                                                        #'shared-initialize
-                                                        (list (class-prototype class)
-                                                              t))))))
-       (let ((instance (apply #'allocate-instance class initargs)))
-            (apply #'initialize-instance instance initargs)
-            instance))
-
-(defmethod make-instance ((class-name symbol)
-                          &rest initargs)
-       (apply #'make-instance (find-class class-name)
-              initargs))
-
-(defvar *default-initargs-flag* (list nil))
-
-(defmethod default-initargs ((class std-class)
-                             supplied-initargs)
-       
-       ;; This implementation of default initargs is critically dependent on all-default-initargs
-       ;; not having any duplicate initargs in it. 
-       (let ((all-default (class-default-initargs class))
-             (miss *default-initargs-flag*))
-            (flet ((getf* (plist key)
-                          (do nil
-                              ((null plist)
-                               miss)
-                            (if (eq (car plist)
-                                    key)
-                                (return (cadr plist))
-                                (setq plist (cddr plist))))))
-                  (labels ((default-1 (tail)
-                                  (if (null tail)
-                                      nil
-                                      (if (eq (getf* supplied-initargs (caar tail))
-                                              miss)
-                                          (list* (caar tail)
-                                                 (funcall (cadar tail))
-                                                 (default-1 (cdr tail)))
-                                          (default-1 (cdr tail))))))
-                         (append supplied-initargs (default-1 all-default))))))
-
-(defmethod initialize-instance ((instance standard-object)
-                                &rest initargs)
-       (apply #'shared-initialize instance t initargs))
-
-(defmethod reinitialize-instance ((instance standard-object)
-                                  &rest initargs)
-       (when initargs
-           (when (eq *boot-state* 'complete)
-               (check-initargs-1 (class-of instance)
-                      initargs
-                      (append (compute-applicable-methods #'reinitialize-instance (list instance))
-                             (compute-applicable-methods #'shared-initialize (list instance t))))))
-       (apply #'shared-initialize instance nil initargs)
-       instance)
-
-(defmethod update-instance-for-different-class ((previous standard-object)
-                                                (current standard-object)
-                                                &rest initargs)
-       (when initargs
-           (check-initargs-1 (class-of current)
-                  initargs
-                  (append (compute-applicable-methods #'update-instance-for-different-class
-                                 (list previous current))
-                         (compute-applicable-methods #'shared-initialize (list current t)))))
-       
-       ;; First we must compute the newly added slots.  The spec defines newly added slots as "those
-       ;; local slots for which no slot of the same name exists in the previous class." 
-       (let ((added-slots 'nil)
-             (current-slotds (class-slots (class-of current)))
-             (previous-slot-names (mapcar #'slotd-name (class-slots (class-of previous)))))
-            (dolist (slotd current-slotds)
-                (if (and (not (memq (slotd-name slotd)
-                                    previous-slot-names))
-                         (eq (slotd-allocation slotd)
-                             ':instance))
-                    (push (slotd-name slotd)
-                          added-slots)))
-            (apply #'shared-initialize current added-slots initargs)))
-
-(defmethod update-instance-for-redefined-class ((instance standard-object)
-                                                added-slots discarded-slots property-list &rest 
-                                                initargs)
-       (declare (ignore discarded-slots property-list))
-       (when initargs
-           (check-initargs-1 (class-of instance)
-                  initargs
-                  (append (compute-applicable-methods #'update-instance-for-redefined-class
-                                 (list instance))
-                         (compute-applicable-methods #'shared-initialize (list instance nil)))))
-       (apply #'shared-initialize instance added-slots initargs))
-
-(defmethod shared-initialize ((instance standard-object)
-                              slot-names &rest initargs)
-       
-       ;; initialize the instance's slots in a two step process 1) A slot for which one of the
-       ;; initargs in initargs can set the slot, should be set by that initarg.  If more than one
-       ;; initarg in initargs can set the slot, the leftmost one should set it. 2) Any slot not set
-       ;; by step 1, may be set from its initform by step 2.  Only those slots specified by the
-       ;; slot-names argument are set.  If slot-names is: T any slot not set in step 1 is set from
-       ;; its initform <list of slot names> any slot in the list, and not set in step 1 is set from
-       ;; its initform () no slots are set from initforms 
-       (let* ((class (class-of instance))
-              (slotds (class-slots class)))
-             (dolist (slotd slotds)
-                 (let ((slot-name (slotd-name slotd))
-                       (slot-initargs (slotd-initargs slotd)))
-                      (flet ((from-initargs nil 
-
-                                    ;; Try to initialize the slot from one of the initargs. If we
-                                    ;; succeed return T, otherwise return nil. 
-                                    (doplist (initarg val)
-                                           initargs
-                                           (when (memq initarg slot-initargs)
-                                               (setf (slot-value instance slot-name)
-                                                     val)
-                                               (return 't))))
-                             (from-initforms nil 
-
-                                    ;; Try to initialize the slot from its initform.  This returns
-                                    ;; no meaningful value. 
-                                    (if (and slot-names (or (eq slot-names 't)
-                                                            (memq slot-name slot-names))
-                                             (not (slot-boundp instance slot-name)))
-                                        (let ((initfunction (slotd-initfunction slotd)))
-                                             (when initfunction
-                                                 (setf (slot-value instance slot-name)
-                                                       (funcall initfunction)))))))
-                            (or (from-initargs)
-                                (from-initforms))))))
-       instance)
-
-
-;;; if initargs are valid return nil, otherwise signal an error 
-
-
-(defun check-initargs-1 (class initargs methods)
-       (let ((legal (apply #'append (mapcar #'slotd-initargs (class-slots class)))))
-            (unless (getf initargs :allow-other-keys)
-                
-                ;; Add to the set of slot-filling initargs the set of initargs that are accepted by
-                ;; the methods.  If at any point we come across &allow-other-keys, we can just quit.
-                (dolist (method methods)
-                    (multiple-value-bind (keys allow-other-keys)
-                        (function-keywords method)
-                      (when allow-other-keys (return-from check-initargs-1 nil))
-                      (setq legal (append keys legal))))
-                
-                ;; Now check the supplied-initarg-names and the default initargs against the total
-                ;; set that we know are legal. 
-                (doplist (key val)
-                       initargs
-                       (unless (memq key legal)
-                           (error "Invalid initialization argument ~S for class ~S" key (class-name
-                                                                                         class)))))))
diff --git a/obsolete/clos/2.0/iterate.lisp b/obsolete/clos/2.0/iterate.lisp
deleted file mode 100644
index 212f819c..00000000
--- a/obsolete/clos/2.0/iterate.lisp
+++ /dev/null
@@ -1,1080 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CLIN-PACKAGE ITERATE USE (QUOTE (LISP WALKER))) 
-BASE 10)
-(IL:FILECREATED "19-Feb-91 13:55:29" 
-IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>ITERATE.;2| 65656  
-
-      IL:|changes| IL:|to:|  (IL:VARS IL:ITERATECOMS)
-
-      IL:|previous| IL:|date:| " 6-Feb-91 11:00:58" 
-IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>ITERATE.;1|)
-
-
-; Copyright (c) 1991 by Venue.  All rights reserved.
-
-(IL:PRETTYCOMPRINT IL:ITERATECOMS)
-
-(IL:RPAQQ IL:ITERATECOMS 
-          (
-
-(IL:* IL:|;;;| "************************************************************************* Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws. This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification. Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests for improvements are also welcome. ************************************************************************* Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 ")
-
-           (IL:P (IN-PACKAGE :ITERATE :USE '(:LISP :WALKER))
-                 (EXPORT '(ITERATE ITERATE* GATHERING GATHER WITH-GATHERING INTERVAL ELEMENTS 
-                                 LIST-ELEMENTS LIST-TAILS PLIST-ELEMENTS EACHTIME WHILE UNTIL 
-                                 COLLECTING JOINING MAXIMIZING MINIMIZING SUMMING *ITERATE-WARNINGS*)
-                        ))
-           (IL:VARIABLES *ITERATE-WARNINGS*)
-           
-
-(IL:* IL:|;;;| "ITERATE macro")
-
-           (IL:FUNCTIONS ITERATE SIMPLE-EXPAND-ITERATE-FORM)
-           (IL:VARIABLES *ITERATE-TEMP-VARS-LIST*)
-           (IL:FUNCTIONS OPTIMIZE-ITERATE-FORM EXPAND-INTO-LET VARIABLES-FROM-LET 
-                  ITERATE-TRANSFORM-BODY PARSE-DECLARATIONS EXTRACT-SPECIAL-BINDINGS 
-                  FUNCTION-LAMBDA-P RENAME-LET-BINDINGS RENAME-VARIABLES MV-SETQ VARIABLE-SAME-P 
-                  MAYBE-WARN)
-           
-           (IL:* IL:|;;| "Sample iterators")
-
-           (IL:FUNCTIONS INTERVAL LIST-ELEMENTS LIST-TAILS ELEMENTS PLIST-ELEMENTS SEQUENCE-ACCESSOR)
-           
-           (IL:* IL:|;;| "These \"iterators\" may be withdrawn")
-
-           (IL:FUNCTIONS EACHTIME WHILE UNTIL)
-                                                             (IL:* IL:\; "GATHERING macro")
-           (IL:FUNCTIONS GATHERING WITH-GATHERING SIMPLE-EXPAND-GATHERING-FORM)
-           (IL:VARIABLES *ACTIVE-GATHERERS* *ANONYMOUS-GATHERING-SITE*)
-           (IL:FUNCTIONS OPTIMIZE-GATHERING-FORM RENAME-AND-CAPTURE-VARIABLES WALK-GATHERING-BODY)
-           
-           (IL:* IL:|;;| "Sample gatherers")
-
-           (IL:FUNCTIONS COLLECTING JOINING MAXIMIZING MINIMIZING SUMMING)
-                                                             (IL:* IL:\; 
-                                           "Easier to read expanded code if PROG1 gets left alone ")
-           (XCL:FILE-ENVIRONMENTS "ITERATE")))
-
-
-
-(IL:* IL:|;;;| 
-"************************************************************************* Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this software and preparation of derivative works based upon this software are permitted.  Any distribution of this software or derivative works must comply with all applicable United States export control laws. This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification. Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests for improvements are also welcome. ************************************************************************* Original source {pooh/n}<pooh>vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 "
-)
-
-
-(IN-PACKAGE :ITERATE :USE '(:LISP :WALKER))
-
-(EXPORT '(ITERATE ITERATE* GATHERING GATHER WITH-GATHERING INTERVAL ELEMENTS LIST-ELEMENTS 
-                LIST-TAILS PLIST-ELEMENTS EACHTIME WHILE UNTIL COLLECTING JOINING MAXIMIZING 
-                MINIMIZING SUMMING *ITERATE-WARNINGS*))
-
-(DEFVAR *ITERATE-WARNINGS* :ANY "Controls whether warnings are issued for iterate/gather forms that aren't optimized.
-NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal."
-)
-
-
-
-(IL:* IL:|;;;| "ITERATE macro")
-
-
-(DEFMACRO ITERATE (CLAUSES &BODY BODY &ENVIRONMENT ENV)
-   (OPTIMIZE-ITERATE-FORM CLAUSES BODY ENV))
-
-(DEFUN SIMPLE-EXPAND-ITERATE-FORM (CLAUSES BODY)
-
-   (IL:* IL:|;;| 
- "Expand ITERATE.  This is the \"formal semantics\" expansion, which we never use. ")
-
-   (LET*
-    ((BLOCK-NAME (GENSYM))
-     (BOUND-VAR-LISTS (MAPCAR #'(LAMBDA (CLAUSE)
-                                       (LET ((NAMES (FIRST CLAUSE)))
-                                            (IF (LISTP NAMES)
-                                                NAMES
-                                                (LIST NAMES))))
-                             CLAUSES))
-     (GENERATOR-VARS (MAPCAR #'(LAMBDA (CLAUSE)
-                                      (DECLARE (IGNORE CLAUSE))
-                                      (GENSYM))
-                            CLAUSES)))
-    `(BLOCK ,BLOCK-NAME
-         (LET*
-          ,(MAPCAN #'(LAMBDA (GVAR CLAUSE VAR-LIST)          (IL:* IL:\; 
-            "For each clause, bind a generator temp to the clause, then bind the specified var(s) ")
-                            (CONS (LIST GVAR (SECOND CLAUSE))
-                                  (COPY-LIST VAR-LIST)))
-                  GENERATOR-VARS CLAUSES BOUND-VAR-LISTS)
-
-          (IL:* IL:|;;| "Note bug in formal semantics: there can be declarations in the head of BODY; they go here, rather than inside loop ")
-
-          (LOOP ,@(MAPCAR #'(LAMBDA (VAR-LIST GEN-VAR)       (IL:* IL:\; 
-   "Set each bound variable (or set of vars) to the result of calling the corresponding generator ")
-                                   `(MULTIPLE-VALUE-SETQ ,VAR-LIST
-                                           (FUNCALL ,GEN-VAR #'(LAMBDA NIL (RETURN-FROM ,BLOCK-NAME))
-                                                  )))
-                         BOUND-VAR-LISTS GENERATOR-VARS)
-                ,@BODY)))))
-
-(DEFPARAMETER *ITERATE-TEMP-VARS-LIST* '(ITERATE-TEMP-1 ITERATE-TEMP-2 ITERATE-TEMP-3 
-                                                   ITERATE-TEMP-4 ITERATE-TEMP-5 ITERATE-TEMP-6 
-                                                   ITERATE-TEMP-7 ITERATE-TEMP-8)
-                                           "Temp var names used by ITERATE expansions.")
-
-(DEFUN OPTIMIZE-ITERATE-FORM (CLAUSES BODY ITERATE-ENV)
-   (LET*
-    ((TEMP-VARS *ITERATE-TEMP-VARS-LIST*)
-     (BLOCK-NAME (GENSYM))
-     (FINISH-FORM `(RETURN-FROM ,BLOCK-NAME))
-     (BOUND-VARS (MAPCAN #'(LAMBDA (CLAUSE)
-                                  (LET ((NAMES (FIRST CLAUSE)))
-                                       (IF (LISTP NAMES)
-                                           (COPY-LIST NAMES)
-                                           (LIST NAMES))))
-                        CLAUSES))
-     ITERATE-DECLS GENERATOR-DECLS UPDATE-FORMS BINDINGS LEFTOVER-BODY)
-    (DO ((TAIL BOUND-VARS (CDR TAIL)))
-        ((NULL TAIL))                                        (IL:* IL:\; "Check for duplicates")
-      (WHEN (MEMBER (CAR TAIL)
-                   (CDR TAIL))
-          (WARN "Variable appears more than once in ITERATE: ~S" (CAR TAIL))))
-    (FLET
-     ((GET-ITERATE-TEMP NIL 
-
-             (IL:* IL:|;;| "Make temporary var.  Note that it is ok to re-use these symbols in each iterate, because they are not used within BODY. ")
-
-             (OR (POP TEMP-VARS)
-                 (GENSYM))))
-     (DOLIST (CLAUSE CLAUSES)
-         (COND
-            ((OR (NOT (CONSP CLAUSE))
-                 (NOT (CONSP (CDR CLAUSE))))
-             (WARN "Bad syntax in ITERATE: clause not of form (var iterator): ~S" CLAUSE))
-            (T
-             (UNLESS (NULL (CDDR CLAUSE))
-                    (WARN "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S" 
-                          CLAUSE))
-             (MULTIPLE-VALUE-BIND (LET-BODY BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS 
-                                         EXTRA-BODY)
-                 (EXPAND-INTO-LET (SECOND CLAUSE)
-                        'ITERATE ITERATE-ENV)
-
-               (IL:* IL:|;;| 
-             "We have expanded the generator clause and parsed it into its LET pieces. ")
-
-               (PROG* ((VARS (FIRST CLAUSE))
-                       GEN-ARGS RENAMED-VARS)
-                      (SETQ VARS (IF (LISTP VARS)
-                                     (COPY-LIST VARS)
-                                     (LIST VARS)))           (IL:* IL:\; 
-                           "VARS is now a (fresh) list of all iteration vars bound in this clause ")
-                      (COND
-                         ((EQ LET-BODY :ABORT)               (IL:* IL:\; 
-                                                    "Already issued a warning about malformedness ")
-                          )
-                         ((NULL (SETQ LET-BODY (FUNCTION-LAMBDA-P LET-BODY 1)))
-                                                             (IL:* IL:\; "Not of the expected form")
-                          (LET ((GENERATOR (SECOND CLAUSE)))
-                               (COND
-                                  ((AND (CONSP GENERATOR)
-                                        (FBOUNDP (CAR GENERATOR)))
-                                                             (IL:* IL:\; "It looks ok--a macro or function here--so the guy who wrote it just didn't do it in an optimizable way ")
-                                   (MAYBE-WARN :DEFINITION "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
-                                          GENERATOR))
-                                  (T                         (IL:* IL:\; 
-                                           "Perhaps it's just a misspelling?  Probably user error ")
-                                     (MAYBE-WARN :USER 
-                                            "Iterate operator in clause ~S is not fboundp." GENERATOR
-                                            )))
-                               (SETQ LET-BODY :ABORT)))
-                         (T
-
-                          (IL:* IL:|;;| "We have something of the form #'(LAMBDA (finisharg) ...), possibly with some LET bindings around it.  LET-BODY = ((finisharg) ...). ")
-
-                          (SETQ LET-BODY (CDR LET-BODY))
-                          (SETQ GEN-ARGS (POP LET-BODY))
-                          (WHEN LET-BINDINGS
-
-                              (IL:* IL:|;;| "The first transformation we want to perform is \"LET-eversion\": turn (let* ((generator (let (..bindings..) #'(lambda ...)))) ..body..) into (let* (..bindings.. (generator #'(lambda ...))) ..body..).  This transformation is valid if nothing in body refers to any of the bindings, something we can assure by alpha-converting the inner let (substituting new names for each var).  Of course, none of those vars can be special, but we already checked for that above. ")
-
-                              (MULTIPLE-VALUE-SETQ (LET-BINDINGS RENAMED-VARS)
-                                     (RENAME-LET-BINDINGS LET-BINDINGS BINDING-TYPE ITERATE-ENV 
-                                            LEFTOVER-BODY #'GET-ITERATE-TEMP))
-                              (SETQ LEFTOVER-BODY NIL)       (IL:* IL:\; 
-                                     "If there was any leftover from previous, it is now consumed ")
-                              )
-
-                          (IL:* IL:|;;| "The second transformation is substituting the body of the generator (LAMBDA (finish-arg) . gen-body) for its appearance in the update form (funcall generator #'(lambda () finish-form)), then simplifying that form.  The requirement for this part is that the generator body not refer to any variables that are bound between the generator binding and the appearance in the loop body.  The only variables bound in that interval are generator temporaries, which have unique names so are no problem, and the iteration variables remaining for subsequent clauses.  We'll discover the story as we walk the body. ")
-
-                          (MULTIPLE-VALUE-BIND (FINISHDECL OTHER REST)
-                              (PARSE-DECLARATIONS LET-BODY GEN-ARGS)
-                            (DECLARE (IGNORE FINISHDECL))(IL:* IL:\; "Pull out declares, if any, separating out the one(s) referring to the finish arg, which we will throw away ")
-                            (WHEN OTHER                      (IL:* IL:\; 
-                               "Combine remaining decls with decls extracted from the LET, if any ")
-                                (SETQ OTHERDECLS (NCONC OTHERDECLS OTHER)))
-                            (SETQ LET-BODY (COND
-                                              (OTHERDECLS    (IL:* IL:\; 
-                                 "There are interesting declarations, so have to keep it wrapped. ")
-                                                     `(LET NIL (DECLARE ,@OTHERDECLS)
-                                                           ,@REST))
-                                              ((NULL (CDR REST))
-                                                             (IL:* IL:\; "Only one form left")
-                                               (FIRST REST))
-                                              (T `(PROGN ,@REST)))))
-                          (UNLESS (EQ (SETQ LET-BODY (ITERATE-TRANSFORM-BODY LET-BODY ITERATE-ENV
-                                                            RENAMED-VARS (FIRST GEN-ARGS)
-                                                            FINISH-FORM BOUND-VARS CLAUSE))
-                                      :ABORT)
-
-                              (IL:* IL:|;;| "Skip the rest if transformation failed.  Warning has already been issued. Note possible further optimization: if LET-BODY expanded into (prog1 oldvalue prepare-for-next-iteration), as so many do, then we could in most cases split the PROG1 into two pieces: do the (setq var oldvalue) here, and do the prepare-for-next-iteration at the bottom of the loop. This does a slight optimization of the PROG1 and also rearranges the code in a way that a reasonably clever compiler might detect how to get rid of redundant variables altogether (such as happens with INTERVAL and LIST-TAILS); that would make the whole thing closer to what you might have coded by hand.  However, to do this optimization, we need to assure that (a) the prepare-for-next-iteration refers freely to no vars other than the internal vars we have extracted from the LET, and (b) that the code has no side effects.  These are both true for all the iterators defined by this module, but how shall we represent side-effect info and/or tap into the compiler's knowledge of same? ")
-
-                              (WHEN LOCALDECLS               (IL:* IL:\; "There were declarations for the generator locals--have to keep them for later, and rename the vars mentioned ")
-                                  (SETQ
-                                   GENERATOR-DECLS
-                                   (NCONC
-                                    GENERATOR-DECLS
-                                    (MAPCAR
-                                     #'(LAMBDA (DECL)
-                                              (LET ((HEAD (CAR DECL)))
-                                                   (CONS HEAD (IF (EQ HEAD 'TYPE)
-                                                                  (CONS (SECOND DECL)
-                                                                        (SUBLIS RENAMED-VARS
-                                                                               (CDDR DECL)))
-                                                                  (SUBLIS RENAMED-VARS (CDR DECL)))))
-                                              )
-                                     LOCALDECLS)))))))
-
-                (IL:* IL:|;;| "Finished analyzing clause now.  LET-BODY is the form which, when evaluated, returns updated values for the iteration variable(s) VARS. ")
-
-                      (WHEN (EQ LET-BODY :ABORT)
-
-                          (IL:* IL:|;;| "Some punt case: go with the formal semantics: bind a var to the generator, then call it in the update section ")
-
-                          (LET ((GVAR (GET-ITERATE-TEMP))
-                                (GENERATOR (SECOND CLAUSE)))
-                               (SETQ LET-BINDINGS
-                                     (LIST (LIST GVAR
-                                                 (COND
-                                                    (LEFTOVER-BODY
-                                                             (IL:* IL:\; "Have to use this up")
-                                                     `(PROGN ,@(PROG1 LEFTOVER-BODY (SETQ 
-                                                                                        LEFTOVER-BODY
-                                                                                          NIL))
-                                                             GENERATOR))
-                                                    (T GENERATOR)))))
-                               (SETQ LET-BODY `(FUNCALL ,GVAR #'(LAMBDA NIL ,FINISH-FORM)))))
-                      (PUSH (MV-SETQ (COPY-LIST VARS)
-                                   LET-BODY)
-                            UPDATE-FORMS)
-                      (DOLIST (V VARS)
-                          (DECLARE (IGNORE V))           (IL:* IL:\; "Pop off the vars we have now bound from the list of vars to watch out for--we'll bind them right now ")
-                          (POP BOUND-VARS))
-                      (SETQ BINDINGS (NCONC BINDINGS LET-BINDINGS
-                                            (COND
-                                               (EXTRA-BODY   (IL:* IL:\; 
-                          "There was some computation to do after the bindings--here's our chance ")
-                                                      (CONS (LIST (FIRST VARS)
-                                                                  `(PROGN ,@EXTRA-BODY NIL))
-                                                            (REST VARS)))
-                                               (T VARS))))))))))
-    (DO ((TAIL BODY (CDR TAIL)))
-        ((NOT (AND (CONSP TAIL)
-                   (CONSP (CAR TAIL))
-                   (EQ (CAAR TAIL)
-                       'DECLARE)))
-
-         (IL:* IL:|;;| "TAIL now points at first non-declaration.  If there were declarations, pop them off so they appear in the right place ")
-
-         (UNLESS (EQ TAIL BODY)
-             (SETQ ITERATE-DECLS (LDIFF BODY TAIL))
-             (SETQ BODY TAIL))))
-    `(BLOCK ,BLOCK-NAME
-         (LET* ,BINDINGS ,@(AND GENERATOR-DECLS `((DECLARE ,@GENERATOR-DECLS)))
-               ,@ITERATE-DECLS
-               ,@LEFTOVER-BODY
-               (LOOP ,@(NREVERSE UPDATE-FORMS)
-                     ,@BODY)))))
-
-(DEFUN EXPAND-INTO-LET (CLAUSE PARENT-NAME ENV)
-
-   (IL:* IL:|;;| "Return values: Body, LET[*], bindings, localdecls, otherdecls, extra body, where BODY is a single form.  If multiple forms in a LET, the preceding forms are returned as extra body.  Returns :ABORT if it issued a punt warning. ")
-
-   (PROG ((EXPANSION CLAUSE)
-          EXPANDEDP BINDING-TYPE LET-BINDINGS LET-BODY)
-     EXPAND
-         (MULTIPLE-VALUE-SETQ (EXPANSION EXPANDEDP)
-                (MACROEXPAND-1 EXPANSION ENV))
-         (COND
-            ((NOT (CONSP EXPANSION))                         (IL:* IL:\; "Shouldn't happen")
-             )
-            ((SYMBOLP (SETQ BINDING-TYPE (FIRST EXPANSION)))
-             (CASE BINDING-TYPE
-                 ((LET LET*) 
-                    (SETQ LET-BINDINGS (SECOND EXPANSION))   (IL:* IL:\; 
-                                                           "List of variable bindings")
-                    (SETQ LET-BODY (CDDR EXPANSION))
-                    (GO HANDLE-LET))))
-            ((AND (CONSP BINDING-TYPE)
-                  (EQ (CAR BINDING-TYPE)
-                      'LAMBDA)
-                  (NOT (FIND-IF #'(LAMBDA (X)
-                                         (MEMBER X LAMBDA-LIST-KEYWORDS))
-                              (SETQ LET-BINDINGS (SECOND BINDING-TYPE))))
-                  (EQL (LENGTH (SECOND EXPANSION))
-                       (LENGTH LET-BINDINGS))
-                  (NULL (CDDR EXPANSION)))                   (IL:* IL:\; 
-                                                      "A simple LAMBDA form can be treated as LET ")
-             (SETQ LET-BODY (CDDR BINDING-TYPE))
-             (SETQ LET-BINDINGS (MAPCAR #'LIST LET-BINDINGS (SECOND EXPANSION)))
-             (SETQ BINDING-TYPE 'LET)
-             (GO HANDLE-LET)))
-
-    (IL:* IL:|;;| "Fall thru if not a LET")
-
-         (COND
-            (EXPANDEDP                                       (IL:* IL:\; "try expanding again")
-                   (GO EXPAND))
-            (T                                               (IL:* IL:\; 
-                                                           "Boring--return form as the body ")
-               (RETURN EXPANSION)))
-     HANDLE-LET
-         (RETURN (LET ((LOCALS (VARIABLES-FROM-LET LET-BINDINGS))
-                       EXTRA-BODY SPECIALS)
-                      (MULTIPLE-VALUE-BIND (LOCALDECLS OTHERDECLS LET-BODY)
-                          (PARSE-DECLARATIONS LET-BODY LOCALS)
-                        (COND
-                           ((SETQ SPECIALS (EXTRACT-SPECIAL-BINDINGS LOCALS LOCALDECLS))
-                            (MAYBE-WARN (COND
-                                               ((FIND-IF #'VARIABLE-GLOBALLY-SPECIAL-P SPECIALS)
-                                                             (IL:* IL:\; 
-                                                  "This could be the fault of a user proclamation ")
-                                                :USER)
-                                               (T :DEFINITION))
-                                   
-                                "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)"
-                                   PARENT-NAME CLAUSE SPECIALS)
-                            :ABORT)
-                           (T (VALUES (COND
-                                         ((NOT (CONSP LET-BODY))
-                                                             (IL:* IL:\; 
-                              "Null body of LET?  unlikely, but someone else will likely complain ")
-                                          NIL)
-                                         ((NULL (CDR LET-BODY))
-                                                             (IL:* IL:\; 
-                                    "A single expression, which we hope is (function (lambda...)) ")
-                                          (FIRST LET-BODY))
-                                         (T 
-
-                                 (IL:* IL:|;;| "More than one expression.  These are forms to evaluate after the bindings but before the generator form is returned.  Save them to evaluate in the next convenient place.  Note that this is ok, as there is no construct that can cause a LET to return prematurely (without returning also from some surrounding construct). ")
-
-                                            (SETQ EXTRA-BODY (BUTLAST LET-BODY))
-                                            (CAR (LAST LET-BODY))))
-                                     BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS EXTRA-BODY))))))
-    ))
-
-(DEFUN VARIABLES-FROM-LET (BINDINGS)
-
-   (IL:* IL:|;;| "Return a list of the variables bound in the first argument to LET[*].")
-
-   (MAPCAR #'(LAMBDA (BINDING)
-                    (IF (CONSP BINDING)
-                        (FIRST BINDING)
-                        BINDING))
-          BINDINGS))
-
-(DEFUN ITERATE-TRANSFORM-BODY (LET-BODY ITERATE-ENV RENAMED-VARS FINISH-ARG FINISH-FORM 
-                                         BOUND-VARS CLAUSE)
-
-(IL:* IL:|;;;| "This is the second major transformation for a single iterate clause. LET-BODY is the body of the iterator after we have extracted its local variables and declarations.  We have two main tasks: (1) Substitute internal temporaries for occurrences of the LET variables; the alist RENAMED-VARS specifies this transformation.  (2) Substitute evaluation of FINISH-FORM for any occurrence of (funcall FINISH-ARG).  Along the way, we check for forms that would invalidate these transformations: occurrence of FINISH-ARG outside of a funcall, and free reference to any element of BOUND-VARS.  CLAUSE & TYPE are the original ITERATE clause and its type (ITERATE or ITERATE*), for purpose of error messages.  On success, we return the transformed body; on failure, :ABORT. ")
-
-   (WALK-FORM LET-BODY ITERATE-ENV #'(LAMBDA (FORM CONTEXT ENV)
-                                            (DECLARE (IGNORE CONTEXT))
-
-                                            (IL:* IL:|;;| 
-      "Need to substitute RENAMED-VARS, as well as turn (FUNCALL finish-arg) into the finish form ")
-
-                                            (COND
-                                               ((SYMBOLP FORM)
-                                                (LET (RENAMING)
-                                                     (COND
-                                                        ((AND (EQ FORM FINISH-ARG)
-                                                              (VARIABLE-SAME-P FORM ENV 
-                                                                     ITERATE-ENV))
-                                                             (IL:* IL:\; 
-                 "An occurrence of the finish arg outside of FUNCALL context--I can't handle this ")
-                                                         (MAYBE-WARN :DEFINITION "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it."
-                                                                (SECOND CLAUSE))
-                                                         (RETURN-FROM ITERATE-TRANSFORM-BODY :ABORT))
-                                                        ((AND (SETQ RENAMING (ASSOC FORM RENAMED-VARS
-                                                                                    ))
-                                                              (VARIABLE-SAME-P FORM ENV 
-                                                                     ITERATE-ENV))
-                                                             (IL:* IL:\; 
-                                                     "Reference to one of the vars we're renaming ")
-                                                         (CDR RENAMING))
-                                                        ((AND (MEMBER FORM BOUND-VARS)
-                                                              (VARIABLE-SAME-P FORM ENV 
-                                                                     ITERATE-ENV))
-                                                             (IL:* IL:\; "FORM is a var that is bound in this same ITERATE, or bound later in this ITERATE*. This is a conflict. ")
-                                                         (MAYBE-WARN :USER "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable."
-                                                                (SECOND CLAUSE)
-                                                                FORM)
-                                                         (RETURN-FROM ITERATE-TRANSFORM-BODY :ABORT))
-                                                        (T FORM))))
-                                               ((AND (CONSP FORM)
-                                                     (EQ (FIRST FORM)
-                                                         'FUNCALL)
-                                                     (EQ (SECOND FORM)
-                                                         FINISH-ARG)
-                                                     (VARIABLE-SAME-P (SECOND FORM)
-                                                            ENV ITERATE-ENV))
-                                                             (IL:* IL:\; 
-                                                           "(FUNCALL finish-arg) => finish-form ")
-                                                (UNLESS (NULL (CDDR FORM))
-                                                    (MAYBE-WARN :DEFINITION 
-                              "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored."
-                                                           (SECOND CLAUSE)
-                                                           (CDDR FORM)))
-                                                FINISH-FORM)
-                                               (T FORM)))))
-
-(DEFUN PARSE-DECLARATIONS (TAIL LOCALS)
-
-   (IL:* IL:|;;| "Extract the declarations from the head of TAIL and divide them into 2 classes: declares about variables in the list LOCALS, and all other declarations.  Returns 3 values: those 2 lists plus the remainder of TAIL. ")
-
-   (LET
-    (LOCALDECLS OTHERDECLS FORM)
-    (LOOP
-     (UNLESS (AND TAIL (CONSP (SETQ FORM (CAR TAIL)))
-                  (EQ (CAR FORM)
-                      'DECLARE))
-         (RETURN (VALUES LOCALDECLS OTHERDECLS TAIL)))
-     (MAPC
-      #'(LAMBDA (DECL)
-               (CASE (FIRST DECL)
-                   ((INLINE NOTINLINE OPTIMIZE)              (IL:* IL:\; 
-                                                           "These don't talk about vars")
-                      (PUSH DECL OTHERDECLS))
-                   (T                                        (IL:* IL:\; 
-                                                           "Assume all other kinds are for vars ")
-                      (LET* ((VARS (IF (EQ (FIRST DECL)
-                                           'TYPE)
-                                       (CDDR DECL)
-                                       (CDR DECL)))
-                             (L (INTERSECTION LOCALS VARS))
-                             OTHER)
-                            (COND
-                               ((NULL L)                     (IL:* IL:\; "None talk about LOCALS")
-                                (PUSH DECL OTHERDECLS))
-                               ((NULL (SETQ OTHER (SET-DIFFERENCE VARS L)))
-                                                             (IL:* IL:\; "All talk about LOCALS")
-                                (PUSH DECL LOCALDECLS))
-                               (T                            (IL:* IL:\; "Some of each")
-                                  (LET ((HEAD (CONS 'TYPE (AND (EQ (FIRST DECL)
-                                                                   'TYPE)
-                                                               (LIST (SECOND DECL))))))
-                                       (PUSH (APPEND HEAD OTHER)
-                                             OTHERDECLS)
-                                       (PUSH (APPEND HEAD L)
-                                             LOCALDECLS))))))))
-      (CDR FORM))
-     (POP TAIL))))
-
-(DEFUN EXTRACT-SPECIAL-BINDINGS (VARS DECLS)
-
-   (IL:* IL:|;;| 
-"Return the subset of VARS that are special, either globally or because of a declaration in DECLS ")
-
-   (LET ((SPECIALS (REMOVE-IF-NOT #'VARIABLE-GLOBALLY-SPECIAL-P VARS)))
-        (DOLIST (D DECLS)
-            (WHEN (EQ (CAR D)
-                      'SPECIAL)
-                (SETQ SPECIALS (UNION SPECIALS (INTERSECTION VARS (CDR D))))))
-        SPECIALS))
-
-(DEFUN FUNCTION-LAMBDA-P (FORM &OPTIONAL NARGS)
-
-   (IL:* IL:|;;| "If FORM is #'(LAMBDA bindings . body) and bindings is of length NARGS, return the lambda expression ")
-
-   (LET (ARGS BODY)
-        (AND (CONSP FORM)
-             (EQ (CAR FORM)
-                 'FUNCTION)
-             (CONSP (SETQ FORM (CDR FORM)))
-             (NULL (CDR FORM))
-             (CONSP (SETQ FORM (CAR FORM)))
-             (EQ (CAR FORM)
-                 'LAMBDA)
-             (CONSP (SETQ BODY (CDR FORM)))
-             (LISTP (SETQ ARGS (CAR BODY)))
-             (OR (NULL NARGS)
-                 (EQL (LENGTH ARGS)
-                      NARGS))
-             FORM)))
-
-(DEFUN RENAME-LET-BINDINGS (LET-BINDINGS BINDING-TYPE ENV LEFTOVER-BODY &OPTIONAL TEMPVARFN)
-
-   (IL:* IL:|;;| "Perform the alpha conversion required for \"LET eversion\" of (LET[*] LET-BINDINGS . body)--rename each of the variables to an internal name. Returns 2 values: a new set of LET bindings and the alist of old var names to new (so caller can walk the body doing the rest of the renaming). BINDING-TYPE is one of LET or LET*.  LEFTOVER-BODY is optional list of forms that must be eval'ed before the first binding happens.  ENV is the macro expansion environment, in case we have to walk a LET*.  TEMPVARFN is a function of no args to return a temporary var; if omitted, we use GENSYM. ")
-
-   (LET (RENAMED-VARS)
-        (VALUES (MAPCAR #'(LAMBDA (BINDING)
-                                 (LET ((VALUEFORM (COND
-                                                     ((NOT (CONSP BINDING))
-                                                             (IL:* IL:\; "No initial value")
-                                                      NIL)
-                                                     ((OR (EQ BINDING-TYPE 'LET)
-                                                          (NULL RENAMED-VARS))
-                                                             (IL:* IL:\; 
-                                       "All bindings are in parallel, so none can refer to others ")
-                                                      (SECOND BINDING))
-                                                     (T      (IL:* IL:\; 
-               "In a LET*, have to substitute vars in the 2nd and subsequent initialization forms ")
-                                                        (RENAME-VARIABLES (SECOND BINDING)
-                                                               RENAMED-VARS ENV))))
-                                       (NEWVAR (IF TEMPVARFN
-                                                   (FUNCALL TEMPVARFN)
-                                                   (GENSYM))))
-                                      (PUSH (CONS (IF (CONSP BINDING)
-                                                      (FIRST BINDING)
-                                                      BINDING)
-                                                  NEWVAR)
-                                            RENAMED-VARS)    (IL:* IL:\; 
-                        "Add new variable to the list AFTER we have walked the initial value form ")
-                                      (WHEN LEFTOVER-BODY
-
-                                          (IL:* IL:|;;| "Previous clause had some computation to do after its bindings.  Here is the first opportunity to do it ")
-
-                                          (SETQ VALUEFORM `(PROGN ,@LEFTOVER-BODY ,VALUEFORM))
-                                          (SETQ LEFTOVER-BODY NIL))
-                                      (LIST NEWVAR VALUEFORM)))
-                       LET-BINDINGS)
-               RENAMED-VARS)))
-
-(DEFUN RENAME-VARIABLES (FORM ALIST ENV)
-
-   (IL:* IL:|;;| "Walks FORM, renaming occurrences of the key variables in ALIST with their corresponding values.  ENV is FORM's environment, so we can make sure we are talking about the same variables. ")
-
-   (WALK-FORM FORM ENV #'(LAMBDA (FORM CONTEXT SUBENV)
-                                (DECLARE (IGNORE CONTEXT))
-                                (LET (PAIR)
-                                     (COND
-                                        ((AND (SYMBOLP FORM)
-                                              (SETQ PAIR (ASSOC FORM ALIST))
-                                              (VARIABLE-SAME-P FORM SUBENV ENV))
-                                         (CDR PAIR))
-                                        (T FORM))))))
-
-(DEFUN MV-SETQ (VARS EXPR)
-
-   (IL:* IL:|;;| "Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some of the simple cases for benefit of compilers that don't, and I don't care what the value is, and I know that the variables need not be set in parallel, since they can't be used free in EXPR ")
-
-   (COND
-      ((NULL VARS)                                           (IL:* IL:\; "EXPR is a side-effect")
-       EXPR)
-      ((NOT (CONSP VARS))                                    (IL:* IL:\; 
-                                    "This is an error, but I'll let MULTIPLE-VALUE-SETQ report it ")
-       `(MULTIPLE-VALUE-SETQ ,VARS ,EXPR))
-      ((AND (LISTP EXPR)
-            (EQ (CAR EXPR)
-                'VALUES))
-
-       (IL:* IL:|;;| "(mv-setq (a b c) (values x y z)) can be reduced to a parallel setq (psetq returns nil, but I don't care about returned value).  Do this even for the single variable case so that we catch (mv-setq (a) (values x y)) ")
-
-       (POP EXPR)                                            (IL:* IL:\; "VALUES")
-       `(SETQ ,@(MAPCON #'(LAMBDA (TAIL)
-                                 (LIST (CAR TAIL)
-                                       (COND
-                                          ((OR (CDR TAIL)
-                                               (NULL (CDR EXPR)))
-                                                             (IL:* IL:\; 
-                                                           "One result expression for this var ")
-                                           (POP EXPR))
-                                          (T                 (IL:* IL:\; 
-                            "More expressions than vars, so arrange to evaluate all the rest now. ")
-                                             (CONS 'PROG1 EXPR)))))
-                       VARS)))
-      ((NULL (CDR VARS))                                     (IL:* IL:\; "Simple one variable case")
-       `(SETQ ,(CAR VARS)
-              ,EXPR))
-      (T                                                     (IL:* IL:\; 
-                                                           "General case--I know nothing")
-         `(MULTIPLE-VALUE-SETQ ,VARS ,EXPR))))
-
-(DEFUN VARIABLE-SAME-P (VAR ENV1 ENV2)
-   (EQ (VARIABLE-LEXICAL-P VAR ENV1)
-       (VARIABLE-LEXICAL-P VAR ENV2)))
-
-(DEFUN MAYBE-WARN (TYPE &REST WARN-ARGS)
-
-   (IL:* IL:|;;| "Issue a warning about not being able to optimize this thing.  TYPE is one of :DEFINITION, meaning the definition is at fault, and :USER, meaning the user's code is at fault. ")
-
-   (WHEN (CASE *ITERATE-WARNINGS*
-             ((NIL) NIL)
-             ((:USER) (EQ TYPE :USER))
-             (T T))
-       (APPLY #'WARN WARN-ARGS)))
-
-
-
-(IL:* IL:|;;| "Sample iterators")
-
-
-(DEFMACRO INTERVAL (&WHOLE WHOLE &KEY FROM DOWNFROM TO DOWNTO ABOVE BELOW BY TYPE)
-   (COND
-      ((AND FROM DOWNFROM)
-       (ERROR "Can't use both FROM and DOWNFROM in ~S" WHOLE))
-      ((CDR (REMOVE NIL (LIST TO DOWNTO ABOVE BELOW)))
-       (ERROR "Can't use more than one limit keyword in ~S" WHOLE))
-      (T
-       (LET*
-        ((DOWN (OR DOWNFROM DOWNTO ABOVE))
-         (LIMIT (OR TO DOWNTO ABOVE BELOW))
-         (INC (COND
-                 ((NULL BY)
-                  1)
-                 ((CONSTANTP BY)                             (IL:* IL:\; 
-                                                           "Can inline this increment")
-                  BY))))
-        `(LET ((FROM ,(OR FROM DOWNFROM 0))
-               ,@(AND LIMIT `((TO ,LIMIT)))
-               ,@(AND (NULL INC)
-                      `((BY ,BY))))
-              ,@(AND TYPE `((DECLARE (TYPE ,TYPE FROM ,@(AND LIMIT '(TO))
-                                               ,@(AND (NULL INC)
-                                                      `(BY))))))
-              #'(LAMBDA (FINISH)
-                       ,@(COND
-                            ((NULL LIMIT)                    (IL:* IL:\; 
-                                                           "We won't use the FINISH arg")
-                             '((DECLARE (IGNORE FINISH)))))
-                       (PROG1 ,(COND
-                                  (LIMIT                     (IL:* IL:\; 
-                           "Test the limit.  If ok, return current value and increment, else quit ")
-                                         `(IF (,(COND
-                                                   (ABOVE '>)
-                                                   (BELOW '<)
-                                                   (DOWN '>=)
-                                                   (T '<=))
-                                               FROM TO)
-                                              FROM
-                                              (FUNCALL FINISH)))
-                                  (T                         (IL:* IL:\; "No test")
-                                     'FROM))
-                           (SETQ FROM (,(IF DOWN
-                                            '-
-                                            '+)
-                                       FROM
-                                       ,(OR INC 'BY))))))))))
-
-(DEFMACRO LIST-ELEMENTS (LIST &KEY (BY '#'CDR))
-   `(LET ((TAIL ,LIST))
-         #'(LAMBDA (FINISH)
-                  (PROG1 (IF (ENDP TAIL)
-                             (FUNCALL FINISH)
-                             (FIRST TAIL))
-                      (SETQ TAIL (FUNCALL ,BY TAIL))))))
-
-(DEFMACRO LIST-TAILS (LIST &KEY (BY '#'CDR))
-   `(LET ((TAIL ,LIST))
-         #'(LAMBDA (FINISH)
-                  (PROG1 (IF (ENDP TAIL)
-                             (FUNCALL FINISH)
-                             TAIL)
-                      (SETQ TAIL (FUNCALL ,BY TAIL))))))
-
-(DEFMACRO ELEMENTS (SEQUENCE)
-   "Generates successive elements of SEQUENCE, with second value being the index.  Use (ELEMENTS (THE type arg)) if you care about the type."
-   (LET* ((TYPE (AND (CONSP SEQUENCE)
-                     (EQ (FIRST SEQUENCE)
-                         'THE)
-                     (SECOND SEQUENCE)))
-          (ACCESSOR (IF TYPE
-                        (SEQUENCE-ACCESSOR TYPE)
-                        'ELT))
-          (LISTP (EQ TYPE 'LIST)))
-
-         (IL:* IL:|;;| "If type is given via THE, we may be able to generate a good accessor here for the benefit of implementations that aren't smart about (ELT (THE STRING FOO)).  I'm not bothering to keep the THE inside the body, however, since I assume any compiler that would understand (AREF (THE SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I bound S to (THE SIMPLE-ARRAY foo) and never modified it. If sequence is declared to be a list, it's better to cdr down it, so we have some extra cases here.  Normally folks would write LIST-ELEMENTS, but maybe they wanted to get the index for free... ")
-
-         `(LET* ((INDEX 0)
-                 (S ,SEQUENCE)
-                 ,@(AND (NOT LISTP)
-                        '((SIZE (LENGTH S)))))
-                #'(LAMBDA (FINISH)
-                         (VALUES (COND
-                                    ,(IF LISTP
-                                         '((NOT (ENDP S))
-                                           (POP S))
-                                         `((< INDEX SIZE)
-                                           (,ACCESSOR S INDEX)))
-                                    (T (FUNCALL FINISH)))
-                                (PROG1 INDEX
-                                    (SETQ INDEX (1+ INDEX))))))))
-
-(DEFMACRO PLIST-ELEMENTS (PLIST)
-   "Generates each time 2 items, the indicator and the value."
-   `(LET ((TAIL ,PLIST))
-         #'(LAMBDA (FINISH)
-                  (VALUES (IF (ENDP TAIL)
-                              (FUNCALL FINISH)
-                              (FIRST TAIL))
-                         (PROG1 (IF (ENDP (SETQ TAIL (CDR TAIL)))
-                                    (FUNCALL FINISH)
-                                    (FIRST TAIL))
-                             (SETQ TAIL (CDR TAIL)))))))
-
-(DEFUN SEQUENCE-ACCESSOR (TYPE)
-
-   (IL:* IL:|;;| 
- "returns the function with which most efficiently to make accesses to a sequence of type TYPE. ")
-
-   (CASE (IF (CONSP TYPE)                                    (IL:* IL:\; "e.g., (VECTOR FLOAT *)")
-             (CAR TYPE)
-             TYPE)
-       ((ARRAY SIMPLE-ARRAY VECTOR) 'AREF)
-       (SIMPLE-VECTOR 'SVREF)
-       (STRING 'CHAR)
-       (SIMPLE-STRING 'SCHAR)
-       (BIT-VECTOR 'BIT)
-       (SIMPLE-BIT-VECTOR 'SBIT)
-       (T 'ELT)))
-
-
-
-(IL:* IL:|;;| "These \"iterators\" may be withdrawn")
-
-
-(DEFMACRO EACHTIME (EXPR)
-   `#'(LAMBDA (FINISH)
-             (DECLARE (IGNORE FINISH))
-             ,EXPR))
-
-(DEFMACRO WHILE (EXPR)
-   `#'(LAMBDA (FINISH)
-             (UNLESS ,EXPR (FUNCALL FINISH))))
-
-(DEFMACRO UNTIL (EXPR)
-   `#'(LAMBDA (FINISH)
-             (WHEN ,EXPR (FUNCALL FINISH))))
-
-
-
-(IL:* IL:\; "GATHERING macro")
-
-
-(DEFMACRO GATHERING (CLAUSES &BODY BODY &ENVIRONMENT ENV)
-   (OR (OPTIMIZE-GATHERING-FORM CLAUSES BODY ENV)
-       (SIMPLE-EXPAND-GATHERING-FORM CLAUSES BODY ENV)))
-
-(DEFMACRO WITH-GATHERING (CLAUSES GATHER-BODY &BODY USE-BODY)
-   "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour."
-
-   (IL:* IL:|;;| "We may optimize this a little better later for those compilers that don't do a good job on (m-v-bind vars (... (values ...)) ...). ")
-
-   `(MULTIPLE-VALUE-BIND ,(MAPCAR #'CAR CLAUSES)
-        (GATHERING ,CLAUSES ,GATHER-BODY)
-      ,@USE-BODY))
-
-(DEFUN SIMPLE-EXPAND-GATHERING-FORM (CLAUSES BODY ENV)
-   (DECLARE (IGNORE ENV))
-
-   (IL:* IL:|;;| 
- "The \"formal semantics\" of GATHERING.  We use this only in cases that can't be optimized. ")
-
-   (LET
-    ((ACC-NAMES (MAPCAR #'FIRST (IF (SYMBOLP CLAUSES)        (IL:* IL:\; 
-                                                        "Shorthand using anonymous gathering site ")
-                                    (SETQ CLAUSES `((*ANONYMOUS-GATHERING-SITE* (,CLAUSES))))
-                                    CLAUSES)))
-     (REALIZER-NAMES (MAPCAR #'(LAMBDA (BINDING)
-                                      (DECLARE (IGNORE BINDING))
-                                      (GENSYM))
-                            CLAUSES)))
-    `(MULTIPLE-VALUE-CALL
-      #'(LAMBDA ,(MAPCAN #'LIST ACC-NAMES REALIZER-NAMES)
-               (FLET ((GATHER (VALUE &OPTIONAL (ACCUMULATOR *ANONYMOUS-GATHERING-SITE*))
-                             (FUNCALL ACCUMULATOR VALUE)))
-                     ,@BODY
-                     (VALUES ,@(MAPCAR #'(LAMBDA (RNAME)
-                                                `(FUNCALL ,RNAME))
-                                      REALIZER-NAMES))))
-      ,@(MAPCAR #'SECOND CLAUSES))))
-
-(DEFVAR *ACTIVE-GATHERERS* NIL
-   "List of GATHERING bindings currently active during macro expansion)")
-
-(DEFVAR *ANONYMOUS-GATHERING-SITE* NIL
-   "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)."
-)
-
-(DEFUN OPTIMIZE-GATHERING-FORM (CLAUSES BODY GATHERING-ENV)
-   (LET*
-    (ACC-INFO LEFTOVER-BODY TOP-BINDINGS FINISH-FORMS TOP-DECLS)
-    (DOLIST (CLAUSE (IF (SYMBOLP CLAUSES)                    (IL:* IL:\; "A shorthand")
-                        `((*ANONYMOUS-GATHERING-SITE* (,CLAUSES)))
-                        CLAUSES))
-        (MULTIPLE-VALUE-BIND (LET-BODY BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS EXTRA-BODY)
-            (EXPAND-INTO-LET (SECOND CLAUSE)
-                   'GATHERING GATHERING-ENV)
-          (PROG* ((ACC-VAR (FIRST CLAUSE))
-                  RENAMED-VARS ACCUMULATOR REALIZER)
-                 (WHEN (AND (CONSP LET-BODY)
-                            (EQ (CAR LET-BODY)
-                                'VALUES)
-                            (CONSP (SETQ LET-BODY (CDR LET-BODY)))
-                            (SETQ ACCUMULATOR (FUNCTION-LAMBDA-P (CAR LET-BODY)))
-                            (CONSP (SETQ LET-BODY (CDR LET-BODY)))
-                            (SETQ REALIZER (FUNCTION-LAMBDA-P (CAR LET-BODY)
-                                                  0))
-                            (NULL (CDR LET-BODY)))
-
-                     (IL:* IL:|;;| "Macro returned something of the form (VALUES #'(lambda (value)")
-
-                     (IL:* IL:|;;| 
-   "..) #'(lambda () ...)), a function to accumulate values and a function to realize the result. ")
-
-                     (WHEN BINDING-TYPE
-
-                         (IL:* IL:|;;| "Gatherer expanded into a LET")
-
-                         (COND
-                            (OTHERDECLS (MAYBE-WARN :DEFINITION "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S"
-                                               (SECOND CLAUSE)
-                                               `(DECLARE ,@OTHERDECLS))
-                                   (GO PUNT)))
-                         (WHEN LET-BINDINGS
-
-                             (IL:* IL:|;;| "The first transformation we want to perform is a variant of \"LET-eversion\": turn (mv-bind (acc real) (let (..bindings..) (values #'(lambda ...) #'(lambda ")
-
-                             (IL:* IL:|;;| "..))) ..body..) into (let* (..bindings.. (acc #'(lambda ...)) (real #'(lambda ...))) ..body..).  This transformation is valid if nothing in body refers to any of the bindings, something we can assure by alpha-converting the inner let (substituting new names for each var).  Of course, none of those vars can be special, but we already checked for that above. ")
-
-                             (MULTIPLE-VALUE-SETQ (LET-BINDINGS RENAMED-VARS)
-                                    (RENAME-LET-BINDINGS LET-BINDINGS BINDING-TYPE GATHERING-ENV
-                                           LEFTOVER-BODY))
-                             (SETQ TOP-BINDINGS (NCONC TOP-BINDINGS LET-BINDINGS))
-                             (SETQ LEFTOVER-BODY NIL)        (IL:* IL:\; 
-                                     "If there was any leftover from previous, it is now consumed ")
-                             ))
-                     (SETQ LEFTOVER-BODY (NCONC LEFTOVER-BODY EXTRA-BODY))
-                                                             (IL:* IL:\; 
-                                                          "Computation to do after these bindings ")
-                     (PUSH (CONS ACC-VAR (RENAME-AND-CAPTURE-VARIABLES ACCUMULATOR RENAMED-VARS 
-                                                GATHERING-ENV))
-                           ACC-INFO)
-                     (SETQ REALIZER (RENAME-VARIABLES REALIZER RENAMED-VARS GATHERING-ENV))
-                     (PUSH (COND
-                              ((NULL (CDDDR REALIZER))       (IL:* IL:\; 
-                                                           "Simple (LAMBDA () expr) => expr ")
-                               (THIRD REALIZER))
-                              (T                             (IL:* IL:\; 
-                                     "There could be declarations or something, so leave as a LET ")
-                                 (CONS 'LET (CDR REALIZER))))
-                           FINISH-FORMS)
-                     (UNLESS (NULL LOCALDECLS)               (IL:* IL:\; 
-                                   "Declarations about the LET variables also has to percolate up ")
-                         (SETQ TOP-DECLS (NCONC TOP-DECLS (SUBLIS RENAMED-VARS LOCALDECLS))))
-                     (RETURN))
-                 (MAYBE-WARN :DEFINITION "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))"
-                        (SECOND CLAUSE))
-             PUNT
-                 (LET ((GS (GENSYM))
-                       (EXPANSION `(MULTIPLE-VALUE-LIST ,(SECOND CLAUSE))))
-                                                             (IL:* IL:\; 
-                "Slow way--bind gensym to the macro expansion, and we will funcall it in the body ")
-                      (PUSH (LIST ACC-VAR GS)
-                            ACC-INFO)
-                      (PUSH `(FUNCALL (CADR ,GS))
-                            FINISH-FORMS)
-                      (SETQ TOP-BINDINGS
-                            (NCONC TOP-BINDINGS
-                                   (LIST (LIST GS
-                                               (COND
-                                                  (LEFTOVER-BODY
-                                                   `(PROGN ,@(PROG1 LEFTOVER-BODY (SETQ LEFTOVER-BODY
-                                                                                        NIL))
-                                                           ,EXPANSION))
-                                                  (T EXPANSION))))))))))
-    (SETQ BODY (WALK-GATHERING-BODY BODY GATHERING-ENV ACC-INFO))
-    (COND
-       ((EQ BODY :ABORT)                                     (IL:* IL:\; 
-                                                           "Couldn't finish expansion")
-        NIL)
-       (T `(LET* ,TOP-BINDINGS ,@(AND TOP-DECLS `((DECLARE ,@TOP-DECLS)))
-                 ,BODY
-                 ,(COND
-                     ((NULL (CDR FINISH-FORMS))              (IL:* IL:\; "just a single value")
-                      (CAR FINISH-FORMS))
-                     (T `(VALUES ,@(REVERSE FINISH-FORMS)))))))))
-
-(DEFUN RENAME-AND-CAPTURE-VARIABLES (FORM ALIST ENV)
-
-   (IL:* IL:|;;| "Walks FORM, renaming occurrences of the key variables in ALIST with their corresponding values, and capturing any other free variables. Returns a list of the new form and the list of other closed-over vars.  ENV is FORM's environment, so we can make sure we are talking about the same variables. ")
-
-   (LET (CLOSED)
-        (LIST (WALK-FORM FORM ENV #'(LAMBDA (FORM CONTEXT SUBENV)
-                                           (DECLARE (IGNORE CONTEXT))
-                                           (LET (PAIR)
-                                                (COND
-                                                   ((OR (NOT (SYMBOLP FORM))
-                                                        (NOT (VARIABLE-SAME-P FORM SUBENV ENV)))
-                                                             (IL:* IL:\; 
-                                                       "non-variable or one that has been rebound ")
-                                                    FORM)
-                                                   ((SETQ PAIR (ASSOC FORM ALIST))
-                                                             (IL:* IL:\; "One to rename")
-                                                    (CDR PAIR))
-                                                   (T        (IL:* IL:\; "var is free")
-                                                      (PUSHNEW FORM CLOSED)
-                                                      FORM)))))
-              CLOSED)))
-
-(DEFUN WALK-GATHERING-BODY (BODY GATHERING-ENV ACC-INFO)
-
-   (IL:* IL:|;;| "Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. ACC-INFO is a list of information about each of the gathering \"bindings\" in the form, in the form (var gatheringfn freevars env) ")
-
-   (LET ((*ACTIVE-GATHERERS* (NCONC (MAPCAR #'CAR ACC-INFO)
-                                    *ACTIVE-GATHERERS*)))
-
-        (IL:* IL:|;;| "*ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER targets.  This is so that when we encounter a GATHER not belonging to us we can know whether to warn about it. ")
-
-        (WALK-FORM
-         (CONS 'PROGN BODY)
-         GATHERING-ENV
-         #'(LAMBDA (FORM CONTEXT ENV)
-                  (DECLARE (IGNORE CONTEXT))
-                  (LET (INFO SITE)
-                       (COND
-                          ((CONSP FORM)
-                           (COND
-                              ((NOT (EQ (CAR FORM)
-                                        'GATHER))            (IL:* IL:\; 
-                                                           "We only care about GATHER")
-                               (WHEN (AND (EQ (CAR FORM)
-                                              'FUNCTION)
-                                          (EQ (CADR FORM)
-                                              'GATHER))      (IL:* IL:\; 
-                                                         "Passed as functional--can't macroexpand ")
-                                   (MAYBE-WARN :USER 
-                                         "Can't optimize GATHERING because of reference to #'GATHER."
-                                          )
-                                   (RETURN-FROM WALK-GATHERING-BODY :ABORT))
-                               FORM)
-                              ((SETQ INFO (ASSOC (SETQ SITE (IF (NULL (CDDR FORM))
-                                                                '*ANONYMOUS-GATHERING-SITE*
-                                                                (THIRD FORM)))
-                                                 ACC-INFO))  (IL:* IL:\; 
-                  "One of ours--expand (GATHER value var).  INFO = (var gatheringfn freevars env) ")
-                               (UNLESS (NULL (CDDDR FORM))
-                                      (WARN "Extra arguments (> 2) in ~S discarded." FORM))
-                               (LET ((FN (SECOND INFO)))
-                                    (COND
-                                       ((SYMBOLP FN)         (IL:* IL:\; "Unoptimized case--just call the gatherer.  FN is the gensym that we bound to the list of two values returned from the gatherer. ")
-                                        `(FUNCALL (CAR ,FN)
-                                                ,(SECOND FORM)))
-                                       (T                    (IL:* IL:\; 
-                                                           "FN = (lambda (value) ...)")
-                                          (DOLIST (S (THIRD INFO))
-                                              (UNLESS (OR (VARIABLE-SAME-P S ENV GATHERING-ENV)
-                                                          (AND (VARIABLE-SPECIAL-P S ENV)
-                                                               (VARIABLE-SPECIAL-P S GATHERING-ENV)))
-
-                                 (IL:* IL:|;;| "Some var used free in the LAMBDA form has been rebound between here and the parent GATHERING form, so can't substitute the lambda.  Ok if it's a special reference both here and in the LAMBDA, because then it's not closed over. ")
-
-                                                  (MAYBE-WARN :USER "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it."
-                                                         S)
-                                                  (RETURN-FROM WALK-GATHERING-BODY :ABORT)))
-
-                                 (IL:* IL:|;;| "Return ((lambda (value) ...) actual-value).  In many cases we could simplify this further by substitution, but we'd have to be careful (for example, we would need to alpha-convert any LET we found inside).  Any decent compiler will do it for us. ")
-
-                                          (LIST FN (SECOND FORM))))))
-                              ((AND (SETQ INFO (MEMBER SITE *ACTIVE-GATHERERS*))
-                                    (OR (EQ SITE '*ANONYMOUS-GATHERING-SITE*)
-                                        (VARIABLE-SAME-P SITE ENV (FOURTH INFO))))
-                                                             (IL:* IL:\; "Some other GATHERING will take care of this form, so pass it up for now. Environment check is to make sure nobody shadowed it between here and there ")
-                               FORM)
-                              (T                             (IL:* IL:\; 
-                                                           "Nobody's going to handle it")
-                                 (IF (EQ SITE '*ANONYMOUS-GATHERING-SITE*)
-                                                             (IL:* IL:\; 
-    "More likely that she forgot to mention the site than forget to write an anonymous gathering. ")
-                                     (WARN "There is no gathering site specified in ~S." FORM)
-                                     (WARN 
-                                   "The site ~S in ~S is not defined in an enclosing GATHERING form."
-                                           SITE FORM))       (IL:* IL:\; 
-                           "Turn it into something else so we don't warn twice in the nested case ")
-                                 `(%ORPHANED-GATHER ,@(CDR FORM)))))
-                          ((AND (SYMBOLP FORM)
-                                (SETQ INFO (ASSOC FORM ACC-INFO))
-                                (VARIABLE-SAME-P FORM ENV GATHERING-ENV))
-                                                             (IL:* IL:\; 
-                                   "A variable reference to a gather binding from environment TEM ")
-                           (MAYBE-WARN :USER 
-                "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form."
-                                  FORM)
-                           (RETURN-FROM WALK-GATHERING-BODY :ABORT))
-                          (T FORM)))))))
-
-
-
-(IL:* IL:|;;| "Sample gatherers")
-
-
-(DEFMACRO COLLECTING (&KEY INITIAL-VALUE)
-   `(LET* ((HEAD ,INITIAL-VALUE)
-           (TAIL ,(AND INITIAL-VALUE `(LAST HEAD))))
-          (VALUES #'(LAMBDA (VALUE)
-                           (IF (NULL HEAD)
-                               (SETQ HEAD (SETQ TAIL (LIST VALUE)))
-                               (SETQ TAIL (CDR (RPLACD TAIL (LIST VALUE))))))
-                 #'(LAMBDA NIL HEAD))))
-
-(DEFMACRO JOINING (&KEY INITIAL-VALUE)
-   `(LET ((RESULT ,INITIAL-VALUE))
-         (VALUES #'(LAMBDA (VALUE)
-                          (SETQ RESULT (NCONC RESULT VALUE)))
-                #'(LAMBDA NIL RESULT))))
-
-(DEFMACRO MAXIMIZING (&KEY INITIAL-VALUE)
-   `(LET ((RESULT ,INITIAL-VALUE))
-         (VALUES #'(LAMBDA (VALUE)
-                          (WHEN ,(COND
-                                    ((AND (CONSTANTP INITIAL-VALUE)
-                                          (NOT (NULL (EVAL INITIAL-VALUE))))
-                                                             (IL:* IL:\; 
-                    "Initial value is given and we know it's not NIL, so leave out the null check ")
-                                     '(> VALUE RESULT))
-                                    (T '(OR (NULL RESULT)
-                                            (> VALUE RESULT))))
-                                (SETQ RESULT VALUE)))
-                #'(LAMBDA NIL RESULT))))
-
-(DEFMACRO MINIMIZING (&KEY INITIAL-VALUE)
-   `(LET ((RESULT ,INITIAL-VALUE))
-         (VALUES #'(LAMBDA (VALUE)
-                          (WHEN ,(COND
-                                    ((AND (CONSTANTP INITIAL-VALUE)
-                                          (NOT (NULL (EVAL INITIAL-VALUE))))
-                                                             (IL:* IL:\; 
-                    "Initial value is given and we know it's not NIL, so leave out the null check ")
-                                     '(< VALUE RESULT))
-                                    (T '(OR (NULL RESULT)
-                                            (< VALUE RESULT))))
-                                (SETQ RESULT VALUE)))
-                #'(LAMBDA NIL RESULT))))
-
-(DEFMACRO SUMMING (&KEY (INITIAL-VALUE 0))
-   `(LET ((SUM ,INITIAL-VALUE))
-         (VALUES #'(LAMBDA (VALUE)
-                          (SETQ SUM (+ SUM VALUE)))
-                #'(LAMBDA NIL SUM))))
-
-
-
-(IL:* IL:\; "Easier to read expanded code if PROG1 gets left alone ")
-
-
-(XCL:DEFINE-FILE-ENVIRONMENT "ITERATE" :PACKAGE (IN-PACKAGE :ITERATE :USE '(:LISP :WALKER))
-   :READTABLE "XCL"
-   :BASE 10
-   :COMPILER :COMPILE-FILE)
-(IL:PUTPROPS IL:ITERATE IL:COPYRIGHT ("Venue" 1991))
-(IL:DECLARE\: IL:DONTCOPY
-  (IL:FILEMAP (NIL)))
-IL:STOP
diff --git a/obsolete/clos/2.0/lap.lisp b/obsolete/clos/2.0/lap.lisp
deleted file mode 100644
index 4dceda84..00000000
--- a/obsolete/clos/2.0/lap.lisp
+++ /dev/null
@@ -1,364 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;;. Copyright (c) 1991 by Venue
-
-(in-package "CLOS")
-
-;;; This file defines CLOS's interface to the LAP mechanism. The file is divided into two parts.  The
-;;; first part defines the interface used by CLOS to create abstract LAP code vectors.  CLOS never
-;;; creates lists that represent LAP code directly, it always calls this mechanism to do so. This
-;;; provides a layer of error checking on the LAP code before it gets to the implementation-specific
-;;; assembler.  Note that this error checking is syntactic only, but even so is useful to have. 
-;;; Because of it, no specific LAP assembler should worry itself with checking the syntax of the LAP
-;;; code. The second part of the file defines the LAP assemblers for each CLOS port. These are
-;;; included together in the same file to make it easier to change them all should some random
-;;; change be made in the LAP mechanism. 
-
-
-(defvar *make-lap-closure-generator*)
-
-(defvar *precompile-lap-closure-generator*)
-
-(defvar *lap-in-lisp*)
-
-(defun make-lap-closure-generator (closure-variables arguments iregs vregs tregs lap-code)
-       (funcall *make-lap-closure-generator* closure-variables arguments iregs vregs tregs lap-code))
-
-(defmacro precompile-lap-closure-generator (cvars args i-regs v-regs t-regs lap)
-       (funcall *precompile-lap-closure-generator* cvars args i-regs v-regs t-regs lap))
-
-(defmacro lap-in-lisp (cvars args iregs vregs tregs lap)
-       (declare (ignore cvars args))
-       `(locally (declare (optimize (safety 0)
-                                 (speed 3)))
-               ,(make-lap-prog iregs vregs tregs (flatten-lap lap (opcode :label 'exit-lap-in-lisp)))
-               ))
-
-
-;;; The following functions and macros are used by CLOS when generating LAP code: GENERATING-LAP
-;;; WITH-LAP-REGISTERS ALLOCATE-REGISTER DEALLOCATE-REGISTER LAP-FLATTEN OPCODE OPERAND 
-
-
-(proclaim '(special *generating-lap*))
-
-                                                             ; CAR   - alist of free registers CADR 
-                                                             ; - alist of allocated registers CADDR
-                                                             ; - max reg number allocated in each
-                                                             ; alist, the entries have the form: 
-                                                             ; (type . (:REG <n>)) 
-
-
-
-;;; This goes around the generation of any lap code.  <body> should return a lap code sequence, this
-;;; macro will take care of converting that to a lap closure generator. 
-
-
-(defmacro generating-lap (closure-variables arguments &body body)
-       `(let* ((*generating-lap* (list nil nil -1)))
-              (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
-
-(defmacro generating-lap-in-lisp (closure-variables arguments &body body)
-       `(let* ((*generating-lap* (list nil nil -1)))
-              (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body))))
-
-
-;;; Each register specification looks like: (<var> <type> &key :reuse <other-reg>) 
-
-
-(defmacro with-lap-registers (register-specifications &body body)
-       
-       ;; Given that, for now, there is only one keyword argument and that, for now, we do no error
-       ;; checking, we can be pretty sleazy about how this works. 
-       (flet ((make-allocations
-               nil
-               (gathering1 (collecting)
-                      (dolist (spec register-specifications)
-                          (gather1 `(,(car spec)
-                                     (or ,(cadddr spec)
-                                         (allocate-register ',(cadr spec))))))))
-              (make-deallocations nil (gathering1
-                                       (collecting)
-                                       (dolist (spec register-specifications)
-                                           (gather1 `(unless ,(cadddr spec)
-                                                         (deallocate-register ,(car spec))))))))
-             `(let ,(make-allocations)
-                   (multiple-value-prog1 (progn ,@body)
-                          ,@(make-deallocations)))))
-
-(defun allocate-register (type)
-       (destructuring-bind (free allocated)
-              *generating-lap*
-              (let ((entry (assoc type free)))
-                   (cond (entry (setf (car *generating-lap*)
-                                      (delete entry free)
-                                      (cadr *generating-lap*)
-                                      (cons entry allocated))
-                                (cdr entry))
-                         (t (let ((new `(,type :reg ,(incf (caddr *generating-lap*)))))
-                                 (setf (cadr *generating-lap*)
-                                       (cons new allocated))
-                                 (cdr new)))))))
-
-(defun deallocate-register (reg)
-       (let ((entry (rassoc reg (cadr *generating-lap*))))
-            (unless entry (error "Attempt to free an unallocated register."))
-            (push entry (car *generating-lap*))
-            (setf (cadr *generating-lap*)
-                  (delete entry (cadr *generating-lap*)))))
-
-(defvar *precompiling-lap* nil)
-
-(defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code)
-       (when (cadr *generating-lap*)
-             (error "Registers still allocated when lap being finalized."))
-       (let ((iregs nil)
-             (vregs nil)
-             (tregs nil))
-            (dolist (entry (car *generating-lap*))
-                (ecase (car entry)
-                    (index (push (caddr entry)
-                                 iregs))
-                    (vector (push (caddr entry)
-                                  vregs))
-                    ((t) (push (caddr entry)
-                               tregs))))
-            (cond (in-lisp-p (macroexpand `(lap-in-lisp ,closure-variables ,arguments ,iregs
-                                                  ,vregs
-                                                  ,tregs
-                                                  ,lap-code)))
-                  (*precompiling-lap* (values closure-variables arguments iregs vregs tregs lap-code)
-                         )
-                  (t (make-lap-closure-generator closure-variables arguments iregs vregs tregs 
-                            lap-code)))))
-
-(defun flatten-lap (&rest opcodes-or-sequences)
-       (let ((result nil))
-            (dolist (opcode-or-sequence opcodes-or-sequences result)
-                (cond ((null opcode-or-sequence))
-                      ((not (consp (car opcode-or-sequence)))
-                                                             ; its an opcode
-                       (setf result (append result (list opcode-or-sequence))))
-                      (t (setf result (append result opcode-or-sequence)))))))
-
-(defmacro flattening-lap nil '(let ((result nil))
-                                   (values #'(lambda (value)
-                                                    (push value result))
-                                          #'(lambda nil (apply #'flatten-lap (reverse result))))))
-
-
-;;; This code deals with the syntax of the individual opcodes and operands. The first two of these
-;;; variables are documented to all ports.  They are lists of the symbols which name the lap opcodes
-;;; and operands.  They can be useful to determine whether a port has implemented all the required
-;;; opcodes and operands. The third of these variables is for use of the emitter only. 
-
-
-(defvar *lap-operands* nil)
-
-(defvar *lap-opcodes* nil)
-
-(defvar *lap-emitters* (make-hash-table :test #'eq :size 30))
-
-(defun opcode (name &rest args)
-       (let ((emitter (gethash name *lap-emitters*)))
-            (if emitter
-                (apply emitter args)
-                (error "No opcode named ~S." name))))
-
-(defun operand (name &rest args)
-       (let ((emitter (gethash name *lap-emitters*)))
-            (if emitter
-                (apply emitter args)
-                (error "No operand named ~S." name))))
-
-(defmacro defopcode (name types)
-       (let ((fn-name (symbol-append "LAP Opcode " name *the-clos-package*))
-             (lambda-list (mapcar #'(lambda (x)
-                                           (declare (ignore x))
-                                           (gensym))
-                                 types)))
-            `(progn (eval-when (load eval)
-                           (load-defopcode ',name ',fn-name))
-                    (defun ,fn-name ,lambda-list (defopcode-1 ',name ',types ,@lambda-list)))))
-
-(defmacro defoperand (name types)
-       (let ((fn-name (symbol-append "LAP Operand " name *the-clos-package*))
-             (lambda-list (mapcar #'(lambda (x)
-                                           (declare (ignore x))
-                                           (gensym))
-                                 types)))
-            `(progn (eval-when (load eval)
-                           (load-defoperand ',name ',fn-name))
-                    (defun ,fn-name ,lambda-list (defoperand-1 ',name ',types ,@lambda-list)))))
-
-(defun load-defopcode (name fn-name)
-       (if* (memq name *lap-operands*)
-            (error "LAP opcodes and operands must have disjoint names.")
-            (setf (gethash name *lap-emitters*)
-                  fn-name)
-            (pushnew name *lap-opcodes*)))
-
-(defun load-defoperand (name fn-name)
-       (if* (memq name *lap-opcodes*)
-            (error "LAP opcodes and operands must have disjoint names.")
-            (setf (gethash name *lap-emitters*)
-                  fn-name)
-            (pushnew name *lap-operands*)))
-
-(defun defopcode-1 (name operand-types &rest args)
-       (iterate ((arg (list-elements args))
-                 (type (list-elements operand-types)))
-              (check-opcode-arg name arg type))
-       (cons name (copy-list args)))
-
-(defun defoperand-1 (name operand-types &rest args)
-       (iterate ((arg (list-elements args))
-                 (type (list-elements operand-types)))
-              (check-operand-arg name arg type))
-       (cons name (copy-list args)))
-
-(defun check-opcode-arg (name arg type)
-       (labels ((usual (x)
-                       (and (consp arg)
-                            (eq (car arg)
-                                x)))
-                (check (x)
-                       (ecase x
-                           ((:reg :cdr :constant :iref :cvar :arg :lisp :lisp-variable) (usual x))
-                           (:label (symbolp arg))
-                           (:operand (and (consp arg)
-                                          (memq (car arg)
-                                                *lap-operands*))))))
-              (unless (if (consp type)
-                          (if (eq (car type)
-                                  'or)
-                              (some #'check (cdr type))
-                              (error "What type is this?"))
-                          (check type))
-                     (error "The argument ~S to the opcode ~A is not of type ~S." arg name type))))
-
-(defun check-operand-arg (name arg type)
-       (flet ((check (x)
-                     (ecase x
-                         (:symbol (symbolp arg))
-                         (:register-number (and (integerp arg)
-                                                (>= x 0)))
-                         (:t t)
-                         (:reg (and (consp arg)
-                                    (eq (car arg)
-                                        :reg)))
-                         (:fixnum (typep arg 'fixnum)))))
-             (unless (if (consp type)
-                         (if (eq (car type)
-                                 'or)
-                             (some #'check (cdr type))
-                             (error "What type is this?"))
-                         (check type))
-                    (error "The argument ~S to the operand ~A is not of type ~S." arg name type))))
-
-
-;;; The actual opcodes. 
-
-
-(defopcode :break nil)
-
-                                                             ; For debugging only.  Not
-
-
-(defopcode :beep nil)
-
-                                                             ; all ports are required to
-
-
-(defopcode :print (:reg))
-
-                                                             ; implement this.
-
-
-(defopcode :move (:operand (or :reg :iref :cdr :lisp-variable)))
-
-(defopcode :eq ((or :reg :constant)
-                (or :reg :constant)
-                :label))
-
-(defopcode :neq ((or :reg :constant)
-                 (or :reg :constant)
-                 :label))
-
-(defopcode :fix= ((or :reg :constant)
-                  (or :reg :constant)
-                  :label))
-
-(defopcode :izerop (:reg :label))
-
-(defopcode :std-instance-p (:reg :label))
-
-(defopcode :fsc-instance-p (:reg :label))
-
-(defopcode :built-in-instance-p (:reg :label))
-
-(defopcode :structure-instance-p (:reg :label))
-
-(defopcode :jmp ((or :reg :constant)))
-
-(defopcode :label (:label))
-
-(defopcode :go (:label))
-
-(defopcode :return ((or :reg :constant)))
-
-(defopcode :exit-lap-in-lisp nil)
-
-
-;;; The actual operands. 
-
-
-(defoperand :reg (:register-number))
-
-(defoperand :cvar (:symbol))
-
-(defoperand :arg (:symbol))
-
-(defoperand :cdr (:reg))
-
-(defoperand :constant (:t))
-
-(defoperand :std-wrapper (:reg))
-
-(defoperand :fsc-wrapper (:reg))
-
-(defoperand :built-in-wrapper (:reg))
-
-(defoperand :structure-wrapper (:reg))
-
-(defoperand :other-wrapper (:reg))
-
-(defoperand :std-slots (:reg))
-
-(defoperand :fsc-slots (:reg))
-
-(defoperand :cref (:reg :fixnum))
-
-(defoperand :iref (:reg :reg))
-
-(defoperand :iset (:reg :reg :reg))
-
-(defoperand :i1+ (:reg))
-
-(defoperand :i+ (:reg :reg))
-
-(defoperand :i- (:reg :reg))
-
-(defoperand :ilogand (:reg :reg))
-
-(defoperand :ilogxor (:reg :reg))
-
-(defoperand :ishift (:reg :fixnum))
-
-(defoperand :lisp (:t))
-
-(defoperand :lisp-variable (:symbol))
-
-
-;;; LAP tests (there need to be a lot more of these) 
-
diff --git a/obsolete/clos/2.0/load-clos.lisp b/obsolete/clos/2.0/load-clos.lisp
deleted file mode 100644
index 8ba7e9a2..00000000
--- a/obsolete/clos/2.0/load-clos.lisp
+++ /dev/null
@@ -1,42 +0,0 @@
-;;; -*- Mode: Lisp; Package: xcl-User ; Base: 10.; Syntax: Common-Lisp -*-
-;;;
-
-(in-package "CLOS" :use (list (or (find-package :walker)
-				    (make-package :walker :use '(:lisp)))
-				(or (find-package :iterate)
-				    (make-package :iterate
-						  :use '(:lisp :walker)))
-				(find-package :lisp)))
-(export (intern (symbol-name :iterate)		;Have to do this here,
-		(find-package :iterate))	;because in the defsystem
-	(find-package :iterate))		;(later in this file)
-						;we use the symbol iterate
-						;to name the file
-
-(defun load-truename (&optional (errorp nil))
-  (flet ((bad-time ()
-	   (when errorp
-	     (error "LOAD-TRUENAME called but a file isn't being loaded."))))
-    (let ((filename (pathname (il:fullname *standard-input*))))
-      (if filename
-	  (make-pathname :host (pathname-host filename) :device
-			 (pathname-device filename) :directory
-			 (pathname-directory filename) :name "") 
-	  (bad-time)))))
-
-(defvar *clos-directory* (load-truename))
-
-(defun load-clos (&optional pathname)
-  (defvar *clos-system-date* "7/14/91 Medley 2.0 (interim)")
-  (defvar *the-clos-package* (find-package :clos))
-  (dolist (filename '(patch pkg walk iterate macros low low2 fin
-		    defclass defs fngen lap plap cache dlap boot
-		    vector slots init std-class cpl braid fsc methods
-		    combin dfun precom1 precom2 precom4 fixup
-		    defcombin ctypes construct env))
-
-    (load (merge-pathnames 
-			 (make-pathname  :name (string-downcase filename) :type
-					 "dfasl") (or pathname *clos-directory*))))
-  (pushnew :clos cl:*features*))
-
diff --git a/obsolete/clos/2.0/low.lisp b/obsolete/clos/2.0/low.lisp
deleted file mode 100644
index dcd28cef..00000000
--- a/obsolete/clos/2.0/low.lisp
+++ /dev/null
@@ -1,194 +0,0 @@
-
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;; File converted on 26-Mar-91 10:29:45 from source low
-;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>low.;4 created 27-Feb-91 17:16:47
-
-;;;. Copyright (c) 1991 by Venue
-
-
-
-(in-package "CLOS")
-
-;;; Shadow, Export, Require, Use-package, and Import forms should follow here
-
-
-
-;;;
-;;;*************************************************************************
-;;;Copyright (c) 1991 Venue
-;;; This file contains portable versions of low-level functions and macros which are ripe for
-;;; implementation specific customization.  None of the code in this file *has* to be customized for
-;;; a particular Common Lisp implementation. Moreover, in some implementations it may not make any
-;;; sense to customize some of this code. ks. 
-
-
-(defmacro %svref (vector index)
-       `(locally (declare (optimize (speed 3)
-                                 (safety 0))
-                        (inline svref))
-               (svref (the simple-vector ,vector)
-                      (the fixnum ,index))))
-
-(defsetf %svref (vector index)
-       (new-value)
-       `(locally (declare (optimize (speed 3)
-                                 (safety 0))
-                        (inline svref))
-               (setf (svref (the simple-vector ,vector)
-                            (the fixnum ,index))
-                     ,new-value)))
-
-
-;;; without-interrupts OK, Common Lisp doesn't have this and for good reason.  But For all of the
-;;; Common Lisp's that CLOS runs on today, there is a meaningful way to implement this.  WHAT I MEAN
-;;; IS: I want the body to be evaluated in such a way that no other code that is running CLOS can be
-;;; run during that evaluation.  I agree that the body won't take *long* to evaluate.  That is to
-;;; say that I will only use without interrupts around relatively small computations. INTERRUPTS-ON
-;;; should turn interrupts back on if they were on. INTERRUPTS-OFF should turn interrupts back off.
-;;; These are only valid inside the body of WITHOUT-INTERRUPTS. OK? 
-
-
-
-;;; AKW: IT'S CALLED, BUT NEVER REALLY USED, SO I'VE REPLACED IT WITH THE PROGN. IF WE REALLY NEED
-;;; IT, CAN BE TRIVIALLY DONE WITH IL:MONITORS
-
-
-(defmacro without-interrupts (&body body)
-       `(progn ,.body))
-
-
-;;; Very Low-Level representation of instances with meta-class standard-class. 
-
-
-(defmacro std-instance-wrapper (x)
-       `(%std-instance-wrapper ,x))
-
-(defmacro std-instance-slots (x)
-       `(%std-instance-slots ,x))
-
-(defun print-std-instance (instance stream depth)
-                                                             ; A temporary definition used
-       (declare (ignore depth))
-                                                             ; for debugging the bootstrap
-       (printing-random-thing (instance stream)
-                                                             ; code of CLOS (See high.lisp).
-              (format stream "#<std-instance>")))
-
-(defmacro %allocate-instance--class (no-of-slots)
-       `(let ((instance (%%allocate-instance--class)))
-             (%allocate-instance--class-1 ,no-of-slots instance)
-             instance))
-
-(defmacro %allocate-instance--class-1 (no-of-slots instance)
-       (once-only (instance)
-              `(progn (setf (std-instance-slots ,instance)
-                            (%allocate-static-slot-storage--class ,no-of-slots)))))
-
-
-;;; This is the value that we stick into a slot to tell us that it is unbound. It may seem gross,
-;;; but for performance reasons, we make this an interned symbol.  That means that the fast check to
-;;; see if a slot is unbound is to say (EQ <val> '..SLOT-UNBOUND..).  That is considerably faster
-;;; than looking at the value of a special variable.  Be careful, there are places in the code which
-;;; actually use ..slot-unbound.. rather than this variable.  So much for modularity 
-
-
-(defvar *slot-unbound* '..slot-unbound..)
-
-(defmacro %allocate-static-slot-storage--class (no-of-slots)
-       `(make-array ,no-of-slots :initial-element *slot-unbound*))
-
-(defmacro std-instance-class (instance)
-       `(wrapper-class (std-instance-wrapper ,instance)))
-
-
-;; 
-
-
-
-;;; FUNCTION-ARGLIST
-
-
-
-;; 
-
-
-
-;;; [COMMENTED OUT AKW. NEVER CALLED] Given something which is functionp, function-arglist should
-;;; return the argument list for it.  CLOS does not count on having this available, but
-;;; MAKE-SPECIALIZABLE works much better if it is available.  Versions of function-arglist for each
-;;; specific port of clos should be put in the appropriate xxx-low file. This is what it should look
-;;; like: 
-
-
-                                                             ; (defun function-arglist (function)
-                                                             ; (<system-dependent-arglist-function>
-                                                             ; function)) 
-
-
-
-;; (FUNCTIONS CLOS::FUNCTION-PRETTY-ARGLIST) (SETFS CLOS::FUNCTION-PRETTY-ARGLIST) (FUNCTIONS
-;; CLOS::SET-FUNCTION-PRETTY-ARGLIST)
-
-
-
-;;; set-function-name When given a function should give this function the name <new-name>. Note that
-;;; <new-name> is sometimes a list.  Some lisps get the upset in the tummy when they start thinking
-;;; about functions which have lists as names.  To deal with that there is set-function-name-intern
-;;; which takes a list spec for a function name and turns it into a symbol if need be. When given a
-;;; funcallable instance, set-function-name MUST side-effect that FIN to give it the name.  When
-;;; given any other kind of function set-function-name is allowed to return new function which is
-;;; the 'same' except that it has the name. In all cases, set-function-name must return the new (or
-;;; same) function. 
-
-
-(defun set-function-name #'new-name (declare (notinline set-function-name-1 intern-function-name))
-       (set-function-name-1 function (intern-function-name new-name)
-              new-name))
-
-(defun set-function-name-1 (fn new-name uninterned-name)
-       (cond ((typep fn 'il:compiled-closure)
-              (il:\\rplptr (compiled-closure-fnheader fn)
-                     4 new-name)
-              (when (and (consp uninterned-name)
-                         (eq (car uninterned-name)
-                             'method))
-                  (let ((debug (si::compiled-function-debugging-info fn)))
-                       (when debug
-                           (setf (cdr debug)
-                                 uninterned-name)))))
-             (t nil))
-       fn)
-
-(defun intern-function-name (name)
-       (cond ((symbolp name)
-              name)
-             ((listp name)
-              (intern (let ((*package* *the-clos-package*)
-                            (*print-case* :upcase)
-                            (*print-gensym* 't))
-                           (format nil "~S" name))
-                     *the-clos-package*))))
-
-
-;;; COMPILE-LAMBDA This is like the Common Lisp function COMPILE.  In fact, that is what it ends up
-;;; calling.   
-
-
-(defun compile-lambda (lambda &rest desirability)
-       (declare (ignore desirability))
-       (compile nil lambda))
-
-(defmacro precompile-random-code-segments (&optional system)
-  `(progn
-     (precompile-function-generators ,system)
-     (precompile-dfun-constructors ,system)))
-
-
-
-(defun record-definition (type spec &rest args)
-  (declare (ignore type spec args))
-  ())
-
-(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
\ No newline at end of file
diff --git a/obsolete/clos/2.0/low2.lisp b/obsolete/clos/2.0/low2.lisp
deleted file mode 100644
index 0c648b9b..00000000
--- a/obsolete/clos/2.0/low2.lisp
+++ /dev/null
@@ -1,144 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;; File converted on 26-Mar-91 10:30:44 from source xerox-low
-;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>xerox-low.;3 created 27-Feb-91 16:37:43
-
-;;;. Copyright (c) 1991 by Venue
-
-
-
-(in-package "CLOS")
-
-;;; Shadow, Export, Require, Use-package, and Import forms should follow here
-
-
-
-;;; ************************************************************************* This is the 1100
-;;; (Xerox version) of the file portable-low. 
-
-
-(defmacro load-time-eval (form)
-       `(il:loadtimeconstant ,form))
-
-
-;;; make the pointer from an instance to its class wrapper be an xpointer. this prevents instance
-;;; creation from spending a lot of time incrementing the large refcount of the class-wrapper.  This
-;;; is safe because there will always be some other pointer to the wrapper to keep it around. 
-
-
-(defstruct (std-instance (:predicate std-instance-p)
-                  (:conc-name %std-instance-)
-                  (:constructor %%allocate-instance--class nil)
-                  (:fast-accessors t)
-                  (:print-function %print-std-instance))
-       (wrapper nil :type il:fullxpointer)
-       (slots nil))
-
-(defun %print-std-instance (instance &optional stream depth)
-       
-       ;; See the IRM, section 25.3.3.  Unfortunatly, that documentation is not correct.  In
-       ;; particular, it makes no mention of the third argument. 
-       (cond ((streamp stream)
-              
-              ;; Use the standard CLOS printing method, then return T to tell the printer that we
-              ;; have done the printing ourselves. 
-              (print-std-instance instance stream depth)
-              t)
-             (t 
-                ;; Internal printing (again, see the IRM section 25.3.3). Return a list containing
-                ;; the string of characters that would be printed, if the object were being printed
-                ;; for real. 
-                (list (with-output-to-string (stream)
-                             (print-std-instance instance stream depth))))))
-
-
-;; 
-
-
-
-;;; FUNCTION-ARGLIST
-
-
-
-;; 
-
-
-(defun function-arglist (x)
-       
-       ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and strings instead of
-       ;; symbols.  How silly. 
-       (let ((arglist (il:arglist x)))
-            (when (symbolp arglist)
-                
-                ;; This could be due to trying to extract the arglist of an interpreted function
-                ;; (though why that should be hard is beyond me).  On the other hand, if the
-                ;; function is compiled, it helps to ask for the "smart" arglist. 
-                (setq arglist (if (consp (symbol-function x))
-                                  (second (symbol-function x))
-                                  (il:arglist x t))))
-            (if (symbolp arglist)
-                
-                ;; Probably never get here, but just in case
-                (list '&rest 'rest)
-                
-                ;; Make sure there are no strings where there should be symbols
-                (if (some #'stringp arglist)
-                    (mapcar #'(lambda (a)
-                                     (if (symbolp a)
-                                         a
-                                         (intern a)))
-                           arglist)
-                    arglist))))
-
-(defun printing-random-thing-internal (thing stream)
-       (let ((*print-base* 8))
-            (princ (il:\\hiloc thing)
-                   stream)
-            (princ "," stream)
-            (princ (il:\\loloc thing)
-                   stream)))
-
-(defun record-definition (name type &optional parent-name parent-type)
-       (declare (ignore type parent-name))
-       nil)
-
-
-;;; FIN uses this too! 
-
-
-(eval-when (compile load eval)
-       (il:datatype il:compiled-closure (il:fnheader il:environment))
-       (il:blockrecord closure-overlay ((funcallable-instance-p il:flag))))
-
-(defun compiled-closure-fnheader (compiled-closure)
-       (il:fetch (il:compiled-closure il:fnheader)
-              il:of compiled-closure))
-
-(defun set-compiled-closure-fnheader (compiled-closure nv)
-       (il:replace (il:compiled-closure il:fnheader)
-              il:of compiled-closure nv))
-
-(defsetf compiled-closure-fnheader set-compiled-closure-fnheader)
-
-
-;;; In Lyric, and until the format of FNHEADER changes, getting the name from a compiled closure
-;;; looks like this: (fetchfield '(nil 4 pointer) (fetch (compiled-closure fnheader) closure)) Of
-;;; course this is completely non-robust, but it will work for now.  This is not the place to go
-;;; into a long tyrade about what is wrong with having record package definitions go away when you
-;;; ship the sysout; there isn't enough diskspace. 
-
-
-(defun set-function-name-1 (fn new-name uninterned-name)
-       (cond ((typep fn 'il:compiled-closure)
-              (il:\\rplptr (compiled-closure-fnheader fn)
-                     4 new-name)
-              (when (and (consp uninterned-name)
-                         (eq (car uninterned-name)
-                             'method))
-                  (let ((debug (si::compiled-function-debugging-info fn)))
-                       (when debug
-                           (setf (cdr debug)
-                                 uninterned-name)))))
-             (t nil))
-       fn)
diff --git a/obsolete/clos/2.0/macros.lisp b/obsolete/clos/2.0/macros.lisp
deleted file mode 100644
index 4f6a294d..00000000
--- a/obsolete/clos/2.0/macros.lisp
+++ /dev/null
@@ -1,355 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;; File converted on 26-Mar-91 10:27:21 from source macros
-;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>macros.;3 created 19-Feb-91 13:51:21
-
-;;;. Copyright (c) 1991 Venue
-
-
-
-(in-package "CLOS")
-
-
-;;;Macros global variable
-;;; definitions, and other random support stuff used by the rest of the system. For simplicity (not
-;;; having to use eval-when a lot), this file must be loaded before it can be compiled. 
-
-
-(in-package 'clos)
-
-(proclaim '(declaration values arglist indentation class variable-rebinding clos-fast-call))
-
-
-;;; Age old functions which CommonLisp cleaned-up away.  They probably exist in other packages in
-;;; all CommonLisp implementations, but I will leave it to the compiler to optimize into calls to
-;;; them. Common Lisp BUG: Some Common Lisps define these in the Lisp package which causes all sorts
-;;; of lossage.  Common Lisp should explictly specify which symbols appear in the Lisp package. 
-
-
-(eval-when (compile load eval)
-       (defmacro memq (item list)
-              `(member ,item ,list :test #'eq))
-       (defmacro assq (item list)
-              `(assoc ,item ,list :test #'eq))
-       (defmacro rassq (item list)
-              `(rassoc ,item ,list :test #'eq))
-       (defmacro delq (item list)
-              `(delete ,item ,list :test #'eq))
-       (defmacro posq (item list)
-              `(position ,item ,list :test #'eq))
-       (defmacro neq (x y)
-              `(not (eq ,x ,y)))
-       (defun make-caxr (n form)
-              (if (< n 4)
-                  `(,(nth n '(car cadr caddr cadddr))
-                    ,form)
-                  (make-caxr (- n 4)
-                         `(cddddr ,form))))
-       (defun make-cdxr (n form)
-              (cond ((zerop n)
-                     form)
-                    ((< n 5)
-                     `(,(nth n '(identity cdr cddr cdddr cddddr))
-                       ,form))
-                    (t (make-cdxr (- n 4)
-                              `(cddddr ,form))))))
-
-(defun zero (&rest ignore)
-       (declare (ignore ignore))
-       0)
-
-(defun make-plist (keys vals)
-       (if (null vals)
-           nil
-           (list* (car keys)
-                  (car vals)
-                  (make-plist (cdr keys)
-                         (cdr vals)))))
-
-(defun remtail (list tail)
-       (if (eq list tail)
-           nil
-           (cons (car list)
-                 (remtail (cdr list)
-                        tail))))
-
-
-;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just lifted it from there
-;;; but I am honest.  Not only that but this one is written in Common Lisp.  I feel a lot like
-;;; bootstrapping, or maybe more like rebuilding Rome. 
-
-
-(defmacro once-only (vars &body body)
-       (let ((gensym-var (gensym))
-             (run-time-vars (gensym))
-             (run-time-vals (gensym))
-             (expand-time-val-forms nil))
-            (dolist (var vars)
-                (push `(if (or (symbolp ,var)
-                               (numberp ,var)
-                               (and (listp ,var)
-                                    (member (car ,var)
-                                           ''function)))
-                           ,var
-                           (let ((,gensym-var (gensym)))
-                                (push ,gensym-var ,run-time-vars)
-                                (push ,var ,run-time-vals)
-                                ,gensym-var))
-                      expand-time-val-forms))
-            `(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars
-                                                                             (reverse 
-                                                                                expand-time-val-forms
-                                                                                    ))
-                                                                     ,@body)))
-                   `(let ,(mapcar #'list (reverse ,run-time-vars)
-                                 (reverse ,run-time-vals))
-                         ,wrapped-body))))
-
-(eval-when
- (compile load eval)
- (defun extract-declarations (body &optional environment)
-        (declare (values documentation declarations body))
-        (let (documentation declarations form)
-             (when (and (stringp (car body))
-                        (cdr body))
-                 (setq documentation (pop body)))
-             (block outer
-                 (loop (when (null body)
-                             (return-from outer nil))
-                       (setq form (car body))
-                       (when (block inner
-                                 (loop (cond ((not (listp form))
-                                              (return-from outer nil))
-                                             ((eq (car form)
-                                                  'declare)
-                                              (return-from inner 't))
-                                             (t (multiple-value-bind
-                                                 (newform macrop)
-                                                 (macroexpand-1 form environment)
-                                                 (if (or (not (eq newform form))
-                                                         macrop)
-                                                     (setq form newform)
-                                                     (return-from outer nil)))))))
-                           (pop body)
-                           (dolist (declaration (cdr form))
-                               (push declaration declarations)))))
-             (values documentation (and declarations `((declare ,.(nreverse declarations))))
-                    body))))
-
-(defvar *keyword-package* (find-package 'keyword))
-
-(defun make-keyword (symbol)
-       (intern (symbol-name symbol)
-              *keyword-package*))
-
-(eval-when (compile load eval)
-       (defun string-append (&rest strings)
-              (setq strings (copy-list strings))
-                                                             ; The explorer can't even rplaca an
-                                                             ; &rest arg? 
-              (do ((string-loc strings (cdr string-loc)))
-                  ((null string-loc)
-                   (apply #'concatenate 'string strings))
-                (rplaca string-loc (string (car string-loc))))))
-
-(defun symbol-append (sym1 sym2 &optional (package *package*))
-       (intern (string-append sym1 sym2)
-              package))
-
-(defmacro check-member (place list &key (test #'eql)
-                              (pretty-name place))
-       (once-only (place list)
-              `(or (member ,place ,list :test ,test)
-                   (error "The value of ~A, ~S is not one of ~S." ',pretty-name ,place ,list))))
-
-(defmacro alist-entry (alist key make-entry-fn)
-       (once-only (alist key)
-              `(or (assq ,key ,alist)
-                   (progn (setf ,alist (cons (,make-entry-fn ,key)
-                                             ,alist))
-                          (car ,alist)))))
-
-(defmacro collecting-once (&key initial-value)
-       `(let* ((head ,initial-value)
-               (tail ,(and initial-value `(last head))))
-              (values #'(lambda (value)
-                               (if (null head)
-                                   (setq head (setq tail (list value)))
-                                   (unless (memq value head)
-                                       (setq tail (cdr (rplacd tail (list value)))))))
-                     #'(lambda nil head))))
-
-(defmacro doplist ((key val)
-                   plist &body body &environment env)
-       (multiple-value-bind (doc decls bod)
-              (extract-declarations body env)
-              (declare (ignore doc))
-              `(let ((.plist-tail. ,plist)
-                     ,key
-                     ,val)
-                    ,@decls
-                    (loop (when (null .plist-tail.)
-                                (return nil))
-                          (setq ,key (pop .plist-tail.))
-                          (when (null .plist-tail.)
-                                (error "Malformed plist in doplist, odd number of elements."))
-                          (setq ,val (pop .plist-tail.))
-                          (progn ,@bod)))))
-
-(defmacro if* (condition true &rest false)
-       `(if ,condition
-            ,true
-            (progn ,@false)))
-
-
-;; 
-
-
-
-;;; printing-random-thing
-
-
-
-;; 
-
-
-
-;;; Similar to printing-random-object in the lisp machine but much simpler and machine independent. 
-
-
-(defmacro printing-random-thing ((thing stream)
-                                 &body body)
-       (once-only (stream)
-              `(progn (format ,stream "#<")
-                      ,@body
-                      (format ,stream " ")
-                      (printing-random-thing-internal ,thing ,stream)
-                      (format ,stream ">"))))
-
-(defun printing-random-thing-internal (thing stream)
-       (let ((*print-base* 8))
-            (princ (il:\\hiloc thing)
-                   stream)
-            (princ "," stream)
-            (princ (il:\\loloc thing)
-                   stream)))
-
-
-;; 
-
-
-
-;;; 
-
-
-
-;; 
-
-
-(defun capitalize-words (string &optional (dashes-p t))
-       (let ((string (copy-seq (string string))))
-            (declare (string string))
-            (do* ((flag t flag)
-                  (length (length string)
-                         length)
-                  (char nil char)
-                  (i 0 (+ i 1)))
-                 ((= i length)
-                  string)
-               (setq char (elt string i))
-               (cond ((both-case-p char)
-                      (if flag
-                          (and (setq flag (lower-case-p char))
-                               (setf (elt string i)
-                                     (char-upcase char)))
-                          (and (not flag)
-                               (setf (elt string i)
-                                     (char-downcase char))))
-                      (setq flag nil))
-                     ((char-equal char #\-)
-                      (setq flag t)
-                      (unless dashes-p
-                          (setf (elt string i)
-                                #\Space)))
-                     (t (setq flag nil))))))
-
-
-;;; FIND-CLASS This is documented in the CLOS specification. 
-
-
-(defvar *find-class* (make-hash-table :test #'eq))
-
-(defun legal-class-name-p (x)
-       (and (symbolp x)
-            (not (keywordp x))))
-
-(defun find-class (symbol &optional (errorp t)
-                         environment)
-       (declare (ignore environment))
-       (or (gethash symbol *find-class*)
-           (cond ((null errorp)
-                  nil)
-                 ((legal-class-name-p symbol)
-                  (error "No class named: ~S." symbol))
-                 (t (error "~S is not a legal class name." symbol)))))
-
-(defsetf find-class (symbol &optional (errorp t)
-                           environment)
-       (new-value)
-       (declare (ignore errorp environment))
-       `(|SETF CLOS FIND-CLASS| ,new-value ,symbol))
-
-(defun |SETF CLOS FIND-CLASS| (new-value symbol)
-       (if (legal-class-name-p symbol)
-           (setf (gethash symbol *find-class*)
-                 new-value)
-           (error "~S is not a legal class name." symbol)))
-
-(defun find-wrapper (symbol)
-       (class-wrapper (find-class symbol)))
-
-(defmacro gathering1 (gatherer &body body)
-  `(gathering ((.gathering1. ,gatherer))
-               (macrolet ((gather1 (x)
-                                 `(gather ,x .gathering1.)))
-                      ,@body)))
-
-
-;;; 
-
-
-(defmacro vectorizing (&key (size 0))
-       `(let* ((limit ,size)
-               (result (make-array limit))
-               (index 0))
-              (values #'(lambda (value)
-                               (if (= index limit)
-                                   (error "vectorizing more elements than promised.")
-                                   (progn (setf (svref result index)
-                                                value)
-                                          (incf index)
-                                          value)))
-                     #'(lambda nil result))))
-
-
-;;; These are augmented definitions of list-elements and list-tails from iterate.lisp.  These
-;;; versions provide the extra :by keyword which can be used to specify the step function through
-;;; the list. 
-
-
-(defmacro *list-elements (list &key (by #'cdr))
-       `(let ((tail ,list))
-             #'(lambda (finish)
-                      (if (endp tail)
-                          (funcall finish)
-                          (prog1 (car tail)
-                              (setq tail (funcall ,by tail)))))))
-
-(defmacro *list-tails (list &key (by #'cdr))
-       `(let ((tail ,list))
-             #'(lambda (finish)
-                      (prog1 (if (endp tail)
-                                 (funcall finish)
-                                 tail)
-                          (setq tail (funcall ,by tail))))))
diff --git a/obsolete/clos/2.0/methods.lisp b/obsolete/clos/2.0/methods.lisp
deleted file mode 100644
index fa52befe..00000000
--- a/obsolete/clos/2.0/methods.lisp
+++ /dev/null
@@ -1,1304 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;;. Copyright (c) 1991 by Venue
-
-(in-package "CLOS")
-
-
-
-;;; METHODS Methods themselves are simple inanimate objects.  Most properties of methods are
-;;; immutable, methods cannot be reinitialized.  The following properties of methods can be changed:
-;;; METHOD-GENERIC-FUNCTION METHOD-FUNCTION            ?? 
-
-(defclass method (metaobject) ())
-
-(defclass standard-method (definition-source-mixin documentation-mixin method)
-     ((generic-function
-	:initform nil	
-	:accessor method-generic-function)
-;     (qualifiers
-;	:initform ()
-;	:initarg  :qualifiers
-;	:reader method-qualifiers)
-      (specializers
-	:initform ()
-	:initarg  :specializers
-	:reader method-specializers)
-      (lambda-list
-	:initform ()
-	:initarg  :lambda-list
-	:reader method-lambda-list)
-      (function
-	:initform nil
-	:initarg :function
-	:reader method-function)		;writer defined by hand
-;     (documentation
-;	:initform ""
-;	:initarg  :documentation)
-      ))
-
-(defclass standard-accessor-method (standard-method)
-     ((slot-name :initform nil
-		 :initarg :slot-name)))
-
-
-;;; This method has to be defined by hand!  Don't try to define it using :accessor or :reader.  It
-;;; can't be an automatically generated reader method because that would break the way the special
-;;; discriminator code which uses this feature works.  -- Probably false now 8/21 
-
-
-(defmethod accessor-method-slot-name ((m standard-accessor-method))
-       (slot-value m 'slot-name))
-
-(defclass standard-reader-method (standard-accessor-method) ())
-(defclass standard-writer-method (standard-accessor-method) ())
-
-(defmethod print-object ((method standard-method)
-                         stream)
-       (printing-random-thing (method stream)
-              (let ((generic-function (method-generic-function method))
-                    (class-name (capitalize-words (class-name (class-of method)))))
-                   (format stream "~A ~S ~{~S ~}~:S" class-name (and generic-function (
-                                                                                generic-function-name
-                                                                                       
-                                                                                     generic-function
-                                                                                       ))
-                          (method-qualifiers method)
-                          (unparse-specializers method)))))
-
-(defmethod print-object ((method standard-accessor-method)
-                         stream)
-       (printing-random-thing (method stream)
-              (let ((generic-function (method-generic-function method))
-                    (class-name (capitalize-words (class-name (class-of method)))))
-                   (format stream "~A ~S, slot:~S, ~:S" class-name (and generic-function (
-                                                                                generic-function-name
-                                                                                          
-                                                                                     generic-function
-                                                                                          ))
-                          (accessor-method-slot-name method)
-                          (unparse-specializers method)))))
-
-
-;;; INITIALIZATION Error checking is done in before methods.  Because of the simplicity of standard
-;;; method objects the standard primary method can fill the slots. Methods are not reinitializable. 
-
-
-(defmethod reinitialize-instance ((method standard-method)
-                                  &rest initargs)
-       (declare (ignore initargs))
-       (error 
-        "Attempt to reinitialize the method ~S.~%~
-          Method objects cannot be reinitialized." method))
-
-(defmethod shared-initialize :before ((method standard-method)
-                                      slot-names &key qualifiers lambda-list specializers function 
-                                      documentation)
-       (declare (ignore slot-names))
-       (flet ((lose (initarg value string)
-                    (error "When initializing the method ~S:~%~
-                   The ~S initialization argument was: ~S.~%~
-                   which ~A." method initarg value string)))
-             (let ((check-qualifiers (legal-std-qualifiers-p qualifiers))
-                   (check-lambda-list (legal-std-lambda-list-p lambda-list))
-                   (check-specializers (legal-std-specializers-p specializers))
-                   (check-function (legal-std-method-function-p function))
-                   (check-documentation (legal-std-documentation-p documentation)))
-                  (unless (eq check-qualifiers t)
-                         (lose :qualifiers qualifiers check-qualifiers))
-                  (unless (eq check-lambda-list t)
-                         (lose :lambda-list lambda-list check-lambda-list))
-                  (unless (eq check-specializers t)
-                         (lose :specializers specializers check-specializers))
-                  (unless (eq check-function t)
-                         (lose :function function check-function))
-                  (unless (eq check-documentation t)
-                         (lose :documentation documentation check-documentation)))))
-
-(defmethod shared-initialize :before ((method standard-accessor-method)
-                                      slot-names &key slot-name)
-       (declare (ignore slot-names))
-       (let ((legalp (legal-std-slot-name-p slot-name)))
-            (unless (eq legalp t)
-                   (error "The value of the :SLOT-NAME initarg ~A." legalp))))
-
-(defmethod shared-initialize :after ((method standard-method)
-                                     slot-names &key qualifiers)
-       (setf (plist-value method 'qualifiers)
-             qualifiers))
-
-(defmethod method-qualifiers ((method standard-method))
-       (plist-value method 'qualifiers))
-
-(defclass generic-function (dependent-update-mixin
-			    definition-source-mixin
-			    metaobject)
-     ()
-  (:metaclass funcallable-standard-class))
-    
-(defclass standard-generic-function (generic-function)
-     ((name
-	:initform nil
-	:initarg :name
-	:accessor generic-function-name)
-      (methods
-	:initform ()
-	:accessor generic-function-methods)
-      (method-class
-	:initarg :method-class
-	:accessor generic-function-method-class)
-      (method-combination
-	:initarg :method-combination
-	:accessor generic-function-method-combination)
-
-;     (permutation
-;	:accessor gf-permutation)
-      (arg-info
-	:initform ()
-	:accessor gf-arg-info)
-      (dfun-state
-	:initform ()
-	:accessor gf-dfun-state)
-      (effective-method-functions		;((methods . fn) ..)
-	:initform ()
-	:accessor gf-effective-method-functions)
-      (valid-p
-	:initform nil
-	:accessor gf-valid-p)
-      (pretty-arglist
-	:initform ()
-	:accessor gf-pretty-arglist)
-      )
-  (:metaclass funcallable-standard-class)
-  (:default-initargs :method-class *the-class-standard-method*
-		     :method-combination *standard-method-combination*))
-
-
-(define-gf-predicate generic-function-p generic-function)
-
-(define-gf-predicate method-p method)
-
-(define-gf-predicate standard-accessor-method-p standard-accessor-method)
-
-(define-gf-predicate standard-reader-method-p standard-reader-method)
-
-(define-gf-predicate standard-writer-method-p standard-writer-method)
-
-(defvar *the-class-method* (find-class 'method))
-
-(defvar *the-class-standard-method* (find-class 'standard-method))
-
-(defvar *the-class-generic-function* (find-class 'generic-function))
-
-(defvar *the-class-standard-generic-function* (find-class 'standard-generic-function))
-
-(defmethod print-object ((generic-function generic-function)
-                         stream)
-       (named-object-print-function generic-function stream (list (length (generic-function-methods
-                                                                           generic-function)))))
-
-(defmethod shared-initialize :before ((generic-function standard-generic-function)
-                                      slot-names &key (name nil namep)
-                                      (lambda-list nil lambda-list-p)
-                                      argument-precedence-order declarations documentation
-                                      (method-class nil method-class-supplied-p)
-                                      (method-combination nil method-combination-supplied-p))
-       (declare (ignore slot-names declarations argument-precedence-order lambda-list lambda-list-p 
-                       name))
-       (when namep (set-function-name generic-function name))
-       (flet ((initarg-error (initarg value string)
-                     (error "When initializing the generic-function ~S:~%~
-                   The ~S initialization argument was: ~A.~%~
-                   It must be ~A." generic-function initarg value string)))
-             (cond (method-class-supplied-p (when (symbolp method-class)
-                                                (setq method-class (find-class method-class)))
-                          (unless (and (classp method-class)
-                                       (*subtypep method-class *the-class-method*))
-                                 (initarg-error :method-class method-class 
-                                        "a subclass of the class METHOD"))
-                          (setf (slot-value generic-function 'method-class)
-                                method-class))
-                   ((slot-boundp generic-function 'method-class))
-                   (t (initarg-error :method-class "not supplied" "a subclass of the class METHOD")))
-             (cond (method-combination-supplied-p (unless (method-combination-p method-combination)
-                                                         (initarg-error :method-combination 
-                                                                method-combination 
-                                                                "a method combination object")))
-                   ((slot-boundp generic-function 'method-combination))
-                   (t (initarg-error :method-combination "not supplied" "a method combination object"
-                             )))))
-
-(defmethod initialize-instance :after ((gf standard-generic-function)
-                                       &key lambda-list argument-precedence-order)
-       (declare (ignore slot-names))
-       (when lambda-list
-           (setf (gf-arg-info gf)
-                 (new-arg-info-from-generic-function lambda-list argument-precedence-order))))
-
-(defmethod reinitialize-instance ((generic-function standard-generic-function)
-                                  &rest initargs &key name lambda-list argument-precedence-order 
-                                  declarations documentation method-class method-combination)
-       (declare (ignore documentation declarations argument-precedence-order lambda-list name 
-                       method-class method-combination))
-       (macrolet ((add-initarg (check name slot-name)
-                         `(unless ,check
-                              (push (slot-value generic-function ,slot-name)
-                                    initargs)
-                              (push ,name initargs))))
-                                                             ; (add-initarg name :name 'name)
-                                                             ; (add-initarg lambda-list :lambda-list
-                                                             ; 'lambda-list) (add-initarg
-                                                             ; argument-precedence-order
-                                                             ; :argument-precedence-order
-                                                             ; 'argument-precedence-order)
-                                                             ; (add-initarg declarations
-                                                             ; :declarations 'declarations)
-                                                             ; (add-initarg documentation
-                                                             ; :documentation 'documentation)
-                                                             ; (add-initarg method-class
-                                                             ; :method-class 'method-class)
-                                                             ; (add-initarg method-combination
-                                                             ; :method-combination
-                                                             ; 'method-combination) 
-              (apply #'call-next-method generic-function initargs)))
-
-
-;;; These three are scheduled for demolition. 
-
-
-(defmethod remove-named-method (generic-function-name argument-specifiers &optional extra)
-       (let ((generic-function nil)
-             (method nil))
-            (cond ((or (null (fboundp generic-function-name))
-                       (not (generic-function-p (setq generic-function (symbol-function 
-                                                                              generic-function-name))
-                                   )))
-                   (error "~S does not name a generic-function." generic-function-name))
-                  ((null (setq method (get-method generic-function extra (parse-specializers 
-                                                                                argument-specifiers)
-                                             nil)))
-                   (error "There is no method for the generic-function ~S~%~
-                   which matches the argument-specifiers ~S." generic-function argument-specifiers))
-                  (t (remove-method generic-function method)))))
-
-(defun real-add-named-method (generic-function-name qualifiers specializers lambda-list function 
-                                    &rest other-initargs)
-       
-       ;; What about changing the class of the generic-function if there is one.  Whose job is that
-       ;; anyways.  Do we need something kind of like class-for-redefinition? 
-       (let* ((generic-function (ensure-generic-function generic-function-name :lambda-list
-                                       (method-ll->generic-function-ll lambda-list)))
-              (specs (parse-specializers specializers))
-                                                             ; (existing (get-method
-                                                             ; generic-function qualifiers specs
-                                                             ; nil))
-              (proto (method-prototype-for-gf generic-function-name))
-              (new (apply #'make-instance (class-of proto)
-                          :qualifiers qualifiers :specializers specs :lambda-list lambda-list 
-                          :function function other-initargs)))
-                                                             ; (when existing (remove-method
-                                                             ; generic-function existing))
-             (add-method generic-function new)))
-
-(defun make-specializable (function-name &key (arglist nil arglistp))
-       (cond ((not (null arglistp)))
-             ((not (fboundp function-name)))
-             ((fboundp 'function-arglist)
-              
-              ;; function-arglist exists, get the arglist from it.
-              (setq arglist (function-arglist function-name)))
-             (t (error "The :arglist argument to make-specializable was not supplied~%~
-            and there is no version of FUNCTION-ARGLIST defined for this~%~
-            port of Portable CommonLoops.~%~
-            You must either define a version of FUNCTION-ARGLIST (which~%~
-            should be easy), and send it off to the Portable CommonLoops~%~
-            people or you should call make-specializable again with the~%~
-            :arglist keyword to specify the arglist.")))
-       (let ((original (and (fboundp function-name)
-                            (symbol-function function-name)))
-             (generic-function (make-instance 'standard-generic-function :name function-name))
-             (nrequireds 0))
-            (if (generic-function-p original)
-                original
-                (progn (dolist (arg arglist)
-                           (if (memq arg lambda-list-keywords)
-                               (return)
-                               (incf nrequireds)))
-                       (setf (symbol-function function-name)
-                             generic-function)
-                       (set-function-name generic-function function-name)
-                       (when arglistp
-                           (setf (gf-pretty-arglist generic-function)
-                                 arglist))
-                       (when original
-                           (add-named-method function-name nil (make-list nrequireds :initial-element
-                                                                      't)
-                                  arglist original))
-                       generic-function))))
-
-(defun real-get-method (generic-function qualifiers specializers &optional (errorp t))
-       (let ((hit (dolist (method (generic-function-methods generic-function))
-                      (when (and (equal qualifiers (method-qualifiers method))
-                                 (every #'same-specializer-p specializers (method-specializers method
-                                                                                 )))
-                            (return method)))))
-            (cond (hit hit)
-                  ((null errorp)
-                   nil)
-                  (t (error "No method on ~S with qualifiers ~:S and specializers ~:S." 
-                            generic-function qualifiers specializers)))))
-
-
-;;; Compute various information about a generic-function's arglist by looking at the argument lists
-;;; of the methods.  The hair for trying not to use &rest arguments lives here. The values returned
-;;; are: number-of-required-arguments the number of required arguments to this generic-function's
-;;; discriminating function &rest-argument-p whether or not this generic-function's discriminating
-;;; function takes an &rest argument. specialized-argument-positions a list of the positions of the
-;;; arguments this generic-function specializes (e.g. for a classical generic-function this is the
-;;; list: (1)). 
-
-
-(defmethod compute-discriminating-function-arglist-info ((generic-function standard-generic-function)
-                                                         )
-       (declare (values number-of-required-arguments &rest-argument-p specialized-argument-postions))
-       (let ((number-required nil)
-             (restp nil)
-             (specialized-positions nil)
-             (methods (generic-function-methods generic-function)))
-            (dolist (method methods)
-                (multiple-value-setq (number-required restp specialized-positions)
-                       (compute-discriminating-function-arglist-info-internal generic-function method
-                              number-required restp specialized-positions)))
-            (values number-required restp (sort specialized-positions #'<))))
-
-(defun compute-discriminating-function-arglist-info-internal (generic-function method 
-                                                                    number-of-requireds restp 
-                                                                    specialized-argument-positions)
-       (declare (ignore generic-function))
-       (let ((requireds 0))
-            
-            ;; Go through this methods arguments seeing how many are required, and whether there is
-            ;; an &rest argument. 
-            (dolist (arg (method-lambda-list method))
-                (cond ((eq arg '&aux)
-                       (return))
-                      ((memq arg '(&optional &rest &key))
-                       (return (setq restp t)))
-                      ((memq arg lambda-list-keywords))
-                      (t (incf requireds))))
-            
-            ;; Now go through this method's type specifiers to see which argument positions are type
-            ;; specified.  Treat T specially in the usual sort of way.  For efficiency don't bother
-            ;; to keep specialized-argument-positions sorted, rather depend on our caller to do
-            ;; that. 
-            (iterate ((type-spec (list-elements (method-specializers method)))
-                      (pos (interval :from 0)))
-                   (unless (eq type-spec *the-class-t*)
-                          (pushnew pos specialized-argument-positions)))
-            
-            ;; Finally merge the values for this method into the values for the exisiting methods
-            ;; and return them.  Note that if num-of-requireds is NIL it means this is the first
-            ;; method and we depend on that. 
-            (values (min (or number-of-requireds requireds)
-                         requireds)
-                   (or restp (and number-of-requireds (/= number-of-requireds requireds)))
-                   specialized-argument-positions)))
-
-(defun make-discriminating-function-arglist (number-required-arguments restp)
-       (nconc (gathering ((args (collecting)))
-                     (iterate ((i (interval :from 0 :below number-required-arguments)))
-                            (gather (intern (format nil "Discriminating Function Arg ~D" i))
-                                   args)))
-              (when restp
-                  `(&rest ,(intern "Discriminating Function &rest Arg")))))
-
-
-;;; 
-
-
-(defun make-arg-info (precedence metatypes number-optional key/rest-p keywords)
-       (let ((new (make-array 6 :adjustable nil)))
-            (setf (svref new 0)
-                  'arg-info
-                  (svref new 1)
-                  precedence
-                  (svref new 2)
-                  metatypes
-                  (svref new 3)
-                  number-optional
-                  (svref new 4)
-                  key/rest-p
-                  (svref new 5)
-                  keywords)
-                                                             ; nil         no keyword or rest
-                                                             ; allowed (k1 k2 ..)  each method must
-                                                             ; accept these keyword arguments T     
-                                                             ; must have &key or &rest 
-            new))
-
-(defun check-arg-info (x)
-       (or (and (simple-vector-p x)
-                (= (array-dimension x 0)
-                   6)
-                (eq (svref x 0)
-                    'arg-info))
-           (error "~S is not an ARG-INFO." x)))
-
-(defun arg-info-precedence (arg-info)
-       (check-arg-info arg-info)
-       (svref arg-info 1))
-
-(defun arg-info-metatypes (arg-info)
-       (check-arg-info arg-info)
-       (svref arg-info 2))
-
-(defun arg-info-number-optional (arg-info)
-       (check-arg-info arg-info)
-       (svref arg-info 3))
-
-(defun arg-info-key/rest-p (arg-info)
-       (check-arg-info arg-info)
-       (svref arg-info 4))
-
-(defun arg-info-keywords (arg-info)
-       (check-arg-info arg-info)
-       (svref arg-info 5))
-
-(defun arg-info-applyp (arg-info)
-       (check-arg-info arg-info)
-       (or (plusp (arg-info-number-optional arg-info))
-           (arg-info-key/rest-p arg-info)))
-
-(defun arg-info-number-required (arg-info)
-       (check-arg-info arg-info)
-       (length (arg-info-metatypes arg-info)))
-
-(defun arg-info-nkeys (arg-info)
-       (count-if #'(lambda (x)
-                          (neq x 't))
-              (arg-info-metatypes arg-info)))
-
-(defun new-arg-info-from-generic-function (lambda-list argument-precedence-order)
-       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
-           (analyze-lambda-list lambda-list)
-         (declare (ignore allow-other-keys-p))
-         (let ((metatypes (make-list nreq))
-               (precedence (compute-precedence lambda-list nreq argument-precedence-order)))
-              (make-arg-info precedence metatypes nopt (or keysp restp)
-                     keywords))))
-
-(defun new-arg-info-from-method (method)
-       (multiple-value-bind (nreq nopt keysp restp)
-           (analyze-lambda-list (method-lambda-list method))
-         (make-arg-info (compute-precedence (method-lambda-list method)
-                               nreq nil)
-                (mapcar #'raise-metatype (make-list nreq)
-                       (method-specializers method))
-                nopt
-                (or keysp restp)
-                nil)))
-
-(defun add-arg-info (generic-function method arg-info)
-       (flet ((lose (string &rest args)
-                    (error 
-              "Attempt to add the method ~S to the generic function ~S.~%~
-                   But ~A" method generic-function (apply #'format nil string args)))
-              (compare (x y)
-                     (if (> x y)
-                         "more"
-                         "fewer")))
-             (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
-                 (analyze-lambda-list (method-lambda-list method))
-               (let ((gf-nreq (arg-info-number-required arg-info))
-                     (gf-nopt (arg-info-number-optional arg-info))
-                     (gf-key/rest-p (arg-info-key/rest-p arg-info))
-                     (gf-keywords (arg-info-keywords arg-info)))
-                    (unless (= nreq gf-nreq)
-                        (lose "the method has ~A required arguments than the generic function."
-                              (compare nreq gf-nreq)))
-                    (unless (= nopt gf-nopt)
-                        (lose "the method has ~S optional arguments than the generic function."
-                              (compare nopt gf-nopt)))
-                    (unless (eq (or keysp restp)
-                                gf-key/rest-p)
-                           (error "the method and generic function differ in whether they accept~%~
-                  rest or keyword arguments."))
-                    (when gf-keywords
-                        (unless (or (and restp (not keysp))
-                                    allow-other-keys-p
-                                    (every #'(lambda (k)
-                                                    (memq k keywords))
-                                           gf-keywords))
-                               (error "the generic function requires each method to accept the keyword arguments~%~
-               ~S.  The method does not all of accept these." gf-keywords)))
-                    (make-arg-info (arg-info-precedence arg-info)
-                           (mapcar #'raise-metatype (arg-info-metatypes arg-info)
-                                  (method-specializers method))
-                           gf-nopt gf-key/rest-p gf-keywords)))))
-
-(defun remove-arg-info (generic-function method arg-info)
-       (declare (ignore generic-function method))
-       arg-info)
-
-
-;;; 
-
-
-(defun compute-precedence (lambda-list nreq argument-precedence-order)
-       (let ((nreq (analyze-lambda-list lambda-list)))
-            (if (null argument-precedence-order)
-                (let ((c -1))
-                     (gathering1 (collecting)
-                            (dotimes (i nreq)
-                                (gather1 (incf c)))))
-                (mapcar #'(lambda (x)
-                                 (position x lambda-list))
-                       argument-precedence-order))))
-
-(defmethod no-applicable-method (generic-function &rest args)
-       (cerror "Retry call to ~S" 
-         "No matching method for the generic-function ~S,~@
-          when called with arguments ~S." generic-function args)
-       (let ((*invalid-dfuns-on-stack* (remove generic-function *invalid-dfuns-on-stack*)))
-            (invalidate-discriminating-function generic-function)
-            (apply generic-function args)))
-
-(defun real-add-method (generic-function method)
-       (if (method-generic-function method)
-           (error "The method ~S is already part of the generic~@
-              function ~S.  It can't be added to another generic~@
-              function until it is removed from the first one." method (method-generic-function
-                                                                        method))
-           (let* ((qualifiers (method-qualifiers method))
-                  (lambda-list (method-lambda-list method))
-                  (specializers (method-specializers method))
-                  (existing (get-method generic-function qualifiers specializers nil)))
-                 
-                 ;; If there is already a method like this one then we must get rid of it before
-                 ;; proceeding.  Note that we call the generic function remove-method to remove it
-                 ;; rather than doing it in some internal way. 
-                 (when existing (remove-method generic-function existing))
-                 
-                 ;; 
-                 (let ((arg-info (gf-arg-info generic-function)))
-                      (setf (gf-arg-info generic-function)
-                            (if (null arg-info)
-                                (new-arg-info-from-method method)
-                                (add-arg-info generic-function method arg-info)))
-                      (setf (method-generic-function method)
-                            generic-function)
-                      (pushnew method (generic-function-methods generic-function))
-                      (dolist (specializer specializers)
-                          (add-method-on-specializer method specializer))
-                      (invalidate-discriminating-function generic-function)
-                      (maybe-update-constructors generic-function method)
-                      method))))
-
-(defun real-remove-method (generic-function method)
-       (if (neq generic-function (method-generic-function method))
-           (error "The method ~S is attached to the generic function~@
-               ~S.  It can't be removed from the generic function~@
-               to which it is not attached." method (method-generic-function method))
-           (let* ((methods (generic-function-methods generic-function))
-                  (new-methods (remove method methods))
-                  (new-arg-info (remove-arg-info generic-function method (gf-arg-info 
-                                                                                generic-function))))
-                 (setf (method-generic-function method)
-                       nil)
-                 (setf (generic-function-methods generic-function)
-                       new-methods)
-                 (dolist (specializer (method-specializers method))
-                     (remove-method-on-specializer method specializer))
-                 (setf (gf-arg-info generic-function)
-                       new-arg-info)
-                 (invalidate-discriminating-function generic-function)
-                 (maybe-update-constructors generic-function method)
-                 generic-function)))
-
-
-;;; This is it.  You have reached the special place where everything comes together.  This is where
-;;; we ensure that the metacircularity will bottom out properly. Remember once again that the source
-;;; of the problem is that the specified behavior clearly calls for the process of method lookup to
-;;; itself call generic functions.  This implies that for a given generic function in the method
-;;; lookup protocol (compute-applicable-methods for example), we can end up in the unfortunate
-;;; situation of having to call that generic function in order to call it! So, we must arrange to
-;;; snap this infinite regress. The strategy taken here is to identify a particular subset of calls
-;;; to method lookup protocol generic functions and snap the recursion there. This subset of generic
-;;; function calls has the following properties: - Any generic function call in the world will,
-;;; eventually reach one of these generic function calls.  That is we are sure that if we can
-;;; arrange for these calls not to recurse we know we are all set. - These calls themselves don't
-;;; recurse.  We arrange, by magic, for the method lookup and application involved in these calls
-;;; not to call any other generic functions. 
-
-
-(defvar *magic-generic-functions* '((compute-discriminating-function ((standard-generic-function)
-                                                                      (standard-generic-function)))
-                                    (compute-applicable-methods ((standard-generic-function t)
-                                                                 (generic-function t)))
-                                    (compute-applicable-methods-using-classes ((
-                                                                            standard-generic-function
-                                                                                t)
-                                                                               (generic-function
-                                                                                t)))
-                                                             ; (same-specializer-p      
-                                                             ; ((standard-class standard-class) (t
-                                                             ; t))) (specializer-applicable-p
-                                                             ; ((standard-class t) (class t))) 
-                                    (specializer-applicable-using-class-p ((standard-class t)
-                                                                           (class t))
-                                           ((built-in-class t)
-                                            (class t)))
-                                    (order-specializers-using-class ((standard-class standard-class t
-                                                                            )
-                                                                     (class class t)))
-                                    (compute-effective-method ((standard-generic-function
-                                                                (eql *standard-method-combination*)
-                                                                t)
-                                                               (generic-function 
-                                                                      standard-method-combination t))
-                                           )
-                                    (method-p ((standard-method)
-                                               (method))
-                                           ((standard-reader-method)
-                                            (method))
-                                           ((standard-writer-method)
-                                            (method)))
-                                    (standard-accessor-method-p ((standard-method)
-                                                                 (t))
-                                           ((standard-reader-method)
-                                            (standard-accessor-method))
-                                           ((standard-writer-method)
-                                            (standard-accessor-method)))
-                                    (standard-reader-method-p ((standard-method)
-                                                               (t))
-                                           ((standard-reader-method)
-                                            (standard-reader-method))
-                                           ((standard-writer-method)
-                                            (t)))
-                                    (standard-writer-method-p ((standard-method)
-                                                               (t))
-                                           ((standard-reader-method)
-                                            (t))
-                                           ((standard-writer-method)
-                                            (standard-writer-method)))
-                                    (method-qualifiers ((standard-method)
-                                                        (standard-method))
-                                           ((standard-reader-method)
-                                            (standard-method)))
-                                    (method-specializers ((standard-method)
-                                                          (standard-method))
-                                           ((standard-reader-method)
-                                            (standard-method)))
-                                    (method-lambda-list ((standard-method)
-                                                         (standard-method))
-                                           ((standard-reader-method)
-                                            (standard-method)))
-                                    (method-function ((standard-method)
-                                                      (standard-method))
-                                           ((standard-reader-method)
-                                            (standard-method)))
-                                    (accessor-method-slot-name ((standard-reader-method)
-                                                                (standard-accessor-method))
-                                           ((standard-writer-method)
-                                            (standard-accessor-method)))
-                                    (classp ((standard-class)
-                                             (class))
-                                           ((built-in-class)
-                                            (class)))
-                                    (class-precedence-list ((standard-class)
-                                                            (clos-class)))
-                                    (class-finalized-p ((standard-class)
-                                                        (clos-class)))
-                                    (generic-function-methods ((standard-generic-function)
-                                                               (standard-generic-function)))
-                                    (generic-function-method-combination ((standard-generic-function)
-                                                                          (standard-generic-function)
-                                                                          ))
-                                    (gf-arg-info ((standard-generic-function)
-                                                  (standard-generic-function)))
-                                    (gf-dfun-state ((standard-generic-function)
-                                                    (standard-generic-function)))
-                                    (gf-effective-method-functions ((standard-generic-function)
-                                                                    (standard-generic-function)))
-                                    ((setf gf-effective-method-functions)
-                                     ((t standard-generic-function)
-                                      (t standard-generic-function)))
-                                                             ; (gf-permutation                      
-                                                             ; ((standard-generic-function)
-                                                             ; (standard-generic-function))) 
-                                    (slot-value-using-class ((standard-class t 
-                                                                   standard-effective-slot-definition
-                                                                    )
-                                                             ; the first t is a bug
-                                                             (std-class standard-object 
-                                                                   standard-effective-slot-definition
-                                                                    ))
-                                           ((funcallable-standard-class t 
-                                                   standard-effective-slot-definition)
-                                            (std-class standard-object 
-                                                   standard-effective-slot-definition)))
-                                    ((setf slot-value-using-class)
-                                     ((t standard-class t standard-effective-slot-definition)
-                                      (t std-class standard-object standard-effective-slot-definition
-                                         ))
-                                     ((t funcallable-standard-class t 
-                                         standard-effective-slot-definition)
-                                      (t std-class standard-object standard-effective-slot-definition
-                                         )))))
-
-(defvar *magic-generic-functions-1* nil)
-
-(defun
- fixup-magic-generic-function
- (gfspec early-methods gf methods)
- (flet
-  ((get-specls (names convert-t-p)
-          (mapcar #'(lambda (s)
-                           (cond ((consp s)
-                                  `(eql ,(eval (cadr s))))
-                                 ((eq s t)
-                                  (if convert-t-p
-                                      (find-class t)
-                                      t))
-                                 (t (find-class s))))
-                 names)))
-  (let
-   ((e (assoc gfspec *magic-generic-functions* :test #'equal)))
-   (when e
-       (push (list* gf (make-arg-info
-                        nil
-                        (apply #'mapcar #'(lambda (&rest args)
-                                                 (if (every #'(lambda (arg)
-                                                                     (eq arg 't))
-                                                            args)
-                                                     't
-                                                     'standard-instance))
-                               (mapcar #'second (cdr e)))
-                        nil nil nil)
-                    (gathering1 (collecting)
-                           (dolist (pair (cdr e))
-                               (iterate ((em (list-elements early-methods))
-                                         (m (list-elements methods)))
-                                      (when (equal (early-method-specializers em t)
-                                                   (get-specls (cadr pair)
-                                                          t))
-                                          (gather1 (list (get-specls (car pair)
-                                                                nil)
-                                                         (list m)
-                                                         (early-method-function em)))
-                                          (return t))))))
-             *magic-generic-functions-1*)))))
-
-(defun get-secondary-dispatch-function (generic-function args)
-       (declare (values compiled-secondary-dispatch-function methods arg-info))
-       (multiple-value-bind (fn methods arg-info)
-           (get-magic-secondary-dispatch-function generic-function args)
-         (if fn
-             (values fn methods arg-info)
-             (get-normal-secondary-dispatch-function generic-function args))))
-
-(defun get-magic-secondary-dispatch-function (generic-function args)
-       (let ((e (assq generic-function *magic-generic-functions-1*)))
-            (when e
-                (dolist (entry (cddr e))
-                    (destructuring-bind (specls appl function)
-                           entry
-                           (unless (iterate ((arg (list-elements args))
-                                             (specl (list-elements specls)))
-                                          (let ((class (class-of arg)))
-                                               (unless (if (consp specl)
-                                                           (eql (cadr specl)
-                                                                arg)
-                                                           (or (eq specl t)
-                                                               (eq specl class)))
-                                                      (return t))))
-                               (return (values function appl (cadr e)))))))))
-
-(defmacro protect-cache-miss-code (gf args &body body)
-       (let ((wrappers (gensym))
-             (invalidp (gensym))
-             #'(gensym)
-             (appl (gensym)))
-            (once-only (gf args)
-                   `(if (memq ,gf *invalid-dfuns-on-stack*)
-                        (multiple-value-bind (,wrappers ,invalidp ,function ,appl)
-                            (cache-miss-values ,gf ,args)
-                          (declare (ignore ,wrappers ,invalidp))
-                          (if (null ,appl)
-                              (apply #'no-applicable-method ,gf ,args)
-                              (apply ,function ,args)))
-                        (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*)))
-                             ,@body)))))
-
-(defmethod same-specializer-p (specl1 specl2)
-       (eq specl1 specl2))
-
-(defmethod specializer-applicable-p ((specializer class)
-                                     object)
-       (memq specializer (class-precedence-list (class-of object))))
-
-(defmethod specializer-applicable-using-class-p ((specializer class)
-                                                 class)
-       (*subtypep class specializer))
-
-(defmethod order-specializers-using-class ((specl1 class)
-                                           (specl2 class)
-                                           class)
-       (cond ((eq specl1 specl2)
-              nil)
-             ((memq specl2 (memq specl1 (class-precedence-list class)))
-              specl1)
-             (t specl2)))
-
-(defmethod compute-applicable-methods ((generic-function generic-function)
-                                       arguments)
-       (labels ((filter (method)
-                       (let ((arguments-tail arguments))
-                            (dolist (m-spec (method-specializers method)
-                                           t)
-                                (unless arguments-tail
-                                    (error "The function ~S requires at least ~D arguments"
-                                           (generic-function-name generic-function)
-                                           (arg-info-number-required (gf-arg-info generic-function))))
-                                (unless (specializer-applicable-p m-spec (pop arguments-tail))
-                                       (return nil)))))
-                (sorter (method-1 method-2)
-                       (dolist (index (arg-info-precedence (gf-arg-info generic-function)))
-                           (let* ((specl1 (nth index (method-specializers method-1)))
-                                  (specl2 (nth index (method-specializers method-2)))
-                                  (class (class-of (nth index arguments)))
-                                  (order (order-specializers-using-class specl1 specl2 class)))
-                                 (when order
-                                     (return-from sorter (eq order specl1)))))))
-              (let ((methods (generic-function-methods generic-function)))
-                   (stable-sort (copy-list (remove-if-not #'filter methods))
-                          #'sorter))))
-
-(defmethod compute-applicable-methods-using-classes ((generic-function generic-function)
-                                                     classes)
-       (labels ((filter (method)
-                       (let ((classes-tail classes))
-                            (dolist (m-spec (method-specializers method)
-                                           t)
-                                (unless classes-tail
-                                    (error "The function ~S requires at least ~D arguments"
-                                           (generic-function-name generic-function)
-                                           (arg-info-number-required (gf-arg-info generic-function))))
-                                (unless (specializer-applicable-using-class-p m-spec (pop 
-                                                                                         classes-tail
-                                                                                          ))
-                                       (return nil)))))
-                (sorter (method-1 method-2)
-                       (dolist (index (arg-info-precedence (gf-arg-info generic-function)))
-                           (let* ((specl1 (nth index (method-specializers method-1)))
-                                  (specl2 (nth index (method-specializers method-2)))
-                                  (class (nth index classes))
-                                  (order (order-specializers-using-class specl1 specl2 class)))
-                                 (when order
-                                     (return-from sorter (eq order specl1)))))))
-              (let ((methods (generic-function-methods generic-function)))
-                   (stable-sort (copy-list (remove-if-not #'filter methods))
-                          #'sorter))))
-
-(defun get-normal-secondary-dispatch-function (generic-function args)
-       (let* ((classes (mapcar #'(lambda (arg mt)
-                                        (declare (ignore mt))
-                                        (class-of arg))
-                              args
-                              (arg-info-metatypes (gf-arg-info generic-function))))
-              (methods (compute-applicable-methods-using-classes generic-function classes))
-              (net (generate-discrimination-net generic-function methods))
-              (arg-info (gf-arg-info generic-function))
-              (metatypes (arg-info-metatypes arg-info))
-              (applyp (arg-info-applyp arg-info)))
-             (flet ((net-test-converter (form)
-                           (if (and (consp form)
-                                    (eq (car form)
-                                        'methods))
-                               '.methods.
-                               (default-test-converter form)))
-                    (net-code-converter (form)
-                           (if (and (consp form)
-                                    (eq (car form)
-                                        'methods))
-                               (let ((gensym (gensym)))
-                                    (values (make-dfun-call metatypes applyp gensym)
-                                           (list gensym)))
-                               (default-code-converter form)))
-                    (net-constant-converter (form)
-                           (if (and (consp form)
-                                    (eq (car form)
-                                        'methods))
-                               (list (get-effective-method-function generic-function (cdr form)))
-                               (default-constant-converter form))))
-                   (if (eq (car net)
-                           'methods)
-                       (and (cdr net)
-                            (values (get-effective-method-function generic-function (cdr net))
-                                   methods))
-                       (values (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
-                                                     ,net)
-                                      #'net-test-converter
-                                      #'net-code-converter
-                                      #'net-constant-converter)
-                              methods)))))
-
-(defun get-effective-method-function (generic-function methods)
-       (let ((combin (generic-function-method-combination generic-function))
-             (precomputed (gf-effective-method-functions generic-function)))
-            
-            ;; NOTE: We are assuming a restriction on user code that the method combination must not
-            ;; change once it is connected to the generic function. This has to be legal, because
-            ;; otherwise any kind of method lookup caching couldn't work.  See this by saying that
-            ;; this cache, is just a backing cache for the fast cache.  If that cache is legal, this
-            ;; one must be too. Should altering the set of methods flush this cache? 
-            (let ((entry (assoc methods precomputed :test #'equal)))
-                 (if entry
-                     (values (cdr entry)
-                            (car entry))
-                     (let* ((effective (compute-effective-method generic-function combin methods))
-                            (fn (make-effective-method-function generic-function effective)))
-                           (setf (gf-effective-method-functions generic-function)
-                                 (cons (cons methods fn)
-                                       precomputed))
-                           (values fn methods))))))
-
-(defun
- generate-discrimination-net
- (generic-function methods)
- (let* ((arg-info (gf-arg-info generic-function))
-        (nreq (arg-info-number-required arg-info))
-        (metatypes (arg-info-metatypes arg-info)))
-       (labels ((do-column (position contenders)
-                       (if (< position nreq)
-                           (if (eq (nth position metatypes)
-                                   't)
-                               (do-column (1+ position)
-                                      contenders)
-                               (do-methods position contenders nil nil))
-                           `(methods ,@contenders)))
-                (do-methods
-                 (position contenders known-outcomes winners)
-                 
-                 ;; <contenders> is a (sorted) list of methods that must be discriminated
-                 ;; <known-outcomes> is a list of outcomes from tests already made on this argument
-                 ;; each outcome looks like (<specializer> [t | nil]) <winners> is a (sorted) list
-                 ;; of methods that are potentially applicable after the discrimination has been
-                 ;; made. 
-                 (if (null contenders)
-                     (do-column (1+ position)
-                            winners)
-                     (let* ((method (car contenders))
-                            (specl (nth position (method-specializers method))))
-                           (flet ((determined-to-be (truth-value)
-                                         (if (classp specl)
-                                             truth-value
-                                             (some #'(lambda (outcome)
-                                                            (outcome-implies-p generic-function
-                                                                   (car outcome)
-                                                                   (cadr outcome)
-                                                                   specl truth-value))
-                                                   known-outcomes)))
-                                  (if-true nil (do-methods position (cdr contenders)
-                                                      (if (not (classp specl))
-                                                          (cons `(,specl t)
-                                                                known-outcomes)
-                                                          known-outcomes)
-                                                      (append winners `(,method))))
-                                  (if-false nil (do-methods position (cdr contenders)
-                                                       (if (not (classp specl))
-                                                           (cons `(,specl nil)
-                                                                 known-outcomes)
-                                                           known-outcomes)
-                                                       winners)))
-                                 (cond ((determined-to-be nil)
-                                        (if-false))
-                                       ((determined-to-be t)
-                                        (if-true))
-                                       (t `(if ,(compute-argument-test-form generic-function
-                                                       (dfun-arg-symbol position)
-                                                       specl)
-                                               ,(if-true)
-                                               ,(if-false)))))))))
-              (do-column 0 methods))))
-
-(define-gf-predicate eql-specializer-p eql-specializer)
-
-(defmethod same-specializer-p ((specl1 eql-specializer)
-                               (specl2 eql-specializer))
-       (eql (eql-specializer-object specl1)
-            (eql-specializer-object specl2)))
-
-(defmethod specializer-applicable-p ((specializer eql-specializer)
-                                     object)
-       (eql (eql-specializer-object specializer)
-            object))
-
-(defmethod specializer-applicable-using-class-p ((specializer eql-specializer)
-                                                 class)
-       (eq class (class-of (eql-specializer-object specializer))))
-
-                                                             ; It would be most egregious to use
-                                                             ; *subtypep here. 
-
-
-(defmethod order-specializers-using-class ((specl1 eql-specializer)
-                                           (specl2 eql-specializer)
-                                           argument-class)
-       (declare (ignore argument-class))
-       nil)
-
-(defmethod order-specializers-using-class ((specl1 class)
-                                           (specl2 eql-specializer)
-                                           argument-class)
-       (declare (ignore argument-class))
-       specl2)
-
-(defmethod order-specializers-using-class ((specl1 eql-specializer)
-                                           (specl2 class)
-                                           argument-class)
-       (declare (ignore argument-class))
-       specl1)
-
-
-;;; Does a given pair of values for {<specializer1> <truth1>} imply a given pair of values for
-;;; {<specializer2> <truth2>}. 
-
-
-(defmethod outcome-implies-p ((generic-function generic-function)
-                              (specl1 eql-specializer)
-                              value1
-                              (specl2 eql-specializer)
-                              value2)
-       (flet ((same-truth-value (x y)
-                     (or (and x y)
-                         (and (not x)
-                              (not y)))))
-             (let ((obj1 (eql-specializer-object specl1))
-                   (obj2 (eql-specializer-object specl2)))
-                  (or (and (eql obj1 obj2)
-                           (same-truth-value value1 value2))
-                      (and (not (eql obj1 obj2))
-                           value1
-                           (not value2))))))
-
-
-;;; Return a form which tests a given argument against a given specializer. 
-
-
-(defmethod compute-argument-test-form ((generic-function generic-function)
-                                       argument-form
-                                       (specializer eql-specializer))
-       `(eql ,argument-form ',(eql-specializer-object specializer)))
-
-
-;;; The value returned by compute-discriminating-function is a function object.  It is called a
-;;; discriminating function because it is called when the generic function is called and its role is
-;;; to discriminate on the arguments to the generic function and then call appropriate method
-;;; functions. A discriminating function can only be called when it is installed as the funcallable
-;;; instance function of the generic function for which it was computed. More precisely, if
-;;; compute-discriminating-function is called with an argument <gf1>, and returns a result <df1>,
-;;; that result must not be passed to apply or funcall directly.  Rather, <df1> must be stored as
-;;; the funcallable instance function of the same generic function <gf1> (using
-;;; set-funcallable-instance-function).  Then the generic function can be passed to funcall or
-;;; apply. An important exception is that methods on this generic function are permitted to return a
-;;; function which itself ends up calling the value returned by a more specific method.  This kind
-;;; of `encapsulation' of discriminating function is critical to many uses of the MOP. As an
-;;; example, the following canonical case is legal: (defmethod compute-discriminating-function ((gf
-;;; my-generic-function)) (let ((std (call-next-method))) #'(lambda (arg) (print (list 'call-to-gf
-;;; gf arg)) (funcall std arg)))) Because many discriminating functions would like to use a dynamic
-;;; strategy in which the precise discriminating function changes with time it is important to
-;;; specify how a discriminating function is permitted itself to change the funcallable instance
-;;; function of the generic function. Discriminating functions are may set the funcallable instance
-;;; function of the generic function, but the new value must be generated by making a call to
-;;; COMPUTE-DISCRIMINATING-FUNCTION.  This is to ensure that any more specific methods which may
-;;; have encapsulated the discriminating function will get a chance to encapsulate the new, inner
-;;; discriminating function. This implies that if a discriminating function wants to modify itself
-;;; it should first store some information in the generic function proper, and then call
-;;; compute-discriminating-function.  The appropriate method on compute-discriminating-function will
-;;; see the information stored in the generic function and generate a discriminating function
-;;; accordingly. The following is an example of a discriminating function which modifies itself in
-;;; accordance with this protocol: (defmethod compute-discriminating-function ((gf
-;;; my-generic-function)) #'(lambda (arg) (cond (<some condition> <store some info in the generic
-;;; function> (set-funcallable-instance-function gf (compute-discriminating-function gf)) (funcall
-;;; gf arg)) (t <call-a-method-of-gf>)))) Whereas this code would not be legal: (defmethod
-;;; compute-discriminating-function ((gf my-generic-function)) #'(lambda (arg) (cond (<some
-;;; condition> (set-funcallable-instance-function gf #'(lambda (a) ..)) (funcall gf arg)) (t
-;;; <call-a-method-of-gf>)))) NOTE:  All the examples above assume that all instances of the class
-;;; my generic function accept only one argument. 
-
-
-(defmethod compute-discriminating-function ((gf standard-generic-function))
-       (let* ((state (gf-dfun-state gf))
-              (dfun (typecase state
-                        (null (make-initial-dfun gf))
-                        (function state)
-                        (cons (car state)))))
-             (doctor-dfun-for-the-debugger gf dfun)))
-
-(defun update-dfun (generic-function dfun &optional cache)
-       (let ((ostate (gf-dfun-state generic-function)))
-            (unless (typep ostate '(or null function))
-                (free-cache (cdr ostate)))
-            (setf (gf-dfun-state generic-function)
-                  (if cache
-                      (cons dfun cache)
-                      dfun))
-            (invalidate-dfun-internal generic-function)))
-
-(defvar *generate-random-code-segments* nil)
-
-(defun invalidate-discriminating-function (generic-function)
-       (let ((ostate (gf-dfun-state generic-function)))
-            (unless (typep ostate '(or null function))
-                (free-cache (cdr ostate)))
-            (setf (gf-dfun-state generic-function)
-                  nil)
-            (setf (gf-effective-method-functions generic-function)
-                  nil)
-            (invalidate-dfun-internal generic-function)
-            (when *generate-random-code-segments*
-                (let ((*generate-random-code-segments* nil))
-                     (generate-random-code-segments generic-function)))))
-
-(defun invalidate-dfun-internal (generic-function)
-       
-       ;; Set the funcallable instance function to something that just calls invalid-dfun, that is,
-       ;; arrange to use lazy evaluation to update the dfun later. 
-       (set-funcallable-instance-function generic-function #'(lambda (&rest args)
-                                                                    (invalid-dfun generic-function 
-                                                                           args)))
-       
-       ;; Except that during bootstrapping, we would like to update the dfun right away, and this
-       ;; arranges for that. 
-       (when *invalidate-discriminating-function-force-p*
-           (let ((*invalid-dfuns-on-stack* (cons generic-function *invalid-dfuns-on-stack*)))
-                (set-funcallable-instance-function generic-function (compute-discriminating-function
-                                                                     generic-function)))))
-
-(defun invalid-dfun (gf args)
-       (protect-cache-miss-code gf args (let ((new-dfun (compute-discriminating-function gf)))
-                                             (set-funcallable-instance-function gf new-dfun)
-                                             (apply gf args))))
-
-
-;;; 
-
-
-(defmethod function-keywords ((method standard-method))
-       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
-           (analyze-lambda-list (method-lambda-list method))
-         (declare (ignore nreq nopt keysp restp))
-         (values keywords allow-other-keys-p)))
-
-(defun analyze-lambda-list (lambda-list)
-       (declare (values nrequired noptional keysp restp allow-other-keys-p keywords 
-                       keyword-parameters))
-       (flet ((parse-keyword-argument (arg)
-                     (if (listp arg)
-                         (if (listp (car arg))
-                             (cadar arg)
-                             (make-keyword (car arg)))
-                         (make-keyword arg))))
-             (let ((nrequired 0)
-                   (noptional 0)
-                   (keysp nil)
-                   (restp nil)
-                   (allow-other-keys-p nil)
-                   (keywords nil)
-                   (keyword-parameters nil)
-                   (state 'required))
-                  (dolist (x lambda-list)
-                      (if (memq x lambda-list-keywords)
-                          (case x
-                              (&optional (setq state 'optional))
-                              (&key (setq keysp 't state 'key))
-                              (&allow-other-keys (setq allow-other-keys-p 't))
-                              (&rest (setq restp 't state 'rest))
-                              (&aux (return t))
-                              (otherwise (error 
-                                               "Encountered the non-standard lambda list keyword ~S."
-                                                x)))
-                          (ecase state
-                              (required (incf nrequired))
-                              (optional (incf noptional))
-                              (key 
-                                 (push (parse-keyword-argument x)
-                                       keywords)
-                                 (push x keyword-parameters))
-                              (rest nil))))
-                  (values nrequired noptional keysp restp allow-other-keys-p (reverse keywords)
-                         (reverse keyword-parameters)))))
-
-(defun method-ll->generic-function-ll (ll)
-       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)
-           (analyze-lambda-list ll)
-         (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords))
-         (remove-if #'(lambda (s)
-                             (or (memq s keyword-parameters)
-                                 (eq s '&allow-other-keys)))
-                ll)))
-
-
-;;; This is based on the rules of method lambda list congruency defined in the spec.  The lambda
-;;; list it constructs is the pretty union of the lambda lists of all the methods.  It doesn't take
-;;; method applicability into account at all yet. 
-
-
-(defmethod generic-function-pretty-arglist ((generic-function standard-generic-function))
-       (let ((methods (generic-function-methods generic-function))
-             (arglist nil))
-            (when methods
-                (multiple-value-bind (required optional rest key allow-other-keys)
-                    (method-pretty-arglist (car methods))
-                  (dolist (m (cdr methods))
-                      (multiple-value-bind (method-key-keywords method-allow-other-keys method-key)
-                          (function-keywords m)
-                        
-                        ;; we've modified function-keywords to return what we want as the third
-                        ;; value, no other change here. 
-                        (declare (ignore method-key-keywords))
-                        (setq key (union key method-key))
-                        (setq allow-other-keys (or allow-other-keys method-allow-other-keys))))
-                  (when allow-other-keys
-                      (setq arglist '(&allow-other-keys)))
-                  (when key
-                      (setq arglist (nconc (list '&key)
-                                           key arglist)))
-                  (when rest
-                      (setq arglist (nconc (list '&rest rest)
-                                           arglist)))
-                  (when optional
-                      (setq arglist (nconc (list '&optional)
-                                           optional arglist)))
-                  (nconc required arglist)))))
-
-(defmethod method-pretty-arglist ((method standard-method))
-       (let ((required nil)
-             (optional nil)
-             (rest nil)
-             (key nil)
-             (allow-other-keys nil)
-             (state 'required)
-             (arglist (method-lambda-list method)))
-            (dolist (arg arglist)
-                (cond ((eq arg '&optional)
-                       (setq state 'optional))
-                      ((eq arg '&rest)
-                       (setq state 'rest))
-                      ((eq arg '&key)
-                       (setq state 'key))
-                      ((eq arg '&allow-other-keys)
-                       (setq allow-other-keys 't))
-                      ((memq arg lambda-list-keywords))
-                      (t (ecase state
-                             (required (push arg required))
-                             (optional (push arg optional))
-                             (key (push arg key))
-                             (rest (setq rest arg))))))
-            (values (nreverse required)
-                   (nreverse optional)
-                   rest
-                   (nreverse key)
-                   allow-other-keys)))
diff --git a/obsolete/clos/2.0/patch.lisp b/obsolete/clos/2.0/patch.lisp
deleted file mode 100644
index eab79094..00000000
--- a/obsolete/clos/2.0/patch.lisp
+++ /dev/null
@@ -1,143 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CLIN-PACKAGE "XCL-USER") BASE 10)
-(IL:FILECREATED "19-Feb-91 14:09:19" 
-IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;2| 9876   
-
-      IL:|changes| IL:|to:|  (IL:VARS IL:XEROX-PATCHESCOMS)
-
-      IL:|previous| IL:|date:| " 6-Feb-91 10:55:16" 
-IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;1|)
-
-
-; Copyright (c) 1991 by Venue.  All rights reserved.
-
-(IL:PRETTYCOMPRINT IL:XEROX-PATCHESCOMS)
-
-(IL:RPAQQ IL:XEROX-PATCHESCOMS (
-
-
-                                    (IL:FUNCTIONS OPTIMIZE-LOGICAL-OP-1-ARG)
-                                    (OPTIMIZERS (LOGIOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
-                                           (LOGXOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
-                                           (LOGAND :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
-                                           (LOGEQV :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG))
-                                    
-                                    (IL:* IL:|;;| "A bug compiling LABELS")
-
-                                    (IL:FUNCTIONS COMPILER::META-CALL-LABELS)
-                                    (FILE-ENVIRONMENTS "XEROX-PATCHES")))
-
-
-
-
-
-
-(IL:* IL:|;;;| 
-"Declare side-effects (actually, lack of side-effects) info for some internal arithmetic functions.  These are needed because the compiler runs the optimizers before checking the side-effects, so side-effect declarations on the \"real\" functions are oft times ignored. Fix a nit in the compiler While no person would generate code like (logor x), macro can (and do). "
-)
-
-
-(DEFUN OPTIMIZE-LOGICAL-OP-1-ARG (FORM ENV CTXT)
-   (DECLARE (IGNORE ENV CTXT))
-   (IF (= 2 (LENGTH FORM))
-       (SECOND FORM)
-       'COMPILER:PASS))
-
-(DEFOPTIMIZER LOGIOR OPTIMIZE-LOGICAL-OP-1-ARG)
-
-(DEFOPTIMIZER LOGXOR OPTIMIZE-LOGICAL-OP-1-ARG)
-
-(DEFOPTIMIZER LOGAND OPTIMIZE-LOGICAL-OP-1-ARG)
-
-(DEFOPTIMIZER LOGEQV OPTIMIZE-LOGICAL-OP-1-ARG)
-
-
-
-(IL:* IL:|;;| "A bug compiling LABELS")
-
-
-(DEFUN COMPILER::META-CALL-LABELS (COMPILER::NODE COMPILER:CONTEXT)
-
-   (IL:* IL:|;;| "This is similar to META-CALL-LAMBDA, but we have some extra information. There are only required arguments, and we have the correct number of them. ")
-
-   (LET ((COMPILER::*MADE-CHANGES* NIL))
-
-        (IL:* IL:|;;| "First, substitute the functions wherever possible.")
-
-        (DOLIST (COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)
-                       (WHEN (NULL (COMPILER::NODE-META-P (COMPILER::LABELS-BODY COMPILER::NODE)))
-                           (SETF (COMPILER::NODE-META-P COMPILER::NODE)
-                                 NIL)
-                           (SETQ COMPILER::*MADE-CHANGES* T)))
-            (WHEN (COMPILER::SUBSTITUTABLE-P (CDR COMPILER::FN-PAIR)
-                         (CAR COMPILER::FN-PAIR))
-                (LET ((COMPILER::*SUBST-OCCURRED* NIL))
-
-                     (IL:* IL:|;;| "First try substituting into the body.")
-
-                     (SETF (COMPILER::LABELS-BODY COMPILER::NODE)
-                           (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR)
-                                  (CAR COMPILER::FN-PAIR)
-                                  (COMPILER::LABELS-BODY COMPILER::NODE)))
-                     (WHEN (NOT COMPILER::*SUBST-OCCURRED*)
-
-                         (IL:* IL:|;;| "Wasn't in the body - try the other functions.")
-
-                         (DOLIST (COMPILER::TARGET-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE))
-                             (UNLESS (EQ COMPILER::TARGET-PAIR COMPILER::FN-PAIR)
-                                 (SETF (CDR COMPILER::TARGET-PAIR)
-                                       (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR)
-                                              (CAR COMPILER::FN-PAIR)
-                                              (CDR COMPILER::TARGET-PAIR)))
-                                 (WHEN COMPILER::*SUBST-OCCURRED*
-                                                             (IL:* IL:\; 
-                                                           "Found it, we can stop now.")
-                                     (SETF (COMPILER::NODE-META-P COMPILER::NODE)
-                                           NIL)
-                                     (SETQ COMPILER::*MADE-CHANGES* T)
-                                     (RETURN)))))
-
-                     (IL:* IL:|;;| "May need to reanalyze the node, since things might have changed. Note that reanalyzing the parts of the node this way means the the state in the enclosing loop is not lost. ")
-
-                     (DOLIST (COMPILER::FNS (COMPILER::LABELS-FUNS COMPILER::NODE))
-                         (COMPILER::MEVAL (CDR COMPILER::FNS)
-                                :ARGUMENT))
-                     (COMPILER::MEVAL (COMPILER::LABELS-BODY COMPILER::NODE)
-                            :RETURN))))
-
-        (IL:* IL:|;;| "Now remove any functions that aren't referenced.")
-
-        (DOLIST (COMPILER::FN-PAIR (PROG1 (COMPILER::LABELS-FUNS COMPILER::NODE)
-                                       (SETF (COMPILER::LABELS-FUNS COMPILER::NODE)
-                                             NIL)))
-            (COND
-               ((NULL (COMPILER::VARIABLE-READ-REFS (CAR COMPILER::FN-PAIR)))
-                (COMPILER::RELEASE-TREE (CDR COMPILER::FN-PAIR))
-                (SETQ COMPILER::*MADE-CHANGES* T))
-               (T (PUSH COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)))))
-
-        (IL:* IL:|;;| "If there aren't any functions left, replace the node with its body.")
-
-        (WHEN (NULL (COMPILER::LABELS-FUNS COMPILER::NODE))
-            (LET ((COMPILER::BODY (COMPILER::LABELS-BODY COMPILER::NODE)))
-                 (SETF (COMPILER::LABELS-BODY COMPILER::NODE)
-                       NIL)
-                 (COMPILER::RELEASE-TREE COMPILER::NODE)
-                 (SETQ COMPILER::NODE COMPILER::BODY COMPILER::*MADE-CHANGES* T)))
-
-        (IL:* IL:|;;| "Finally, set the meta-p flag if everythings OK.")
-
-        (IF (NULL COMPILER::*MADE-CHANGES*)
-            (SETF (COMPILER::NODE-META-P COMPILER::NODE)
-                  COMPILER:CONTEXT)
-            (SETF (COMPILER::NODE-META-P COMPILER::NODE)
-                  NIL)))
-   COMPILER::NODE)
-
-(DEFINE-FILE-ENVIRONMENT "XEROX-PATCHES" :PACKAGE (IN-PACKAGE "XCL-USER")
-   :READTABLE "XCL"
-   :BASE 10
-   :COMPILER :COMPILE-FILE)
-(IL:PUTPROPS IL:XEROX-PATCHES IL:COPYRIGHT ("Venue" 1991))
-(IL:DECLARE\: IL:DONTCOPY
-  (IL:FILEMAP (NIL)))
-IL:STOP
diff --git a/obsolete/clos/2.0/pkg.lisp b/obsolete/clos/2.0/pkg.lisp
deleted file mode 100644
index 7491df0d..00000000
--- a/obsolete/clos/2.0/pkg.lisp
+++ /dev/null
@@ -1,81 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;; File converted on 26-Mar-91 10:23:29 from source pkg
-;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>pkg.;4 created  1-Mar-91 10:10:26
-
-;;;. Copyright (c) 1991 by Venue
-
-
-(in-package "CLOS")
-
-
-
-;;; Some CommonLisps have more symbols in the Lisp package than the ones that are explicitly
-;;; specified in CLtL.  This causes trouble. Any Lisp that has extra symbols in the Lisp package
-;;; should shadow those symbols in the CLOS package. 
-
-
-(shadow 'cl:documentation)
-
-
-;;; These come from the index pages of 88-002R. 
-
-(eval-when (compile load eval)
-(defvar *exports*
-       '(add-method built-in-class call-method call-next-method change-class class-name class-of 
-               compute-applicable-methods defclass defgeneric define-method-combination defmethod 
-               ensure-generic-function find-class find-method function-keywords generic-flet 
-               generic-labels initialize-instance invalid-method-error make-instance 
-               make-instances-obsolete method-combination-error method-qualifiers next-method-p 
-               no-applicable-method no-next-method print-object reinitialize-instance remove-method 
-               shared-initialize slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound
-               slot-value standard standard-class standard-generic-function standard-method 
-               standard-object structure-class symbol-macrolet update-instance-for-different-class 
-               update-instance-for-redefined-class with-accessors with-added-methods with-slots))
-
-(import '(xcl:false xcl:destructuring-bind xcl:true) *the-clos-package*)
-
-(export *exports* *the-clos-package*)
-
-(import *exports* (find-package :lisp))
-
-(export *exports* (find-package :lisp)))
-
-                                                             ; (defvar *chapter-3-exports* '(
-                                                             ; get-setf-function
-                                                             ; get-setf-function-name
-                                                             ; class-prototype class object 
-
-
-
-;; essential-class
-
-
-                                                             ; class-name class-precedence-list
-                                                             ; class-local-supers class-local-slots
-                                                             ; class-direct-subclasses
-                                                             ; class-direct-methods class-slots
-                                                             ; method-arglist
-                                                             ; method-argument-specifiers
-                                                             ; method-function method-equal
-                                                             ; slotd-name slot-missing 
-
-
-
-;; define-meta-class %allocate-instance %instance-ref %instancep %instance-meta-class 
-
-
-                                                             ; allocate-instance optimize-slot-value
-                                                             ; optimize-setf-of-slot-value
-                                                             ; add-named-class
-                                                             ; class-for-redefinition add-class
-                                                             ; supers-changed slots-changed
-                                                             ; check-super-metaclass-compatibility
-                                                             ; make-slotd
-                                                             ; compute-class-precedence-list
-                                                             ; walk-method-body
-                                                             ; walk-method-body-form
-                                                             ; add-named-method remove-named-method
-                                                             ; )) 
-
diff --git a/obsolete/clos/2.0/plap.lisp b/obsolete/clos/2.0/plap.lisp
deleted file mode 100644
index 49d8b833..00000000
--- a/obsolete/clos/2.0/plap.lisp
+++ /dev/null
@@ -1,309 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;;. Copyright (c) 1991 by Venue
-
-(in-package "CLOS")
-
-
-;;; The portable implementation of the LAP assembler. The portable implementation of the LAP
-;;; assembler works by translating LAP code back into Lisp code and then compiling that Lisp code. 
-;;; Note that this implementation is actually going to get a lot of use.  Some implementations (KCL)
-;;; won't implement a native LAP assembler at all. Other implementations may not implement native
-;;; LAP assemblers for all of their ports.  All of this implies that this portable LAP assembler
-;;; needs to generate the best code it possibly can. 
-
-
-(defmacro
- lap-case
- (operand &body cases)
- (once-only
-  (operand)
-  `(ecase (car ,operand)
-       ,@(mapcar #'(lambda (case)
-                          `(,(car case)
-                            (apply #'(lambda ,(cadr case)
-                                            ,@(cddr case))
-                                   (cdr ,operand))))
-                cases))))
-
-(defvar *lap-args*)
-
-(defvar *lap-rest-p*)
-
-(defvar *lap-i-regs*)
-
-(defvar *lap-v-regs*)
-
-(defvar *lap-t-regs*)
-
-(defvar *lap-optimize-declaration* '((speed 3)
-                                     (safety 0)
-                                     (compilation-speed 0)))
-
-(eval-when (load eval)
-       (setq *make-lap-closure-generator* #'(lambda (closure-var-names arg-names index-regs 
-                                                           vector-regs t-regs lap-code)
-                                                   (compile-lambda (make-lap-closure-generator-lambda
-                                                                    closure-var-names arg-names 
-                                                                    index-regs vector-regs t-regs 
-                                                                    lap-code)))
-             *precompile-lap-closure-generator*
-             #'(lambda (cvars args i-regs v-regs t-regs lap)
-                      `#',(make-lap-closure-generator-lambda cvars args i-regs v-regs t-regs lap))
-             *lap-in-lisp*
-             #'(lambda (cvars args iregs vregs tregs lap)
-                      (declare (ignore cvars args))
-                      (make-lap-prog iregs vregs tregs (flatten-lap lap 
-                                                             ; (opcode :label 'exit-lap-in-lisp)
-                                                              )))))
-
-(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs t-regs lap)
-       (let* ((rest (memq '&rest args))
-              (ldiff (and rest (ldiff args rest))))
-             (when rest
-                 (setq args (append ldiff '(&rest .lap-rest-arg.))))
-             (let* ((*lap-args* (if rest
-                                    ldiff
-                                    args))
-                    (*lap-rest-p* (not (null rest))))
-                   `(lambda ,cvars #'(lambda ,args (declare (optimize . ,*lap-optimize-declaration*))
-                                            ,(make-lap-prog-internal i-regs v-regs t-regs lap))))))
-
-(defun make-lap-prog (i-regs v-regs t-regs lap)
-       (let* ((*lap-args* 'lap-in-lisp)
-              (*lap-rest-p* 'lap-in-lisp))
-             (make-lap-prog-internal i-regs v-regs t-regs lap)))
-
-(defun make-lap-prog-internal (i-regs v-regs t-regs lap)
-       (let* ((*lap-i-regs* i-regs)
-              (*lap-v-regs* v-regs)
-              (*lap-t-regs* t-regs)
-              (code (mapcar #'lap-opcode lap)))
-             `(prog ,(mapcar #'(lambda (reg)
-                                      `(,(lap-reg reg)
-                                        ,(lap-reg-initial-value-form reg)))
-                            (append i-regs v-regs t-regs))
-                    (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*))
-                           (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
-                           (optimize . ,*lap-optimize-declaration*))
-                    ,.code)))
-
-(defconstant *empty-vector* '#())
-
-(defun lap-reg-initial-value-form (reg)
-       (cond ((member reg *lap-i-regs*)
-              0)
-             ((member reg *lap-v-regs*)
-              '*empty-vector*)
-             ((member reg *lap-t-regs*)
-              nil)
-             (t (error "What kind of register is ~S?" reg))))
-
-(defun lap-opcode (opcode)
-       (lap-case opcode (:move (from to)
-                               `(setf ,(lap-operand to)
-                                      ,(lap-operand from)))
-              ((:eq :neq :fix=)
-               (arg1 arg2 label)
-               `(when ,(lap-operands (ecase (car opcode)
-                                         (:eq 'eq)
-                                         (:neq 'neq)
-                                         (:fix= 'runtime\ fix=))
-                              arg1 arg2)
-                    (go ,label)))
-              ((:izerop)
-               (arg label)
-               `(when ,(lap-operands 'runtime\ izerop arg)
-                    (go ,label)))
-              (:std-instance-p (from label)
-                     `(when ,(lap-operands 'runtime\ std-instance-p from)
-                          (go ,label)))
-              (:fsc-instance-p (from label)
-                     `(when ,(lap-operands 'runtime\ fsc-instance-p from)
-                          (go ,label)))
-              (:built-in-instance-p (from label)
-                     (declare (ignore from))
-                     `(when ,t
-                          (go ,label)))
-                                                             ; ***
-              (:structure-instance-p (from label)
-                     `(when ,(lap-operands 'runtime\ ??? from)
-                          (go ,label)))
-                                                             ; ***
-              (:jmp (fn)
-                    (if (eq *lap-args* 'lap-in-lisp)
-                        (error "Can't do a :JMP in LAP-IN-LISP.")
-                        `(return ,(if *lap-rest-p*
-                                      `(runtime\ apply ,(lap-operand fn)
-                                              ,@*lap-args* .lap-rest-arg.)
-                                      `(runtime\ funcall ,(lap-operand fn)
-                                              ,@*lap-args*)))))
-              (:return (value)
-                     `(return ,(lap-operand value)))
-              (:label (label)
-                     label)
-              (:go (label)
-                   `(go ,label))
-              (:exit-lap-in-lisp nil `(go exit-lap-in-lisp))
-              (:break nil `(break))
-              (:beep nil)
-              (:print (val)
-                     (lap-operands 'print val))))
-
-(defun lap-operand (operand)
-       (lap-case operand (:reg (n)
-                               (lap-reg n))
-              (:cdr (reg)
-                    (lap-operands 'cdr reg))
-              ((:cvar :arg)
-               (name)
-               name)
-              (:constant (c)
-                     `',c)
-              ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper :std-slots :fsc-slots)
-               (x)
-               (lap-operands (ecase (car operand)
-                                 (:std-wrapper 'runtime\ std-wrapper)
-                                 (:fsc-wrapper 'runtime\ fsc-wrapper)
-                                 (:built-in-wrapper 'runtime\ built-in-wrapper)
-                                 (:structure-wrapper 'runtime\ structure-wrapper)
-                                 (:std-slots 'runtime\ std-slots)
-                                 (:fsc-slots 'runtime\ fsc-slots))
-                      x))
-              (:i1+ (index)
-                    (lap-operands 'runtime\ i1+ index))
-              (:i+ (index1 index2)
-                   (lap-operands 'runtime\ i+ index1 index2))
-              (:i- (index1 index2)
-                   (lap-operands 'runtime\ i- index1 index2))
-              (:ilogand (index1 index2)
-                     (lap-operands 'runtime\ ilogand index1 index2))
-              (:ilogxor (index1 index2)
-                     (lap-operands 'runtime\ ilogxor index1 index2))
-              (:iref (vector index)
-                     (lap-operands 'runtime\ iref vector index))
-              (:iset (vector index value)
-                     (lap-operands 'runtime\ iset vector index value))
-              (:cref (vector i)
-                     `(runtime\ svref ,(lap-operand vector)
-                             ,i))
-              (:lisp-variable (symbol)
-                     symbol)
-              (:lisp (form)
-                     form)))
-
-(defun lap-operands (fn &rest regs)
-       (cons fn (mapcar #'lap-operand regs)))
-
-(defun lap-reg (n)
-       (intern (format nil "REG~D" n)
-              *the-clos-package*))
-
-
-;;; Runtime Implementations of the operands and opcodes. In those ports of CLOS which choose not to
-;;; completely re-implement the LAP code generator, it may still be provident to consider
-;;; reimplementing one or more of these to get the compiler to produce better code.  That is why
-;;; they are split out. 
-
-
-(proclaim '(declaration clos-fast-call))
-
-(defmacro runtime\ funcall (fn &rest args)
-       `(funcall ,fn ,.args))
-
-(defmacro runtime\ apply (fn &rest args)
-       `(apply ,fn ,.args))
-
-(defmacro runtime\ std-wrapper (x)
-       `(std-instance-wrapper ,x))
-
-(defmacro runtime\ fsc-wrapper (x)
-       `(fsc-instance-wrapper ,x))
-
-(defmacro runtime\ built-in-wrapper (x)
-       `(built-in-wrapper-of ,x))
-
-(defmacro runtime\ structure-wrapper (x)
-       `(??? ,x))
-
-(defmacro runtime\ std-slots (x)
-       `(std-instance-slots (the std-instance ,x)))
-
-(defmacro runtime\ fsc-slots (x)
-       `(fsc-instance-slots ,x))
-
-(defmacro runtime\ std-instance-p (x)
-       `(std-instance-p ,x))
-
-(defmacro runtime\ fsc-instance-p (x)
-       `(fsc-instance-p ,x))
-
-(defmacro runtime\ izerop (x)
-       `(zerop (the fixnum ,x)))
-
-(defmacro runtime\ fix= (x y)
-       `(= (the fixnum ,x)
-           (the fixnum ,y)))
-
-
-;;; These are the implementations of the index operands.  The portable assembler generates Lisp code
-;;; that uses these macros.  Even though the variables holding the arguments and results have type
-;;; declarations on them, we put type declarations in here. Some compilers are so stupid... 
-
-
-(defmacro runtime\ iref (vector index)
-       `(svref (the simple-vector ,vector)
-               (the fixnum ,index)))
-
-(defmacro runtime\ iset (vector index value)
-       `(setf (svref (the simple-vector ,vector)
-                     (the fixnum ,index))
-              ,value))
-
-(defmacro runtime\ svref (vector fixnum)
-       `(svref (the simple-vector ,vector)
-               (the fixnum ,fixnum)))
-
-(defmacro runtime\ i+ (index1 index2)
-       `(the fixnum (+ (the fixnum ,index1)
-                       (the fixnum ,index2))))
-
-(defmacro runtime\ i- (index1 index2)
-       `(the fixnum (- (the fixnum ,index1)
-                       (the fixnum ,index2))))
-
-(defmacro runtime\ i1+ (index)
-       `(the fixnum (1+ (the fixnum ,index))))
-
-(defmacro runtime\ ilogand (index1 index2)
-       `(the fixnum (logand (the fixnum ,index1)
-                           (the fixnum ,index2))))
-
-(defmacro runtime\ ilogxor (index1 index2)
-       `(the fixnum (logxor (the fixnum ,index1)
-                           (the fixnum ,index2))))
-
-
-;;; In the portable implementation, indexes are just fixnums. 
-
-
-(defconstant index-value-limit most-positive-fixnum)
-
-(defun index-value->index (index-value)
-       index-value)
-
-(defun index->index-value (index)
-       index)
-
-(defun make-index-mask (cache-size line-size)
-       (let ((cache-size-in-bits (floor (log cache-size 2)))
-             (line-size-in-bits (floor (log line-size 2)))
-             (mask 0))
-            (dotimes (i cache-size-in-bits)
-                (setq mask (dpb 1 (byte 1 i)
-                                mask)))
-            (dotimes (i line-size-in-bits)
-                (setq mask (dpb 0 (byte 1 i)
-                                mask)))
-            mask))
diff --git a/obsolete/clos/2.0/precom-browser.cl b/obsolete/clos/2.0/precom-browser.cl
deleted file mode 100644
index cb7bad35..00000000
--- a/obsolete/clos/2.0/precom-browser.cl
+++ /dev/null
@@ -1,3 +0,0 @@
-;;
-
-(CLOS::PRECOMPILE-RANDOM-CODE-SEGMENTS BROWSER)
diff --git a/obsolete/clos/2.0/precom1.lisp b/obsolete/clos/2.0/precom1.lisp
deleted file mode 100644
index 76d6e88b..00000000
--- a/obsolete/clos/2.0/precom1.lisp
+++ /dev/null
@@ -1,31 +0,0 @@
-;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-
-(in-package 'clos)
-
-;;;
-;;; pre-allocate generic function caches.  The hope is that this will put
-;;; them nicely together in memory, and that that may be a win.  Of course
-;;; the first gc copy will probably blow that out, this really wants to be
-;;; wrapped in something that declares the area static.
-;;;
-;;; This preallocation only creates about 25% more caches than CLOS itself
-;;; uses need.  Some ports may want to preallocate some more of these.
-;;; 
-(eval-when (load)
-  (flet ((allocate (n size)
-	   (mapcar #'free-cache
-		   (mapcar #'get-cache
-			   (make-list n :initial-element size)))))
-    (allocate 128 4)
-    (allocate 64 8)
-    (allocate 64 9)
-    (allocate 32 16)
-    (allocate 16 17)
-    (allocate 16 32)
-    (allocate 1  64)))
\ No newline at end of file
diff --git a/obsolete/clos/2.0/precom2.lisp b/obsolete/clos/2.0/precom2.lisp
deleted file mode 100644
index 0c763a45..00000000
--- a/obsolete/clos/2.0/precom2.lisp
+++ /dev/null
@@ -1,12 +0,0 @@
-;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-
-(in-package 'clos)
-
-(precompile-dfun-constructors clos)		;this is half of a call to
-						;precompile-random-code-segments
diff --git a/obsolete/clos/2.0/precom4.lisp b/obsolete/clos/2.0/precom4.lisp
deleted file mode 100644
index 06a17cf5..00000000
--- a/obsolete/clos/2.0/precom4.lisp
+++ /dev/null
@@ -1,12 +0,0 @@
-;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-
-(in-package 'clos)
-
-(precompile-function-generators clos)		;this is half of a call to
-						;precompile-random-code-segments
diff --git a/obsolete/clos/2.0/slots.lisp b/obsolete/clos/2.0/slots.lisp
deleted file mode 100644
index c21c00d6..00000000
--- a/obsolete/clos/2.0/slots.lisp
+++ /dev/null
@@ -1,261 +0,0 @@
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;;. Copyright (c) 1991 by Venue
-
-(in-package "CLOS")
-
-;;; These four functions work on std-instances and fsc-instances.  These are instances for which it
-;;; is possible to change the wrapper and the slots. For these kinds of instances, most specified
-;;; methods from the instance structure protocol are promoted to the implementation-specific class
-;;; std-class.  Many of these methods call these four functions. 
-
-
-(defun get-wrapper (inst)
-       (cond ((std-instance-p inst)
-              (std-instance-wrapper inst))
-             ((fsc-instance-p inst)
-              (fsc-instance-wrapper inst))
-             (t (error "What kind of instance is this?"))))
-
-(defun get-slots (inst)
-       (cond ((std-instance-p inst)
-              (std-instance-slots inst))
-             ((fsc-instance-p inst)
-              (fsc-instance-slots inst))
-             (t (error "What kind of instance is this?"))))
-
-(defun set-wrapper (inst new)
-       (cond ((std-instance-p inst)
-              (setf (std-instance-wrapper inst)
-                    new))
-             ((fsc-instance-p inst)
-              (setf (fsc-instance-wrapper inst)
-                    new))
-             (t (error "What kind of instance is this?"))))
-
-(defun set-slots (inst new)
-       (cond ((std-instance-p inst)
-              (setf (std-instance-slots inst)
-                    new))
-             ((fsc-instance-p inst)
-              (setf (fsc-instance-slots inst)
-                    new))
-             (t (error "What kind of instance is this?"))))
-
-(defmacro get-slot-value-2 (instance wrapper slot-name slots index)
-       `(let ((val (%svref ,slots ,index)))
-             (if (eq val ',*slot-unbound*)
-                 (slot-unbound (wrapper-class ,wrapper)
-                        ,instance
-                        ,slot-name)
-                 val)))
-
-(defmacro set-slot-value-2 (nv instance wrapper slot-name slots index)
-       (declare (ignore instance wrapper slot-name))
-       `(setf (%svref ,slots ,index)
-              ,nv))
-
-(defun get-class-slot-value-1 (object wrapper slot-name)
-       (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
-            (if (null entry)
-                (slot-missing (wrapper-class wrapper)
-                       object slot-name 'slot-value)
-                (if (eq (cdr entry)
-                        *slot-unbound*)
-                    (slot-unbound (wrapper-class wrapper)
-                           object slot-name)
-                    (cdr entry)))))
-
-(defun set-class-slot-value-1 (new-value object wrapper slot-name)
-       (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
-            (if (null entry)
-                (slot-missing (wrapper-class wrapper)
-                       object slot-name 'setf new-value)
-                (setf (cdr entry)
-                      new-value))))
-
-(defmethod class-slot-value ((class std-class)
-                             slot-name)
-       (let ((wrapper (class-wrapper class))
-             (prototype (class-prototype class)))
-            (get-class-slot-value-1 prototype wrapper slot-name)))
-
-(defmethod (setf class-slot-value)
-       (nv (class std-class)
-           slot-name)
-       (let ((wrapper (class-wrapper class))
-             (prototype (class-prototype class)))
-            (set-class-slot-value-1 nv prototype wrapper slot-name)))
-
-(defmethod find-slot-definition ((class std-class)
-                                 slot-name)
-       (if (and (eq class *the-class-standard-class*)
-                (eq slot-name 'slots))
-           *the-eslotd-standard-class-slots*
-           (progn (unless (class-finalized-p class)
-                         (finalize-inheritance class))
-                  (dolist (eslotd (class-slots class))
-                      (when (eq (slotd-name eslotd)
-                                slot-name)
-                            (return eslotd))))))
-
-(defun slot-value (object slot-name)
-       (let ((class (class-of object)))
-            (if (eq class *the-class-standard-effective-slot-definition*)
-                (let* ((wrapper (check-wrapper-validity object))
-                       (slots (get-slots object))
-                       (index (instance-slot-index wrapper slot-name)))
-                      (if index
-                          (get-slot-value-2 object wrapper slot-name slots index)
-                          (get-class-slot-value-1 object wrapper slot-name)))
-                (let ((slot-definition (find-slot-definition class slot-name)))
-                     (if (null slot-definition)
-                         (slot-missing class object slot-name 'slot-value)
-                         (slot-value-using-class class object slot-definition))))))
-
-(defun set-slot-value (object slot-name new-value)
-       (let ((class (class-of object)))
-            (if (eq class *the-class-standard-effective-slot-definition*)
-                (let* ((wrapper (check-wrapper-validity object))
-                       (slots (get-slots object))
-                       (index (instance-slot-index wrapper slot-name)))
-                      (if index
-                          (set-slot-value-2 new-value object wrapper slot-name slots index)
-                          (set-class-slot-value-1 new-value object wrapper slot-name)))
-                (let ((slot-definition (find-slot-definition class slot-name)))
-                     (if (null slot-definition)
-                         (slot-missing class object slot-name 'setf)
-                         (setf (slot-value-using-class class object slot-definition)
-                               new-value))))))
-
-(defun slot-boundp (object slot-name)
-       (let* ((class (class-of object))
-              (slot-definition (find-slot-definition class slot-name)))
-             (if (null slot-definition)
-                 (slot-missing class object slot-name 'slot-boundp)
-                 (slot-boundp-using-class class object slot-definition))))
-
-(defun slot-makunbound (object slot-name)
-       (let* ((class (class-of object))
-              (slot-definition (find-slot-definition class slot-name)))
-             (if (null slot-definition)
-                 (slot-missing class object slot-name 'slot-makunbound)
-                 (slot-makunbound-using-class class object slot-definition))))
-
-(defun slot-exists-p (object slot-name)
-       (let* ((class (class-of object))
-              (slot-definition (find-slot-definition class slot-name)))
-             (and slot-definition (slot-exists-p-using-class class object slot-definition))))
-
-
-;;; This isn't documented, but is used within CLOS in a number of print object methods (see
-;;; named-object-print-function). 
-
-
-(defun slot-value-or-default (object slot-name &optional (default "unbound"))
-       (if (slot-boundp object slot-name)
-           (slot-value object slot-name)
-           default))
-
-
-;;; 
-
-
-(defmethod slot-value-using-class ((class std-class)
-                                   (object standard-object)
-                                   (slotd standard-effective-slot-definition))
-       (let* ((wrapper (check-wrapper-validity object))
-                                                             ; trap if need be
-              (slots (get-slots object))
-              (slot-name (slotd-name slotd))
-              (index (or (slotd-instance-index slotd)
-                         (setf (slotd-instance-index slotd)
-                               (instance-slot-index wrapper slot-name)))))
-             (if index
-                 (get-slot-value-2 object wrapper slot-name slots index)
-                 (get-class-slot-value-1 object wrapper slot-name))))
-
-(defmethod (setf slot-value-using-class)
-       (new-value (class std-class)
-              (object standard-object)
-              (slotd standard-effective-slot-definition))
-       (let* ((wrapper (check-wrapper-validity object))
-                                                             ; trap if need be
-              (slots (get-slots object))
-              (slot-name (slotd-name slotd))
-              (index (or (slotd-instance-index slotd)
-                         (setf (slotd-instance-index slotd)
-                               (instance-slot-index wrapper slot-name)))))
-             (if index
-                 (set-slot-value-2 new-value object wrapper slot-name slots index)
-                 (set-class-slot-value-1 new-value object wrapper slot-name))))
-
-(defmethod slot-boundp-using-class ((class std-class)
-                                    (object standard-object)
-                                    (slotd standard-effective-slot-definition))
-       (let* ((wrapper (check-wrapper-validity object))
-                                                             ; trap if need be
-              (slots (get-slots object))
-              (slot-name (slotd-name slotd))
-              (index (or (slotd-instance-index slotd)
-                         (setf (slotd-instance-index slotd)
-                               (instance-slot-index wrapper slot-name)))))
-             (if index
-                 (neq (svref slots index)
-                      *slot-unbound*)
-                 (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
-                      (if (null entry)
-                          (slot-missing class object slot-name 'slot-boundp)
-                          (neq (cdr entry)
-                               *slot-unbound*))))))
-
-(defmethod slot-makunbound-using-class ((class std-class)
-                                        (object standard-object)
-                                        (slotd standard-effective-slot-definition))
-       (let* ((wrapper (check-wrapper-validity object))
-                                                             ; trap if need be
-              (slots (get-slots object))
-              (slot-name (slotd-name slotd))
-              (index (or (slotd-instance-index slotd)
-                         (setf (slotd-instance-index slotd)
-                               (instance-slot-index wrapper slot-name)))))
-             (cond (index (setf (%svref slots index)
-                                *slot-unbound*)
-                          object)
-                   (t (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
-                           (if* (null entry)
-                                (slot-missing class object slot-name 'slot-makunbound)
-                                (setf (cdr entry)
-                                      *slot-unbound*)
-                                object))))))
-
-(defmethod slot-exists-p-using-class ((class std-class)
-                                      (object standard-object)
-                                      (slotd standard-effective-slot-definition))
-       t)
-
-(defmethod slot-missing ((class t)
-                         instance slot-name operation &optional new-value)
-       (error "When attempting to ~A,~%the slot ~S is missing from the object ~S."
-              (ecase operation
-                  (slot-value "read the slot's value (slot-value)")
-                  (setf (format nil "set the slot's value to ~S (setf of slot-value)" new-value))
-                  (slot-boundp "test to see if slot is bound (slot-boundp)")
-                  (slot-makunbound "make the slot unbound (slot-makunbound)"))
-              slot-name instance))
-
-(defmethod slot-unbound ((class t)
-                         instance slot-name)
-       (error "The slot ~S is unbound in the object ~S." slot-name instance))
-
-(defmethod allocate-instance ((class standard-class)
-                              &rest initargs)
-       (declare (ignore initargs))
-       (unless (class-finalized-p class)
-              (finalize-inheritance class))
-       (let* ((class-wrapper (class-wrapper class))
-              (instance (%allocate-instance--class (class-no-of-instance-slots class))))
-             (setf (std-instance-wrapper instance)
-                   class-wrapper)
-             instance))
diff --git a/obsolete/clos/2.0/std-class.lisp b/obsolete/clos/2.0/std-class.lisp
deleted file mode 100644
index a07b366c..00000000
--- a/obsolete/clos/2.0/std-class.lisp
+++ /dev/null
@@ -1,997 +0,0 @@
-
-;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
-
-
-;;; File converted on 10-Apr-91 22:24:19 from source std-class
-;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>std-class.;4 created 20-Feb-91 13:07:14
-
-;;;. Copyright (c) 1991 by Venue
-
-
-(in-package "CLOS")
-
-
-
-(define-gf-predicate classp class)
-
-(define-gf-predicate standard-class-p standard-class)
-
-(define-gf-predicate forward-referenced-class-p forward-referenced-class)
-
-(defmethod shared-initialize :after ((object documentation-mixin)
-                                     slot-names &key documentation)
-       (declare (ignore slot-names))
-       (setf (plist-value object 'documentation)
-             documentation))
-
-(defmethod documentation (object &optional doc-type)
-       (cl:documentation object doc-type))
-
-(defmethod (setf documentation)
-       (new-value object &optional doc-type)
-       (declare (ignore new-value doc-type))
-       (error "Can't change the documentation of ~S." object))
-
-(defmethod documentation ((object documentation-mixin)
-                          &optional doc-type)
-  (declare (ignore doc-type))
-  (car (plist-value object 'documentation)))
-
-(defmethod (setf documentation)
-       (new-value (object documentation-mixin)
-              &optional doc-type)
-       (declare (ignore doc-type))
-       (setf (plist-value object 'documentation)
-             new-value))
-
-(defmethod documentation ((slotd standard-slot-definition)
-                          &optional doc-type)
-       (declare (ignore doc-type))
-       (slot-value slotd 'documentation))
-
-(defmethod (setf documentation)
-       (new-value (slotd standard-slot-definition)
-              &optional doc-type)
-       (declare (ignore doc-type))
-       (setf (slot-value slotd 'documentation)
-             new-value))
-
-(defmethod documentation ((method standard-method) &optional doc-type)
-  (declare (ignore doc-type))
-  (plist-value method 'documentation))
-
-(defmethod (setf documentation)
-	   (new-value (method standard-method)
-		      &optional doc-type)
-  (declare (ignore doc-type))
-  (setf (plist-value method 'documentation) new-value))
-
-;;; Various class accessors that are a little more complicated than can be done with automatically
-;;; generated reader methods. 
-
-
-(defmethod class-wrapper ((class clos-class))
-       (with-slots (wrapper)
-           class
-         (let ((w? wrapper))
-              (if (consp w?)
-                  (let ((new (make-wrapper class)))
-                       (setf (wrapper-instance-slots-layout new)
-                             (car w?)
-                             (wrapper-class-slots new)
-                             (cdr w?))
-                       (setq wrapper new))
-                  w?))))
-
-(defmethod class-precedence-list ((class clos-class))
-       (unless (class-finalized-p class)
-              (finalize-inheritance class))
-       (with-slots (class-precedence-list)
-           class
-         class-precedence-list))
-
-(defmethod class-finalized-p ((class clos-class))
-       (with-slots (wrapper)
-           class
-         (not (null wrapper))))
-
-(defmethod class-prototype ((class std-class))
-       (with-slots (prototype)
-           class
-         (or prototype (setq prototype (allocate-instance class)))))
-
-(defmethod class-direct-default-initargs ((class std-class))
-       (plist-value class 'direct-default-initargs))
-
-(defmethod class-default-initargs ((class std-class))
-       (plist-value class 'default-initargs))
-
-(defmethod class-constructors ((class std-class))
-       (plist-value class 'constructors))
-
-(defmethod class-slot-cells ((class std-class))
-       (plist-value class 'class-slot-cells))
-
-
-;;; Class accessors that are even a little bit more complicated than those above.  These have a
-;;; protocol for updating them, we must implement that protocol. Maintaining the direct subclasses
-;;; backpointers.  The update methods are here, the values are read by an automatically generated
-;;; reader method. 
-
-
-(defmethod add-direct-subclass ((class class)
-                                (subclass class))
-       (with-slots (direct-subclasses)
-           class
-         (pushnew subclass direct-subclasses)
-         subclass))
-
-(defmethod remove-direct-subclass ((class class)
-                                   (subclass class))
-       (with-slots (direct-subclasses)
-           class
-         (setq direct-subclasses (remove subclass direct-subclasses))
-         subclass))
-
-
-;;; Maintaining the direct-methods and direct-generic-functions backpointers. There are four generic
-;;; functions involved, each has one method for the class case and another method for the damned EQL
-;;; specializers. All of these are specified methods and appear in their specified place in the
-;;; class graph. ADD-METHOD-ON-SPECIALIZER REMOVE-METHOD-ON-SPECIALIZER SPECIALIZER-METHODS
-;;; SPECIALIZER-GENERIC-FUNCTIONS In each case, we maintain one value which is a cons.  The car is
-;;; the list methods.  The cdr is a list of the generic functions.  The cdr is always computed
-;;; lazily. 
-
-
-(defmethod add-method-on-specializer ((method method)
-                                      (specializer class))
-       (with-slots (direct-methods)
-           specializer
-         (setf (car direct-methods)
-               (adjoin method (car direct-methods))
-               (cdr direct-methods)
-               nil))
-       method)
-
-(defmethod remove-method-on-specializer ((method method)
-                                         (specializer class))
-       (with-slots (direct-methods)
-           specializer
-         (setf (car direct-methods)
-               (remove method (car direct-methods))
-               (cdr direct-methods)
-               nil))
-       method)
-
-(defmethod specializer-methods ((specializer class))
-       (with-slots (direct-methods)
-           specializer
-         (car direct-methods)))
-
-(defmethod specializer-generic-functions ((specializer class))
-       (with-slots (direct-methods)
-           specializer
-         (or (cdr direct-methods)
-             (setf (cdr direct-methods)
-                   (gathering1 (collecting-once)
-                          (dolist (m (car direct-methods))
-                              (gather1 (method-generic-function m))))))))
-
-
-;;; This hash table is used to store the direct methods and direct generic functions of EQL
-;;; specializers.  Each value in the table is the cons. 
-
-
-(defvar *eql-specializer-methods* (make-hash-table :test #'eql))
-
-(defmethod add-method-on-specializer ((method method)
-                                      (specializer eql-specializer))
-       (let* ((object (eql-specializer-object specializer))
-              (entry (gethash object *eql-specializer-methods*)))
-             (unless entry
-                 (setq entry (setf (gethash object *eql-specializer-methods*)
-                                   (cons nil nil))))
-             (setf (car entry)
-                   (adjoin method (car entry))
-                   (cdr entry)
-                   nil)
-             method))
-
-(defmethod remove-method-on-specializer ((method method)
-                                         (specializer eql-specializer))
-       (let* ((object (eql-specializer-object specializer))
-              (entry (gethash object *eql-specializer-methods*)))
-             (when entry
-                 (setf (car entry)
-                       (remove method (car entry))
-                       (cdr entry)
-                       nil))
-             method))
-
-(defmethod specializer-methods ((specializer eql-specializer))
-       (car (gethash (eql-specializer-object specializer)
-                   *eql-specializer-methods*)))
-
-(defmethod specializer-generic-functions ((specializer eql-specializer))
-       (let* ((object (eql-specializer-object specializer))
-              (entry (gethash object *eql-specializer-methods*)))
-             (when entry
-                 (or (cdr entry)
-                     (setf (cdr entry)
-                           (gathering1 (collecting-once)
-                                  (dolist (m (car entry))
-                                      (gather1 (method-generic-function m)))))))))
-
-(defun real-load-defclass (name metaclass-name supers slots other accessors)
-       (do-standard-defsetfs-for-defclass accessors)
-                                                             ; ***
-       (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots
-              slots :definition-source `((defclass ,name ()
-                                             ())
-                                         ,(load-truename))
-              other))
-
-(defun ensure-class (name &rest all)
-       (apply #'ensure-class-using-class name (find-class name nil)
-              all))
-
-(defmethod ensure-class-using-class (name (class null)
-                                          &rest args &key)
-       (multiple-value-bind (meta initargs)
-           (ensure-class-values class args)
-         (setf class (apply #'make-instance meta :name name initargs)
-               (find-class name)
-               class)
-	 (inform-type-system-about-class class name)
-                                                             ; ***
-         class))
-
-(defmethod ensure-class-using-class (name (class clos-class)
-                                          &rest args &key)
-       (multiple-value-bind (meta initargs)
-           (ensure-class-values class args)
-         (unless (eq (class-of class)
-                     meta)
-                (change-class class meta))
-         (apply #'reinitialize-instance class initargs)
-         (inform-type-system-about-class class name)
-                                                             ; ***
-         class))
-
-(defun ensure-class-values (class args)
-       (let* ((initargs (copy-list args))
-              (unsupplied (list 1))
-              (supplied-meta (getf initargs :metaclass unsupplied))
-              (supplied-supers (getf initargs :direct-superclasses unsupplied))
-              (supplied-slots (getf initargs :direct-slots unsupplied))
-              (meta (cond ((neq supplied-meta unsupplied)
-                           (find-class supplied-meta))
-                          ((or (null class)
-                               (forward-referenced-class-p class))
-                           *the-class-standard-class*)
-                          (t (class-of class))))
-              (proto (class-prototype meta)))
-             (flet ((fix-super (s)
-                           (cond ((classp s)
-                                  s)
-                                 ((not (legal-class-name-p s))
-                                  (error "~S is not a class or a legal class name." s))
-                                 (t (or (find-class s nil)
-                                        (setf (find-class s)
-                                              (make-instance 'forward-referenced-class :name s)))))))
-                   (loop (unless (remf initargs :metaclass)
-                                (return)))
-                   (loop (unless (remf initargs :direct-superclasses)
-                                (return)))
-                   (loop (unless (remf initargs :direct-slots)
-                                (return)))
-                   (values meta (list* :direct-superclasses (and (neq supplied-supers unsupplied)
-                                                                 (mapcar #'fix-super supplied-supers)
-                                                                 )
-                                       :direct-slots
-                                       (and (neq supplied-slots unsupplied)
-                                            supplied-slots)
-                                       initargs)))))
-
-
-;;; 
-
-
-(defmethod shared-initialize :before ((class std-class)
-                                      slot-names &key direct-superclasses)
-       (declare (ignore slot-names))
-       
-       ;; *** error checking
-       )
-
-(defmethod shared-initialize :after ((class std-class)
-                                     slot-names 
-				     &key (direct-superclasses 
-					   nil direct-superclasses-p)
-                                     (direct-slots nil direct-slots-p)
-                                     (direct-default-initargs 
-				      nil direct-default-initargs-p))
-  (declare (ignore slot-names))
-  (setq direct-superclasses (if direct-superclasses-p
-				(setf (slot-value class 'direct-superclasses)
-				      (or direct-superclasses 
-					  (list *the-class-standard-object*)
-					  ))
-				(slot-value class 'direct-superclasses)))
-  (setq direct-slots (if direct-slots-p
-			 (setf (slot-value class 'direct-slots)
-			       (mapcar #'(lambda (pl)
-					   (make-direct-slotd class pl))
-				       direct-slots))
-			 (slot-value class 'direct-slots)))
-  (if direct-default-initargs-p
-      (setf (plist-value class 'direct-default-initargs)
-	    direct-default-initargs)
-      (setq direct-default-initargs
-	    (plist-value class 'direct-default-initargs)))
-  (setf (plist-value class 'class-slot-cells)
-	(gathering1 (collecting)
-                    (dolist (dslotd direct-slots)
-		      (when (eq (slotd-allocation dslotd)
-				class)
-			(let ((initfunction (slotd-initfunction dslotd)))
-			  (gather1 (cons (slotd-name dslotd)
-					 (if initfunction
-					     (funcall initfunction)
-					     *slot-unbound*))))))))
-  (add-direct-subclasses class direct-superclasses)
-  (add-slot-accessors class direct-slots))
-
-(defmethod reinitialize-instance :before ((class std-class)
-                                          &key direct-superclasses direct-slots 
-                                          direct-default-initargs)
-       (declare (ignore direct-default-initargs))
-       (remove-direct-subclasses class (class-direct-superclasses class))
-       (remove-slot-accessors class (class-direct-slots class)))
-
-(defmethod reinitialize-instance :after ((class std-class)
-                                         &rest initargs &key)
-       (update-class class nil)
-       (map-dependents class #'(lambda (dependent)
-                                      (apply #'update-dependent class dependent initargs))))
-
-(defun add-slot-accessors (class dslotds)
-       (fix-slot-accessors class dslotds 'add))
-
-(defun remove-slot-accessors (class dslotds)
-       (fix-slot-accessors class dslotds 'remove))
-
-(defun fix-slot-accessors (class dslotds add/remove)
-       (flet ((fix (gfspec name r/w)
-                   (let ((gf (ensure-generic-function gfspec)))
-                        (case r/w
-                            (r (if (eq add/remove 'add)
-                                   (add-reader-method class gf name)
-                                   (remove-reader-method class gf)))
-                            (w (if (eq add/remove 'add)
-                                   (add-writer-method class gf name)
-                                   (remove-writer-method class gf)))))))
-             (dolist (dslotd dslotds)
-                 (let ((slot-name (slotd-name dslotd)))
-                      (dolist (r (slotd-readers dslotd))
-                          (fix r slot-name 'r))
-                      (dolist (w (slotd-writers dslotd))
-                          (fix w slot-name 'w))))))
-
-(defun add-direct-subclasses (class new)
-       (dolist (n new)
-           (unless (memq class (class-direct-subclasses class))
-                  (add-direct-subclass n class))))
-
-(defun remove-direct-subclasses (class new)
-       (let ((old (class-direct-superclasses class)))
-            (dolist (o (set-difference old new))
-                (remove-direct-subclass o class))))
-
-
-;;; 
-
-
-(defmethod finalize-inheritance ((class std-class))
-       (update-class class t))
-
-
-;;; Called by :after reinitialize instance whenever a class is reinitialized. The class may or may
-;;; not be finalized. 
-
-
-(defun update-class (class finalizep)
-       (when (or finalizep (class-finalized-p class))
-           (let* ((dsupers (class-direct-superclasses class))
-                  (dslotds (class-direct-slots class))
-                  (dinits (class-direct-default-initargs class))
-                  (cpl (compute-class-precedence-list class dsupers))
-                  (eslotds (compute-slots class cpl dslotds))
-                  (inits (compute-default-initargs class cpl dinits)))
-                 (update-cpl class cpl)
-                 (update-slots class cpl eslotds)
-		 (update-dinits class dinits)
-                 (update-inits class inits)
-                 (update-constructors class)))
-       (unless finalizep
-           (dolist (sub (class-direct-subclasses class))
-               (update-class sub nil))))
-
-(defun update-cpl (class cpl)
-       (when (class-finalized-p class)
-           (unless (equal (class-precedence-list class)
-                          cpl)
-                  (force-cache-flushes class)))
-       (setf (slot-value class 'class-precedence-list)
-             cpl))
-
-(defun update-slots (class cpl eslotds)
-       (multiple-value-bind (nlayout nwrapper-class-slots)
-           (compute-storage-info cpl eslotds)
-         
-         ;; If there is a change in the shape of the instances then the old class is now obsolete. 
-         (let* ((owrapper (class-wrapper class))
-                (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
-                (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
-                (nwrapper (cond ((null owrapper)
-                                 (make-wrapper class))
-                                ((and (equal nlayout olayout)
-                                      (not (iterate ((o (list-elements owrapper-class-slots))
-                                                     (n (list-elements nwrapper-class-slots)))
-                                                  (unless (eq (car o)
-                                                              (car n))
-                                                         (return t)))))
-                                 owrapper)
-                                (t 
-
-                                 ;; This will initialize the new wrapper to have the same state as
-                                 ;; the old wrapper.  We will then have to change that.  This may
-                                 ;; seem like wasted work (it is), but the spec requires that we
-                                 ;; call make-instances-obsolete. 
-                                   (make-instances-obsolete class)
-                                   (class-wrapper class)))))
-               (with-slots (wrapper no-of-instance-slots slots)
-                   class
-                 (setf no-of-instance-slots (length nlayout)
-                       slots eslotds (wrapper-instance-slots-layout nwrapper)
-                       nlayout
-                       (wrapper-class-slots nwrapper)
-                       nwrapper-class-slots wrapper nwrapper))
-               (dolist (eslotd eslotds)
-                   (setf (slotd-class eslotd)
-                         class)
-                   (setf (slotd-instance-index eslotd)
-                         (instance-slot-index nwrapper (slotd-name eslotd)))))))
-
-(defun compute-storage-info (cpl eslotds)
-       (let ((instance nil)
-             (class nil))
-            (dolist (eslotd eslotds)
-                (let ((alloc (slotd-allocation eslotd)))
-                     (cond ((eq alloc :instance)
-                            (push eslotd instance))
-                           ((classp alloc)
-                            (push eslotd class)))))
-            (values (compute-layout cpl instance)
-                   (compute-class-slots class))))
-
-(defun compute-layout (cpl instance-eslotds)
-       (let* ((names (gathering1 (collecting)
-                            (dolist (eslotd instance-eslotds)
-                                (when (eq (slotd-allocation eslotd)
-                                          :instance)
-                                    (gather1 (slotd-name eslotd))))))
-              (order nil))
-             (labels ((rwalk (tail)
-                             (when tail
-                                 (rwalk (cdr tail))
-                                 (dolist (ss (class-slots (car tail)))
-                                     (let ((n (slotd-name ss)))
-                                          (when (memq n names)
-                                              (setq order (cons n order)
-                                                    names
-                                                    (remove n names))))))))
-                    (rwalk cpl)
-                    (reverse (append names order)))))
-
-(defun compute-class-slots (eslotds)
-       (gathering1 (collecting)
-              (dolist (eslotd eslotds)
-                  (gather1 (assoc (slotd-name eslotd)
-                                  (class-slot-cells (slotd-allocation eslotd)))))))
-(defun update-dinits (class dinits)
-  (setf (plist-value class 'direct-default-initargs) 
-	(remove-invalid dinits (class-slots class))))
-
-(defun update-inits (class inits)
-       (setf (plist-value class 'default-initargs) 
-	     (remove-invalid inits (class-slots class))))
-
-;; bug: :default-initargs aren't updated with slots are removed, so
-;; update-inits removes initargs that don't have corresponding slots.
-
-(defun remove-invalid (inits slotds &aux (return nil))
-  (dolist (element inits)
-    (dolist (slotd slotds)
-      (if (member (car element) (slot-value slotd 'initargs))
-	  (pushnew element return))))
-  return)
-
-
-
-(defmethod compute-default-initargs ((class std-class)
-                                     cpl direct)
-       (labels ((walk (tail)
-                      (if (null tail)
-                          nil
-                          (let ((c (pop tail)))
-                               (append (if (eq c class)
-                                           direct
-                                           (class-direct-default-initargs c))
-                                      (walk tail))))))
-              (let ((initargs (walk cpl)))
-		(delete-duplicates initargs 
-				   :test #'eq :key #'car :from-end t))))
-
-
-;;; Protocols for constructing direct and effective slot definitions. 
-
-
-(defmethod direct-slot-definition-class ((class std-class)
-                                         initargs)
-       (declare (ignore initargs))
-       (find-class 'standard-direct-slot-definition))
-
-(defun make-direct-slotd (class initargs)
-       (let ((initargs (list* :class class initargs)))
-            (apply #'make-instance (direct-slot-definition-class class initargs)
-                   initargs)))
-
-
-;;; 
-
-
-(defmethod compute-slots ((class std-class)
-                          cpl class-direct-slots)
-       
-       ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once for each different slot
-       ;; name we find in our superclasses.  Each call receives the class and a list of the dslotds
-       ;; with that name. The list is in most-specific-first order. 
-       (let ((name-dslotds-alist nil))
-            (labels ((collect-one-class (dslotds)
-                            (dolist (d dslotds)
-                                (let* ((name (slotd-name d))
-                                       (entry (assq name name-dslotds-alist)))
-                                      (if entry
-                                          (push d (cdr entry))
-                                          (push (list name d)
-                                                name-dslotds-alist))))))
-                   (collect-one-class class-direct-slots)
-                   (dolist (c (cdr cpl))
-                       (collect-one-class (class-direct-slots c)))
-                   (mapcar #'(lambda (direct)
-                                    (compute-effective-slot-definition class (nreverse (cdr direct)))
-                                    )
-                          name-dslotds-alist))))
-
-(defmethod compute-effective-slot-definition ((class std-class)
-                                              dslotds)
-       (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
-              (class (effective-slot-definition-class class initargs)))
-             (apply #'make-instance class initargs)))
-
-(defmethod effective-slot-definition-class ((class std-class)
-                                            initargs)
-       (declare (ignore initargs))
-       (find-class 'standard-effective-slot-definition))
-
-(defmethod compute-effective-slot-definition-initargs ((class std-class)
-                                                       direct-slotds)
-       (let* ((name nil)
-              (initfunction nil)
-              (initform nil)
-              (initargs nil)
-              (allocation nil)
-              (type t)
-              (namep nil)
-              (initp nil)
-              (allocp nil))
-             (dolist (slotd direct-slotds)
-                 (when slotd
-                     (unless namep
-                         (setq name (slotd-name slotd)
-                               namep t))
-                     (unless initp
-                         (when (slotd-initfunction slotd)
-                             (setq initform (slotd-initform slotd)
-                                   initfunction
-                                   (slotd-initfunction slotd)
-                                   initp t)))
-                     (unless allocp
-                         (setq allocation (slotd-allocation slotd)
-                               allocp t))
-                     (setq initargs (append (slotd-initargs slotd)
-                                           initargs))
-                     (let ((slotd-type (slotd-type slotd)))
-                          (setq type (cond ((null type)
-                                            slotd-type)
-                                           ((subtypep type slotd-type)
-                                            type)
-                                           (t `(and ,type ,slotd-type)))))))
-             (list :name name :initform initform :initfunction initfunction :initargs initargs 
-                   :allocation allocation :type type)))
-
-
-;;; NOTE: For bootstrapping considerations, these can't use make-instance to make the method object.
-;;; They have to use make-a-method which is a specially bootstrapped mechanism for making standard
-;;; methods. 
-
-
-(defmethod add-reader-method ((class std-class)
-                              generic-function slot-name)
-       (let* ((name (class-name class))
-              (method (make-a-method 'standard-reader-method nil (list (or name 'standard-object))
-                             (list class)
-                             (make-reader-method-function class slot-name)
-                             "automatically generated reader method" slot-name)))
-             (add-method generic-function method)))
-
-(defmethod add-writer-method ((class std-class)
-                              generic-function slot-name)
-       (let* ((name (class-name class))
-              (method (make-a-method 'standard-writer-method nil (list 'new-value (or name
-                                                                                      
-                                                                                      '
-                                                                                      standard-object
-                                                                                      ))
-                             (list *the-class-t* class)
-                             (make-writer-method-function class slot-name)
-                             "automatically generated writer method" slot-name)))
-             (add-method generic-function method)))
-
-(defmethod remove-reader-method ((class std-class)
-                                 generic-function)
-       (let ((method (get-method generic-function nil (list class)
-                            nil)))
-            (when method (remove-method generic-function method))))
-
-(defmethod remove-writer-method ((class std-class)
-                                 generic-function)
-       (let ((method (get-method generic-function nil (list *the-class-t* class)
-                            nil)))
-            (when method (remove-method generic-function method))))
-
-
-;;; make-reader-method-function and make-write-method function are NOT part of the standard
-;;; protocol.  They are however useful, CLOS makes uses makes use of them internally and documents
-;;; them for CLOS users. *** This needs work to make type testing by the writer functions which ***
-;;; do type testing faster.  The idea would be to have one constructor *** for each possible type
-;;; test.  In order to do this it would be nice *** to have help from inform-type-system-about-class
-;;; and friends. *** There is a subtle bug here which is going to have to be fixed. *** Namely, the
-;;; simplistic use of the template has to be fixed.  We *** have to give the optimize-slot-value
-;;; method the user might have *** defined for this metclass a chance to run. 
-
-
-(defmethod make-reader-method-function ((class standard-class)
-                                        slot-name)
-       (make-std-reader-method-function slot-name))
-
-(defmethod make-writer-method-function ((class standard-class)
-                                        slot-name)
-       (make-std-writer-method-function slot-name))
-
-(defun make-std-reader-method-function (slot-name)
-       #'(lambda (instance)
-                (slot-value instance slot-name)))
-
-(defun make-std-writer-method-function (slot-name)
-       #'(lambda (nv instance)
-                (setf (slot-value instance slot-name)
-                      nv)))
-
-                                                             ; inform-type-system-about-class
-                                                             ; make-type-predicate 
-
-
-
-;;; These are NOT part of the standard protocol.  They are internal mechanism which CLOS uses to
-;;; *try* and tell the type system about class definitions. In a more fully integrated
-;;; implementation of CLOS, the type system would know about class objects and class names in a more
-;;; fundamental way and the mechanism used to inform the type system about new classes would be
-;;; different. 
-
-
-(defmethod inform-type-system-about-class ((class std-class)
-                                           name)
-       (let ((predicate-name (make-type-predicate-name name)))
-            (setf (symbol-function predicate-name)
-                  (make-type-predicate name))
-            (do-satisfies-deftype name predicate-name)
-	    (setf (gethash name lisp::*typep-hash-table*)
-		  predicate-name))) ;makes typep significantly faster...
-
-(defun make-type-predicate (name)
-       #'(lambda (x)
-                (not (null (memq (find-class name)
-                                 (cond ((std-instance-p x)
-                                        (class-precedence-list (std-instance-class x)))
-                                       ((fsc-instance-p x)
-                                        (class-precedence-list (fsc-instance-class x)))))))))
-
-
-;;; These 4 definitions appear here for bootstrapping reasons.  Logically, they should be in the
-;;; construct file.  For documentation purposes, a copy of these definitions appears in the
-;;; construct file.  If you change one of the definitions here, be sure to change the copy there. 
-
-
-(defvar *initialization-generic-functions* (list #'make-instance #'default-initargs 
-                                                 #'allocate-instance #'initialize-instance
-                                                 #'shared-initialize))
-
-(defmethod maybe-update-constructors ((generic-function generic-function)
-                                      (method method))
-       (when (memq generic-function *initialization-generic-functions*)
-           (labels ((recurse (class)
-                           (update-constructors class)
-                           (dolist (subclass (class-direct-subclasses class))
-                               (recurse subclass))))
-                  (when (classp (car (method-specializers method)))
-                      (recurse (car (method-specializers method)))))))
-
-(defmethod update-constructors ((class std-class))
-       (dolist (cons (class-constructors class))
-           (install-lazy-constructor-installer cons)))
-
-(defmethod update-constructors ((class class))
-       nil)
-
-(defmethod compatible-meta-class-change-p (class proto-new-class)
-       (eq (class-of class)
-           (class-of proto-new-class)))
-
-(defmethod check-super-metaclass-compatibility ((class t)
-                                                (new-super t))
-       (unless (eq (class-of class)
-                   (class-of new-super))
-           (error "The class ~S was specified as a~%super-class of the class ~S;~%~
-            but the meta-classes ~S and~%~S are incompatible." new-super class (class-of new-super)
-                  (class-of class))))
-
-
-;;; 
-
-
-(defun force-cache-flushes (class)
-       (let* ((owrapper (class-wrapper class))
-              (state (wrapper-state owrapper)))
-             
-             ;; We only need to do something if the state is still T.  If the state isn't T, it will
-             ;; be FLUSH or OBSOLETE, and both of those will already be doing what we want.  In
-             ;; particular, we must be sure we never change an OBSOLETE into a FLUSH since OBSOLETE
-             ;; means do what FLUSH does and then some. 
-             (when (eq state 't)
-                 (let ((nwrapper (make-wrapper class)))
-                      (setf (wrapper-instance-slots-layout nwrapper)
-                            (wrapper-instance-slots-layout owrapper))
-                      (setf (wrapper-class-slots nwrapper)
-                            (wrapper-class-slots owrapper))
-                      (without-interrupts (setf (slot-value class 'wrapper)
-                                                nwrapper)
-                             (invalidate-wrapper owrapper 'flush nwrapper))
-                      (update-constructors class)))))
-
-                                                             ; ??? ***
-
-
-(defun flush-cache-trap (owrapper nwrapper instance)
-       (declare (ignore owrapper))
-       (set-wrapper instance nwrapper))
-
-
-;;; make-instances-obsolete can be called by user code.  It will cause the next access to the
-;;; instance (as defined in 88-002R) to trap through the update-instance-for-redefined-class
-;;; mechanism. 
-
-
-(defmethod make-instances-obsolete ((class std-class))
-       (let ((owrapper (class-wrapper class))
-             (nwrapper (make-wrapper class)))
-            (setf (wrapper-instance-slots-layout nwrapper)
-                  (wrapper-instance-slots-layout owrapper))
-            (setf (wrapper-class-slots nwrapper)
-                  (wrapper-class-slots owrapper))
-            (without-interrupts (setf (slot-value class 'wrapper)
-                                      nwrapper)
-                   (invalidate-wrapper owrapper 'obsolete nwrapper)
-                   class)))
-
-(defmethod make-instances-obsolete ((class symbol))
-       (make-instances-obsolete (find-class class)))
-
-
-;;; obsolete-instance-trap is the internal trap that is called when we see an obsolete instance. 
-;;; The times when it is called are: - when the instance is involved in method lookup - when
-;;; attempting to access a slot of an instance It is not called by class-of, wrapper-of, or any of
-;;; the low-level instance access macros. Of course these times when it is called are an internal
-;;; implementation detail of CLOS and are not part of the documented description of when the obsolete
-;;; instance update happens.  The documented description is as it appears in 88-002R. This has to
-;;; return the new wrapper, so it counts on all the methods on obsolete-instance-trap-internal to
-;;; return the new wrapper.  It also does a little internal error checking to make sure that the
-;;; traps are only happening when they should, and that the trap methods are computing apropriate
-;;; new wrappers. 
-
-
-(defun obsolete-instance-trap (owrapper nwrapper instance)
-       
-       ;; local  --> local        transfer local  --> shared       discard local  -->  --         
-       ;; discard shared --> local        transfer shared --> shared       discard shared -->  --   
-       ;; discard --    --> local        add --    --> shared        -- 
-       (let* ((class (wrapper-class nwrapper))
-              (guts (allocate-instance class))
-                                                             ; ??? allocate-instance ???
-              (olayout (wrapper-instance-slots-layout owrapper))
-              (nlayout (wrapper-instance-slots-layout nwrapper))
-              (oslots (get-slots instance))
-              (nslots (get-slots guts))
-              (oclass-slots (wrapper-class-slots owrapper))
-              (added nil)
-              (discarded nil)
-              (plist nil))
-             
-             ;; Go through all the old local slots. 
-             (iterate ((name (list-elements olayout))
-                       (opos (interval :from 0)))
-                    (let ((npos (posq name nlayout)))
-                         (if npos
-                             (setf (svref nslots npos)
-                                   (svref oslots opos))
-                             (progn (push name discarded)
-                                    (unless (eq (svref oslots opos)
-                                                *slot-unbound*)
-                                        (setf (getf plist name)
-                                              (svref oslots opos)))))))
-             
-             ;; Go through all the old shared slots. 
-             (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
-                    (let ((name (car oclass-slot-and-val))
-                          (val (cdr oclass-slot-and-val)))
-                         (let ((npos (posq name nlayout)))
-                              (if npos
-                                  (setf (svref nslots npos)
-                                        (cdr oclass-slot-and-val))
-                                  (progn (push name discarded)
-                                         (unless (eq val *slot-unbound*)
-                                             (setf (getf plist name)
-                                                   val)))))))
-             
-             ;; Go through all the new local slots to compute the added slots. 
-             (dolist (nlocal nlayout)
-                 (unless (or (memq nlocal olayout)
-                             (assq nlocal oclass-slots))
-                        (push nlocal added)))
-             (without-interrupts (set-wrapper instance nwrapper)
-                    (set-slots instance nslots))
-             (update-instance-for-redefined-class instance added discarded plist)
-             nwrapper))
-
-
-;;; 
-
-
-(defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc)
-       `(let* ((old-class (class-of instance))
-               (copy (,alloc old-class))
-               (guts (,alloc new-class))
-               (new-wrapper (,wrapper-fetcher guts))
-               (old-wrapper (class-wrapper old-class))
-               (old-layout (wrapper-instance-slots-layout old-wrapper))
-               (new-layout (wrapper-instance-slots-layout new-wrapper))
-               (old-slots (,slots-fetcher instance))
-               (new-slots (,slots-fetcher guts))
-               (old-class-slots (wrapper-class-slots old-wrapper)))
-              
-              ;; "The values of local slots specified by both the class Cto and Cfrom are retained. 
-              ;; If such a local slot was unbound, it remains unbound." 
-              (iterate ((new-slot (list-elements new-layout))
-                        (new-position (interval :from 0)))
-                     (let ((old-position (position new-slot old-layout :test #'eq)))
-                          (when old-position
-                              (setf (svref new-slots new-position)
-                                    (svref old-slots old-position)))))
-              
-              ;; "The values of slots specified as shared in the class Cfrom and as local in the
-              ;; class Cto are retained." 
-              (iterate ((slot-and-val (list-elements old-class-slots)))
-                     (let ((position (position (car slot-and-val)
-                                            new-layout :test #'eq)))
-                          (when position
-                              (setf (svref new-slots position)
-                                    (cdr slot-and-val)))))
-              
-              ;; Make the copy point to the old instance's storage, and make the old instance point
-              ;; to the new storage. 
-              (without-interrupts (setf (,slots-fetcher copy)
-                                        old-slots)
-                     (setf (,wrapper-fetcher instance)
-                           new-wrapper)
-                     (setf (,slots-fetcher instance)
-                           new-slots))
-              (update-instance-for-different-class copy instance)
-              instance))
-
-(defmethod change-class ((instance standard-object)
-                         (new-class standard-class))
-       (unless (std-instance-p instance)
-           (error "Can't change the class of ~S to ~S~@
-            because it isn't already an instance with metaclass~%~S." instance new-class 
-                  'standard-class))
-       (change-class-internal std-instance-wrapper std-instance-slots allocate-instance))
-
-(defmethod change-class ((instance standard-object)
-                         (new-class funcallable-standard-class))
-       (unless (fsc-instance-p instance)
-           (error "Can't change the class of ~S to ~S~@
-            because it isn't already an instance with metaclass~%~S." instance new-class 
-                  'funcallable-standard-class))
-       (change-class-internal fsc-instance-wrapper fsc-instance-slots allocate-instance))
-
-(defmethod change-class ((instance t)
-                         (new-class-name symbol))
-       (change-class instance (find-class new-class-name)))
-
-
-;;; The metaclass BUILT-IN-CLASS This metaclass is something of a weird creature.  By this point,
-;;; all instances of it which will exist have been created, and no instance is ever created by
-;;; calling MAKE-INSTANCE. But, there are other parts of the protcol we must follow and those
-;;; definitions appear here. 
-
-
-(defmethod shared-initialize :before ((class built-in-class)
-                                      slot-names &rest initargs)
-       (declare (ignore slot-names))
-       (error "Attempt to initialize or reinitialize a built in class."))
-
-(defmethod class-direct-slots ((class built-in-class))
-       nil)
-
-(defmethod class-slots ((class built-in-class))
-       nil)
-
-(defmethod class-direct-default-initargs ((class built-in-class))
-       nil)
-
-(defmethod class-default-initargs ((class built-in-class))
-       nil)
-
-(defmethod check-super-metaclass-compatibility ((c class)
-                                                (s built-in-class))
-       (or (eq s *the-class-t*)
-           (error "~S cannot have ~S as a super.~%~
-              The class ~S is the only built in class that can be a~%~
-              superclass of a standard class." c s *the-class-t*)))
-
-
-;;; 
-
-
-(defmethod check-super-metaclass-compatibility ((c std-class)
-                                                (f forward-referenced-class))
-       't)
-
-
-;;; 
-
-
-(defmethod add-dependent ((metaobject dependent-update-mixin)
-                          dependent)
-       (pushnew dependent (plist-value metaobject 'dependents)))
-
-(defmethod remove-dependent ((metaobject dependent-update-mixin)
-                             dependent)
-       (setf (plist-value metaobject 'dependents)
-             (delete dependent (plist-value metaobject 'dependents))))
-
-(defmethod map-dependents ((metaobject dependent-update-mixin)
-                           function)
-       (dolist (dependent (plist-value metaobject 'dependents))
-           (funcall function dependent)))
diff --git a/obsolete/clos/2.0/test.lisp b/obsolete/clos/2.0/test.lisp
deleted file mode 100644
index 74c921f2..00000000
--- a/obsolete/clos/2.0/test.lisp
+++ /dev/null
@@ -1,2880 +0,0 @@
-;;;-*- Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;; 
-;;; Testing code.
-;;;
-
-(in-package :clos)
-
-;;; Because CommonLoops runs in itself so much, the notion of a test file for
-;;; it is kind of weird.
-;;;
-;;; If all of CLOS loads then many of the tests in this file (particularly
-;;; those at the beginning) are sure to work.  Those tests exists primarily
-;;; to help debug things when low-level changes are made to CLOS, or when a
-;;; particular port customizes low-level code.
-;;;
-;;; Some of the other tests are "real" in the sense that they test things
-;;; that CLOS itself does not use, so might be broken.
-;;; 
-;;; NOTE:
-;;;   The tests in this file do not appear in random order!  They
-;;;   depend on state  which has already been set up in order to run.
-;;;
-
-(defmacro do-test (name cleanups &body body)
-  `(let ((do-test-failed nil))
-     (catch 'do-test
-       (format t "~&Testing ~A..." ,name)
-;       (cleanup-do-test ',cleanups)
-       (block do-test ,@body)
-       (if do-test-failed
-           (format t "~&FAILED!")
-           (format t "OK")))))
-  
-(defmacro do-test-error (fatal string &rest args)
-  `(progn (terpri)
-          (setq do-test-failed t)
-          (format t ,string ,@args)
-          (when ,fatal (return-from do-test nil))))
-
-(defun cleanup-do-test (cleanups)
-  (dolist (cleanup cleanups)
-    (ecase (car cleanup)
-      (:classes
-        (dolist (c (cdr cleanup))
-          (let ((class (find-class c 'nil)))
-            (when class
-              (dolist (super (slot-value class 'direct-superclasses))
-                (setf (slot-value class 'direct-subclasses)
-                      (remove class (slot-value class 'direct-subclasses))))
-              (setf (find-class c) nil)))))
-      (:functions
-        (dolist (f (cdr cleanup))
-          (fmakunbound f)))
-      (:setf-generic-functions
-        (dolist (f (cdr cleanup))
-          (fmakunbound (get-setf-function-name f))))
-      (:variables
-        (dolist (v (cdr cleanup))
-          (makunbound v))))))
-
-#-(or KCL IBCL :Coral GCLisp)
-(eval-when (eval)
-  (compile 'do-test)
-  (compile 'do-test-error)
-  (compile 'cleanup-do-test))
-
-  ;;   
-;;;;;; 
-  ;;   
-
-(do-test "types for early classes"
-         ()
-  (dolist (x '(standard-object standard-class standard-slot-definition))
-    (or (typep (make-instance x) x)
-        (do-test-error () "instance of ~S not of type ~S??" x x))))
-
-
-(do-test "types for late classes"
-         ()
-  (dolist (x '(standard-method standard-generic-function))
-    (or (typep (make-instance x) x)
-        (do-test-error () "~&instance of ~S not of type ~S??" x x))))
-
-(defvar *built-in-class-tests*
-        '((ARRAY (MAKE-ARRAY '(10 10)))
-          (BIT-VECTOR (MAKE-ARRAY 10 :ELEMENT-TYPE 'BIT))
-          (CHARACTER #\a)
-          (COMPLEX #C(1 2))
-          (CONS (LIST 1 2 3))
-          (FLOAT 1.3)
-          (INTEGER 1)
-         ;LIST                   abstract super of cons, null
-          (NULL NIL)
-         ;NUMBER                 abstract super of complex, float, rational
-          (RATIO 1/2)
-         ;RATIONAL               abstract super of ratio, integer
-         ;SEQUENCE               abstract super of list, vector
-          (STRING "foo")
-          (SYMBOL 'FOO)
-          (VECTOR (VECTOR 1 2 3))))
-
-(do-test "built-in-class-of"
-         ()
-  (let ((lostp nil))
-    (dolist (tst *built-in-class-tests*)
-      (unless (eq (find-class (car tst) 't)
-                  (class-of (eval (cadr tst))))
-        (do-test-error ()
-                       "~&class-of ~S was ~A not ~A~%"
-                       (cadr tst)
-                       (class-name (class-of (eval (cadr tst))))
-                       (car tst))
-        (setq lostp t)))
-    (not lostp)))
-
-(do-test "existence of generic-functions for accessors of early classes"
-         ()
-  ;; Because accessors are done with add-method, and this has to be done
-  ;; specially for early classes it is worth testing to make sure that
-  ;; the generic-functions got created for the accessor of early classes.
-  ;;
-  ;; Of course CLOS wouldn't have loaded if most of these didn't exist,
-  ;; but what the hell.
-  (dolist (class '(standard-class
-                   standard-slot-definition
-                   standard-generic-function
-                   standard-method))
-    (dolist (slotd (class-slots (find-class class)))
-      (dolist (rea (slotd-readers slotd))
-        (unless (and (gboundp rea)
-                     (generic-function-p (gdefinition rea)))
-          (do-test-error () "~S isn't a generic function" rea)))
-      (dolist (wri (slotd-writers slotd))
-        (unless (and (gboundp wri)
-                     (generic-function-p (gdefinition wri)))
-          (do-test-error () "~S isn't a generic function" wri))))))
-
-(do-test "early reader/writer methods are appropriate class"
-         ()
-  ;; Because accessors are done with add-method, and this has to be done
-  ;; specially for early classes it is worth testing to make sure that
-  ;; the generic-functions got created for the accessor of early classes.
-  ;;
-  ;; Of course CLOS wouldn't have loaded if most of these didn't exist,
-  ;; but what the hell.
-  (dolist (class '(standard-class
-                   standard-slot-definition
-                   standard-generic-function
-                   standard-method))
-    (let ((class (find-class 'standard-class)))
-      (flet ((check-reader (gf)
-               (let ((reader (get-method (gdefinition gf)
-                                         ()
-                                         (list class))))
-                 (unless (typep reader 'standard-reader-method)
-                   (do-test-error () "~S isn't a READER method" reader))))
-             (check-writer (gf)
-               (let ((writer (get-method (gdefinition gf)
-                                         ()
-                                         (list (find-class 't) class))))
-                 (unless (typep writer 'standard-writer-method)
-                   (do-test-error () "~S isn't a WRITER method" writer)))))
-        (dolist (slotd (class-direct-slots class))
-          (dolist (rea (slotd-readers slotd))
-            (check-reader rea))   
-          (dolist (wri (slotd-writers slotd))
-            (check-writer wri)))))))
-
-(do-test "typep works for standard-classes"
-         ((:classes foo1 foo2 bar))
-
-  (defclass foo1 () ())
-  (defclass foo2 (foo1) ())
-  (defclass bar () ())
-
-  (let ((f1 (make-instance 'foo1))
-        (f2 (make-instance 'foo2)))
-    (or (typep f1 'foo1)
-        (do-test-error
-          () "an instance of foo1 isn't subtypep of foo1"))
-    (or (not (typep f1 'foo2))
-        (do-test-error
-          () "an instance of foo1 is suptypep of a subclass of foo1"))
-    (or (not (typep f1 'bar))
-        (do-test-error
-          () "an instance of foo1 is subtypep of an unrelated class"))
-    (or (typep f2 'foo1)
-        (do-test-error
-          () "an instance of foo2 is not subtypep of a super-class of foo2"))
-    ))
-
-(do-test "accessors and readers should NOT be inherited"
-         ((:classes foo bar)
-          (:functions foo-x foo-y))
-
-  (defclass foo ()
-       ((x :accessor foo-x)
-        (y :reader foo-y)))
-
-  (fmakunbound 'foo-x)
-  (fmakunbound 'foo-y)
-
-  (defclass bar (foo)
-       (x y))
-
-  (and (fboundp 'foo-x) (do-test-error () "foo-x got inherited?"))
-  (and (fboundp 'foo-y) (do-test-error () "foo-x got inherited?")))
-
-(do-test ":accessor and :reader methods go away"
-         ((:classes foo)
-          (:functions foo-x foo-y)
-          (:setf-generic-functions foo-x foo-y))  
-
-  (defclass foo () ((x :accessor foo-x) (y :reader foo-y)))
-
-  (unless (and (fboundp 'foo-x)
-               (fboundp 'foo-y))
-    (do-test-error t "accessors didn't even get generated?"))
-
-  (defclass foo () (x y))
-
-  (flet ((methods (x)
-           (generic-function-methods (symbol-function 'foo-y))))
-    
-    (and (methods 'foo-x)
-         (do-test-error () "~&reader method for foo-x not removed"))
-    (and (methods 'foo-y)
-         (do-test-error () "~&reader method for foo-y not removed"))
-    (and (methods (get-setf-function-name 'foo-y))
-         (do-test-error () "~&writer method for foo-y not removed"))
-    t))
-
-
-(defclass test-class-1 ()
-     ((x :initform nil :accessor test-class-1-x :initarg :x)
-      (y :initform nil :accessor test-class-1-y :initarg :y)))
-
-(do-test "Simple with-accessors test -- does not really exercise the walker."
-         ((:functions foo bar))
-
-  (defmethod foo ((obj test-class-1))
-    (with-accessors ((x test-class-1-x)
-                     (y test-class-1-y))
-                    obj
-      (list x y)))
-
-  (defmethod bar ((obj test-class-1))
-    (with-accessors ((x test-class-1-x)
-                     (y test-class-1-y))
-                obj
-      (setq x 1
-            y 2)))
-
-  (or (and (equal '(nil nil) (foo (make-instance 'test-class-1)))
-           (equal '(1 2) (foo (make-instance 'test-class-1 :x 1 :y 2))))
-      (do-test-error () "FOO (the one that reads) failed"))
-
-  (or (let ((foo (make-instance 'test-class-1)))
-        (bar foo)
-        (or (and (equal (slot-value foo 'x) 1)
-                 (equal (slot-value foo 'y) 2))
-            (do-test-error () "BAR (the one that writes) failed")))))
-
-(do-test "Simple with-slots test -- does not really exercise the walker."
-         ((:functions foo bar))
-  
-  (defmethod foo ((obj test-class-1))
-    (with-slots (x y)
-                obj
-      (list x y)))
-
-  (defmethod bar ((obj test-class-1))
-    (with-slots ((obj-x x)
-                 (obj-y y))
-                obj
-      (setq obj-x 1
-            obj-y 2)))
-
-  (or (and (equal '(nil nil) (foo (make-instance 'test-class-1)))
-           (equal '(1 2) (foo (make-instance 'test-class-1 :x 1 :y 2))))
-      (do-test-error () "FOO (the one that reads) failed"))
-
-  (or (let ((foo (make-instance 'test-class-1)))
-        (bar foo)
-        (or (and (equal (slot-value foo 'x) 1)
-                 (equal (slot-value foo 'y) 2))
-            (do-test-error () "BAR (the one that writes) failed")))))
-
-  ;;   
-;;;;;; things that bug fixes prompted.
-  ;;   
-
-
-(do-test "with-slots inside of lexical closures"
-         ((:functions frog barg))
-  ;; 6/20/86
-  ;; The walker was confused about what (FUNCTION (LAMBDA ..)) meant.  It
-  ;; didn't walk inside there.  Its sort of surprising this didn't get
-  ;; caught sooner.
-
-  (defun frog (fn foos)
-    (and foos (cons (funcall fn (car foos)) (frog fn (cdr foos)))))
-
-  (defun barg ()
-    (let ((the-test-class (make-instance 'test-class-1 :x 0 :y 3)))
-      (with-slots (x y)
-                  the-test-class
-        (frog #'(lambda (foo) (incf x) (decf y))
-             (make-list 3)))))
-
-  (or (equal (barg) '(2 1 0))
-      (do-test-error t "lost")))
-
-(do-test "redefinition of default method has proper effect"
-         ((:functions foo))
-  ;; 5/26/86
-  ;; This was caused because the hair for trying to avoid making a
-  ;; new discriminating function didn't know that changing the default
-  ;; method was a reason to make a new discriminating function.  Fixed
-  ;; by always making a new discriminating function when a method is
-  ;; added or removed.  The template stuff should keep this from being
-  ;; expensive.
-
-  (defmethod foo ((x standard-class)) 'standard-class)
-  (defmethod foo (x) 'default)
-  (defmethod foo (x) 'new-default)
-
-  (or (eq (foo nil) 'new-default)
-      (do-test-error t "lost")))
-
-
-
-(defvar *call-next-method-test-object* (make-instance 'standard-object))
-
-(do-test "call-next-method passes original arguments"
-         ((:functions foo))
-  ;; 2/4/88
-  ;; The spec says that call-next-method must pass the original arguments
-  ;; to call-next-method when none are supplied.  This tests that.
-
-  (defmethod foo ((x t))
-    (unless (eq x *call-next-method-test-object*)
-      (do-test-error t "got wrong value")))
-
-  (defmethod foo ((x standard-object))
-    (setq x nil)
-    (call-next-method))
-
-  (foo *call-next-method-test-object*)
-
-  )
-
-(do-test "call-next-method closures pass original arguments - 1"
-         ((:functions foo))
-  ;; 2/4/88
-  ;; call-next-method must pass the original arguments even when it is
-  ;; returned as a lexical closure with indefinite extent
-
-  (defmethod foo ((x t))
-    (unless (eq x *call-next-method-test-object*)
-      (do-test-error t "got wrong value")))
-
-  (defmethod foo ((x standard-object))
-    (setq x nil)
-    #'call-next-method)
-
-  (funcall (foo *call-next-method-test-object*))
-
-  )
-
-(do-test "call-next-method closures pass original arguments - 2"
-         ((:functions foo))
-  ;; 2/4/88
-  ;; call-next-method must pass the original arguments even when it is
-  ;; returned as a lexical closure with indefinite extent
-
-  (defmethod foo ((x t))
-    (unless (eq x *call-next-method-test-object*)
-      (do-test-error t "got wrong value")))
-
-  (defmethod foo ((x standard-object))
-    #'(lambda ()
-        (setq x nil)
-        (call-next-method)))
-
-  (funcall (foo *call-next-method-test-object*))
-
-  )
-
-(do-test "call-next-method passes supplied arguments"
-         ((:functions foo))
-  ;; 2/4/88
-  ;; The spec says that call-next-method must pass the original arguments
-  ;; to call-next-method when none are supplied.  This tests that.
-
-  (defmethod foo ((x t))
-    (unless (eq x *call-next-method-test-object*)
-      (do-test-error t "got wrong value")))
-
-  (defmethod foo ((x standard-object))
-    (call-next-method *call-next-method-test-object*))
-
-  (foo (make-instance 'standard-object))
-
-  )
-
-(do-test "call-next-method closures pass supplied arguments - 1"
-         ((:functions foo))
-  ;; 2/4/88
-  ;; call-next-method must pass the original arguments even when it is
-  ;; returned as a lexical closure with indefinite extent
-
-  (defmethod foo ((x t))
-    (unless (eq x *call-next-method-test-object*)
-      (do-test-error t "got wrong value")))
-
-  (defmethod foo ((x standard-object))
-    #'call-next-method)
-
-  (funcall (foo (make-instance 'standard-object)) *call-next-method-test-object*)
-
-  )
-
-(do-test "call-next-method closures pass supplied arguments - 2"
-         ((:functions foo))
-  ;; 2/4/88
-  ;; call-next-method must pass the original arguments even when it is
-  ;; returned as a lexical closure with indefinite extent
-
-  (defmethod foo ((x t))
-    (unless (eq x *call-next-method-test-object*)
-      (do-test-error t "got wrong value")))
-
-  (defmethod foo ((x standard-object))
-    #'(lambda (x)
-        (call-next-method x)))
-
-  (funcall (foo (make-instance 'standard-object)) 
-	   *call-next-method-test-object*))
-
-
-(do-test "call-next-method inside of default value form of &optional"
-         ((:functions foo))
-  ;; 5/3/88
-  ;; call-next-method must work inside the default value forms of the
-  ;; method's &mumble arguments.
-
-  (defmethod foo1 ((x t) &optional y)
-    (declare (ignore y))
-    *call-next-method-test-object*)
-
-  (defmethod foo1 ((x standard-object) &optional (y (call-next-method)))
-    (list x y))
-
-  (let ((object (make-instance 'standard-object)))
-    (unless (equal (foo1 object) (list object *call-next-method-test-object*))
-      (do-test-error t "Got wrong value"))))
-
-(do-test "specifying :type when superclass doesn't"
-         ((:classes foo bar))
-  ;; 3/23/88
-  ;; if a suclass specifies the :type slot option for a slot for which no
-  ;; superclass specifies a type then the inheritance rule is just to take
-  ;; the type specified by the subclass
-  
-  (defclass foo ()
-       ((x)))
-
-  (defclass bar (foo)
-       ((x :type number))))
-
-
-(do-test "Leaky next methods"
-         ((:functions foo bar))
-  ;; 6/23/88
-  ;; Since I use special variables to communicate the next methods info,
-  ;; there can be bugs which cause them to leak to the wrong method.
-
-  (defmethod foo ((x standard-class))
-    (bar x))
-
-  (defmethod foo ((x class))
-    (call-next-method))
-
-  (defmethod foo ((x t))
-    t)
-
-  (defmethod bar ((x standard-class))
-    (next-method-p))
-
-  (unless (foo (find-class 't))
-    (do-test-error nil "Method leaked.")))
-
-
-;;;
-;;; some simple tests for initialization protocols
-;;; 8/5/88
-;;; 
-(proclaim '(special x-initform-fired y-initform-fired z-initform-fired))
-
-(defclass initialization-test-1 ()
-     ((x :initform (setq x-initform-fired 'x-initform))
-      (y :initform (setq y-initform-fired 'y-initform))
-      (z :initform (setq z-initform-fired 'z-initform))))
-
-(defclass initialization-test-2 ()
-     ((x :initform (setq x-initform-fired 'x-initform) :initarg :x)
-      (y :initform (setq y-initform-fired 'y-initform) :initarg :y)
-      (z :initform (setq z-initform-fired 'z-initform) :initarg :z)))
-
-(defclass initialization-test-3 ()
-     ((x :initform (setq x-initform-fired 'x-initform) :initarg :x)
-      (y :initform (setq y-initform-fired 'y-initform) :initarg :y)
-      (z :initform (setq z-initform-fired 'z-initform) :initarg :z))
-  (:default-initargs :x 'x-default))
-
-(defclass initalization-test-4 (initialization-test-3)
-     ()
-  (:default-initargs :z 'z-default))
-
-(defclass initialization-test-5 (initialization-test-4)
-     ()
-  (:default-initargs :x 'x-default-from-5))
-      
-(do-test "shared-initialize with T argument and no initargs"
-         ()
-
-  (let (x-initform-fired y-initform-fired z-initform-fired)
-    (let* ((class (find-class 'initialization-test-1))
-           (instance (allocate-instance class)))
-
-      (shared-initialize instance 't)
-
-      (unless x-initform-fired (do-test-error nil "x initform not evaluated"))
-      (unless y-initform-fired (do-test-error nil "y initform not evaluated"))
-      (unless z-initform-fired (do-test-error nil "z initform not evaluated"))
-      
-      (unless (eq (slot-value instance 'x) 'x-initform)
-        (do-test-error nil "Value of X doesn't match initform"))
-      (unless (eq (slot-value instance 'y) 'y-initform)
-        (do-test-error nil "Value of X doesn't match initform"))
-      (unless (eq (slot-value instance 'z) 'z-initform)
-        (do-test-error nil "Value of X doesn't match initform"))
-
-      )))
-
-(do-test "shared-initialize with T argument and initargs"
-         ()
-
-  (let (x-initform-fired y-initform-fired z-initform-fired)
-    (let* ((class (find-class 'initialization-test-2))
-           (instance (allocate-instance class)))
-
-      (shared-initialize instance 't :y 'y-initarg)
-
-      (unless x-initform-fired
-        (do-test-error nil "x initform not evaluated"))
-      (unless (not y-initform-fired)
-        (do-test-error nil "y initform was evaluated"))
-      (unless z-initform-fired
-        (do-test-error nil "z initform not evaluated"))
-      
-      (unless (eq (slot-value instance 'x) 'x-initform)
-        (do-test-error nil "Value of X doesn't match initform"))
-      (unless (eq (slot-value instance 'y) 'y-initarg)
-        (do-test-error nil "Value of X doesn't match initform"))
-      (unless (eq (slot-value instance 'z) 'z-initform)
-        (do-test-error nil "Value of X doesn't match initform"))
-
-      )))
-
-(do-test "initialization arguments rules test"
-         ((:classes foo bar))
-
-  (defclass foo ()
-       ((x :initarg a)))
-
-  (defclass bar (foo)
-       ((x :initarg b))
-    (:default-initargs a 1 b 2))
-
-  (unless (and (equal (default-initargs (find-class 'bar) '())
-                      '(b 2 a 1))
-               (equal (default-initargs (find-class 'bar) '(a 3))
-                      '(a 3 b 2))
-               (equal (default-initargs (find-class 'bar) '(b 4))
-                      '(b 4 a 1))
-               (equal (default-initargs (find-class 'bar) '(a 1 a 2))
-                      '(a 1 a 2 b 2)))
-    (do-test-error nil "default-initargs got wrong value"))
-
-  (unless (and (eq (slot-value (make-instance 'bar) 'x) 1)
-               (eq (slot-value (make-instance 'bar 'a 3) 'x) 3)
-               (eq (slot-value (make-instance 'bar 'b 4) 'x) 4)
-               (eq (slot-value (make-instance 'bar 'a 1 'a 2) 'x) 1))
-    (do-test-error nil "initialization in make-instance failed"))
-
-  )
-
-
-#| testing a pair of lists for equality bogus, '(a b c) <> '(b c a)
-
-(do-test "more tests for initialization arguments rules"
-         ((:classes foo fie bar baz))
-
-  (defclass foo ()
-       ((a :initform 'initform-foo-a)
-        (b :initarg :foo-b)
-        (c :initform 'initform-foo-c)
-        (d :initarg :foo-d))
-    (:default-initargs :foo-b 'initarg-foo-b
-                       :foo-d 'initarg-foo-d))
-  (defclass fie (foo)
-       ((a :initform 'initform-fie-a)
-        (b :initarg :fie-b)
-        (c :initform 'initform-fie-c :allocation :class)
-        (d :initarg :fie-d :allocation :class))
-    (:default-initargs :fie-b 'initarg-fie-b
-                       :fie-d 'initarg-fie-d))
-  (defclass bar (foo)
-       ((a :initform 'initform-bar-a)
-        (b :initarg :bar-b)
-        (c :initform 'initform-bar-c)
-        (d :initarg :bar-d))
-    (:default-initargs :bar-b 'initarg-bar-b
-                       :bar-d 'initarg-bar-d))
-  (defclass baz (fie bar)
-       ((a :initform 'initform-baz-a)
-        (b :initarg :baz-b)
-        (c :initform 'initform-baz-c)
-        (d :initarg :baz-d))
-    (:default-initargs :baz-b 'initarg-baz-b
-                       :baz-d 'initarg-baz-d))
-
-  (unless (and (equal (default-initargs (find-class 'foo) ())
-                      '(:foo-d initarg-foo-d 
-			:foo-b initarg-foo-b))
-               (equal (default-initargs (find-class 'fie) ())
-                      '(:fie-b initarg-fie-b
-                        :fie-d initarg-fie-d
-                        :foo-b initarg-foo-b
-                        :foo-d initarg-foo-d))
-               (equal (default-initargs (find-class 'bar) ())
-                      '(:bar-b initarg-bar-b
-                        :bar-d initarg-bar-d
-                        :foo-b initarg-foo-b
-                        :foo-d initarg-foo-d))
-               (equal (default-initargs (find-class 'baz) ())
-                      '(:baz-b initarg-baz-b
-                        :baz-d initarg-baz-d
-                        :fie-b initarg-fie-b
-                        :fie-d initarg-fie-d
-                        :bar-b initarg-bar-b
-                        :bar-d initarg-bar-d
-                        :foo-b initarg-foo-b
-                        :foo-d initarg-foo-d)))
-    (do-test-error nil "default-initargs got wrong value"))
-  )
-|#
-(do-test "initialization protocols"
-         ((:classes foo))
-
-  (let ((initform-for-x 'initform-x)
-        (initform-for-y 'initform-y)
-        (initform-for-z 'initform-z)
-        (default-initarg-for-x 'default-initarg-x)
-        (initarg-supplied-for-z 'initarg-z)
-        instance-of-foo)
-    
-    (defclass foo ()
-         ((x :initform initform-for-x :initarg :x)
-          (y :initform initform-for-y :initarg :y)
-          (z :initform initform-for-z :initarg :z))
-      (:default-initargs :x default-initarg-for-x))
-
-    (setq instance-of-foo (make-instance 'foo :z initarg-supplied-for-z))
-
-    (unless (and (eq (slot-value instance-of-foo 'x)
-                     default-initarg-for-x)
-                 (eq (slot-value instance-of-foo 'y)
-                     initform-for-y)
-                 (eq (slot-value instance-of-foo 'z)
-                     initarg-supplied-for-z))
-      (do-test-error nil "initialization failed"))
-
-    (setq instance-of-foo
-          (reinitialize-instance (allocate-instance (find-class 'foo))
-                                 :z initarg-supplied-for-z))
-
-    (unless (and (not (slot-boundp instance-of-foo 'x))
-                 (not (slot-boundp instance-of-foo 'y))
-                 (eq (slot-value instance-of-foo 'z)
-                     initarg-supplied-for-z))
-      (do-test-error nil "initialization failed")))
-
-  )
-
-(do-test "update-instance-for-different-class"
-         ((:classes foo bar))
-
-  (let ((initform-for-x 'initform-x)
-        (initform-for-y 'initform-y)
-        (default-initarg-for-x 'default-initarg-x)
-        (initform-for-z 'initform-z)
-        (initform-for-u 'initform-u)
-        (initform-for-v 'initform-v)
-        (default-initarg-for-z 'default-intiarg-z)
-        (initarg-supplied-for-v 'initarg-v)
-        instance-of-foo
-        instance-of-bar)
-
-    (defclass foo ()
-         ((x :initform initform-for-x :initarg :x)
-          (y :initform initform-for-y :initarg :y))
-      (:default-initargs :x default-initarg-for-x))
-
-    (defclass bar ()
-         ((x :initform initform-for-x :initarg :x)
-          (y :initform initform-for-y :initarg :y)
-          (z :initform initform-for-z :initarg :z)
-          (u :initform initform-for-u :initarg :u)
-          (v :initform initform-for-v :initarg :v))
-      (:default-initargs :z default-initarg-for-z))
-
-    (setq instance-of-foo (make-instance 'foo))
-    (setq instance-of-bar (allocate-instance (find-class 'bar)))
-    (update-instance-for-different-class instance-of-foo instance-of-bar
-                                         :v initarg-supplied-for-v)
-    (unless (and (not (slot-boundp instance-of-bar 'x))
-                 (not (slot-boundp instance-of-bar 'y))
-                 (eq (slot-value instance-of-bar 'z) initform-for-z)
-                 (eq (slot-value instance-of-bar 'u) initform-for-u)
-                 (eq (slot-value instance-of-bar 'v) initarg-supplied-for-v))
-      (do-test-error nil "initialization failed"))))
-
-(do-test "only needed forms should be evaluated in initializing instances"
-         ((:classes foo))
-
-  (defclass foo ()
-    ((x :initform (do-test-error nil "x initform was evaluated")
-        :initarg :x)
-     (y :initform (do-test-error nil "y initform was evaluated")
-        :initarg :y)
-     (z :initform (do-test-error nil "z initform was evaluated")
-        :initarg :z))
-    (:default-initargs :y 1
-                       :z (do-test-error nil "z default initarg was evaluated")))
-
-  (make-instance 'foo :x 1 :z 1))
-
-
-;;;
-;;; We need to put these class defenitions in top level.
-;;;
-
-(defclass class-for-testing-change-class-1 ()
-  ((x :initform 'x :accessor class-1-x)
-   (y :initform 'y :accessor class-1-y)))
-
-(defclass class-for-testing-change-class-2 ()
-  ((a :initform 'a :accessor class-2-a)
-   (b :initform 'b :accessor class-2-b)))
-
-(do-test "update-instance-for-different-class/change-class"
-         ()
-
-  (defmethod update-instance-for-different-class
-             ((previous class-for-testing-change-class-1)
-              (current class-for-testing-change-class-2)
-              &rest initargs)
-    (declare (ignore initargs))
-    (setf (class-2-a current) (class-1-x previous))
-    (setf (class-2-b current) (class-1-y previous)))
-
-  (let ((f1 (make-instance 'class-for-testing-change-class-1))
-        (f2 (make-instance 'class-for-testing-change-class-1)))
-    (change-class f1 (find-class 'class-for-testing-change-class-2))
-    (unless (and (eq (class-2-a f1) (class-1-x f2))
-                 (eq (class-2-b f1) (class-1-y f2)))
-      (do-test-error nil "change class failed")))
-  )
-
-(cleanup-do-test '((:classes class-for-testing-redefined-class)
-                   (:functions test-x test-y test-a)
-                   (:setf-generic-functions class-x class-y)))
-                    
-(let (foo)
-  (defclass class-for-testing-redefined-class ()
-    ((x :initform 'x :accessor test-x)
-     (y :initform 'y :accessor test-y)))
-
-  (setq foo (make-instance 'class-for-testing-redefined-class))
-
-  (defclass class-for-testing-redefined-class ()
-    ((a :initform 0 :accessor test-a)
-     (y :initform 1 :accessor test-y)))
-
-  (do-test "update-instance-for-redefined-class/make-instances-obsolete(1)"
-        ()
-    (unless (and (eq (test-a foo) 0)
-                 (eq (test-y foo) 'y))
-      (do-test-error nil "default behavior failed"))))
-
-(cleanup-do-test '((:classes x-y-pos)
-                   (:functions pos-x pos-y pos-rho pos-theta)
-                   (:setf-generic-functions pos-x pos-y pos-rho pos-theta)))
-
-(let (old-pos new-pos)
-
-  (defclass x-y-pos ()
-    ((x :initform 3 :accessor pos-x)
-     (y :initform 4 :accessor pos-y)))
-  
-  (setq old-pos (make-instance 'x-y-pos))
-  
-  (defclass x-y-pos ()
-    ((rho :initform 0 :accessor pos-rho)
-     (theta :initform 0 :accessor pos-theta)))
-  
-  (do-test "update-instance-for-redefined-class/make-instances-obsolete(2)"
-        ()
-
-    (defmethod update-instance-for-redefined-class :before
-               ((pos x-y-pos) added deleted plist &key)
-      ;; Transform the x-y coordinates to polar coordinates
-      ;; and store into the new slots
-      (let ((x (getf plist 'x))
-            (y (getf plist 'y)))
-        (setf (pos-rho pos) (sqrt (+ (* x x) (* y y)))
-              (pos-theta pos) (atan y x))))
-
-    (defmethod pos-x ((pos x-y-pos))
-      (with-slots (rho theta) pos (* rho (cos theta))))
-
-    (defmethod (setf pos-x) (new-x (pos x-y-pos))
-      (with-slots (rho theta) pos
-        (let ((y (pos-y pos)))
-          (setq rho (sqrt (+ (* new-x new-x) (* y y)))
-                theta (atan y new-x))
-          new-x)))
-    
-    (defmethod pos-y ((pos x-y-pos))
-      (with-slots (rho theta) pos (* rho (sin theta))))
-  
-    (defmethod (setf pos-y) (new-y (pos x-y-pos))
-      (with-slots (rho theta)
-        (let ((x (pos-x pos)))
-          (setq rho (sqrt (+ (* x x) (* new-y new-y)))
-                theta (atan new-y x))
-          new-y)))
-
-    (unless (and (equalp 5 (pos-rho old-pos))
-                 (equalp (* 5 (cos (atan 4 3))) (pos-x old-pos))
-                 (equalp (* 5 (sin (atan 4 3))) (pos-y old-pos)))
-      (do-test-error nil "specialized behaivior failed"))
-    ))
-
-(cleanup-do-test '((:classes class-for-testing-redefined-class
-                             test-obsolete-class)
-                   (:functions test-x test-y test-a)
-                   (:setf-generic-functions class-x class-y)))
-
-(defclass test-obsolete-class (standard-class) ())
-
-(defmethod check-super-metaclass-compatibility ((x test-obsolete-class)
-                                                (y standard-class))
-  't)
-                    
-(let ((foo 'nil)
-      bar)
-  (defmethod make-instances-obsolete ((x test-obsolete-class))
-    (setq foo 'called)
-    (call-next-method))
-
-  (defclass class-for-testing-redefined-class ()
-    ((x :initform 'x :accessor test-x)
-     (y :initform 'y :accessor test-y))
-    (:metaclass test-obsolete-class))
-
-  (setq bar (make-instance 'class-for-testing-redefined-class))
-
-  (defclass class-for-testing-redefined-class ()
-    ((a :initform 0 :accessor test-a)
-     (y :initform 1 :accessor test-y)))
-
-  (do-test "update-instance-for-redefined-class/make-instances-obsolete(3)"
-        ()
-    (unless (and (eq (test-a bar) 0)
-                 (eq (test-y bar) '1)
-                 (eq foo 'called))
-      (do-test-error nil "imcompatible class change failed"))))
-
-(cleanup-do-test '((:classes class-for-testing-redefined-class)
-                   (:functions test-x test-y test-a)
-                   (:setf-generic-functions class-x class-y)))
-                    
-(let (foo)
-  (defclass class-for-testing-redefined-class ()
-    ((x :initform 'x :accessor test-x)
-     (y :initform 'y :accessor test-y)))
-
-  (setq foo (make-instance 'class-for-testing-redefined-class))
-
-  (make-instances-obsolete 'class-for-testing-redefined-class)
-  
-  (do-test "update-instance-for-redefined-class/make-instances-obsolete(4)"
-        ()
-    (unless (and (eq (test-x foo) 'x)
-                 (eq (test-y foo) 'y))
-      (do-test-error nil "call make-instances-obsolete by hand failed"))))
-
-(do-test "slot-mumble functions"
-         ((:variables foo1 bar1)
-          (:classes foo bar))
-
-  (defclass foo-sm ()
-    ((x :initform 'x :allocation :class)
-     (y :initform 'y)
-     (z :allocation :class)
-     (u)))
-
-  (defclass bar-sm ()
-    ((x :initform 'x :allocation :class)
-     (y :initform 'y)
-     (z :allocation :class)
-     (u))
-    (:metaclass funcallable-standard-class))
-
-  (defmethod slot-missing ((class standard-class)
-                           (instance foo-sm)
-                           slot-name operation &optional new-value)
-    (list* class instance slot-name operation new-value))
-  
-  (defmethod slot-missing ((class standard-class)
-                           (instance bar-sm)
-                           slot-name operation &optional new-value)
-    (list* class instance slot-name operation new-value))
-
-  (defmethod slot-unbound ((class standard-class)
-                           (instance foo-sm)
-                           slot-name)
-    (list class instance slot-name))
-  
-  (defmethod slot-unbound ((class funcallable-standard-class)
-                           (instance bar-sm)
-                           slot-name)
-    (list class instance slot-name))
-  
-  (setq foo1 (make-instance 'foo-sm))
-  (setq bar1 (make-instance 'bar-sm))
-
-  (flet ((test1 (instance)
-           (and (eq (slot-value instance 'x) 'x)
-                (eq (slot-value instance 'y) 'y)
-                (equal (slot-value instance 'z)
-                       (list (class-of instance) instance 'z))
-                (equal (slot-value instance 'u)
-                       (list (class-of instance) instance 'u))
-                (slot-boundp instance 'x)
-                (slot-boundp instance 'y)
-                (not (slot-boundp instance 'z))
-                (not (slot-boundp instance 'u))))
-         (test2 (instance)
-           (and (not (slot-boundp instance 'x))
-                (not (slot-boundp instance 'y))
-                (slot-boundp instance 'z)
-                (slot-boundp instance 'u)
-                (equal (slot-value instance 'x)
-                       (list (class-of instance) instance 'x))
-                (equal (slot-value instance 'y)
-                       (list (class-of instance) instance 'y))
-                (eq (slot-value instance 'z) 'z)
-                (eq (slot-value instance 'u) 'u)))
-         (test3 (instance)
-           (and (slot-exists-p instance 'x)
-                (slot-exists-p instance 'y)))
-         (test4 (instance)
-           (and (equal (slot-value instance 'a)
-                       (list (class-of instance)
-                             instance
-                             'a
-                             'slot-value))
-                (equal (setf (slot-value instance 'a) 'b)
-                       (list* (class-of instance)
-                              instance
-                              'a
-                              'setf
-                              'b))
-                (equal (slot-boundp instance 'a)
-                       (list (class-of instance)
-                             instance
-                             'a
-                             'slot-boundp))
-
-                (equal (slot-makunbound instance 'a)
-                       (list (class-of instance)
-                             instance
-                             'a
-                             'slot-makunbound)))))
-
-        (unless (and (test1 foo1)
-                     (test1 bar1))
-          (do-test-error nil "slot functions test1 failed"))
-
-        (slot-makunbound foo1 'x)
-        (slot-makunbound foo1 'y)
-        (setf (slot-value foo1 'z) 'z)
-        (setf (slot-value foo1 'u) 'u)
-        (slot-makunbound bar1 'x)
-        (slot-makunbound bar1 'y)
-        (setf (slot-value bar1 'z) 'z)
-        (setf (slot-value bar1 'u) 'u)
-
-        (unless (and (test2 foo1)
-                     (test2 bar1))
-          (do-test-error nil "slot functions test2 failed"))
-
-        (unless (and (test3 foo1)
-                     (test3 bar1))
-          (do-test-error nil "slot functions test3 failed"))
-        
-        (unless (and (test4 foo1)
-                     (test4 bar1))
-          (do-test-error nil "slot function test4 failed"))
-        ))
-
-
-(cleanup-do-test '((:classes foo-sm bar-sm)
-                   (:functions foo-x foo-y bar-x bar-y)))
-
-(defclass foo ()
-  ((x :initform 'x :allocation :class :reader foo-x)
-   (y :initform 'y :reader foo-y)))
-
-(defclass bar ()
-  ((x :allocation :class :reader bar-x)
-   (y :reader bar-y)))
-
-(do-test "slot-value/slot-unbound for pv optimization case and :reader method"
-         ((:functions get-foo-x get-foo-y get-x-1 get-y-1
-                      get-bar-x get-bar-y get-x-2 get-y-2)
-          (:variables foo1 bar1))
-
-  (defmethod get-foo-x ((foo1 foo))
-    (slot-value foo1 'x))
-  (defmethod get-foo-y ((foo1 foo))
-    (slot-value foo1 'y))
-
-  (defun get-x-1 (foo1)
-    (slot-value foo1 'x))
-  (defun get-y-1 (foo1)
-    (slot-value foo1 'y))
-
-  (defmethod slot-unbound ((class standard-class) (instance foo) slot-name)
-    (list class instance slot-name))
-  
-  (setq foo1 (make-instance 'foo))
-  
-  (unless (and (eq (get-foo-x foo1) 'x)
-               (eq (get-foo-y foo1) 'y)
-               (eq (get-x-1 foo1) 'x)
-               (eq (get-y-1 foo1) 'y)
-               (eq (foo-x foo1) 'x)
-               (eq (foo-y foo1) 'y))
-    (do-test-error nil "slot-value failed"))
-
-  (unless (and (eq (slot-makunbound foo1 'x) foo1)
-               (eq (slot-makunbound foo1 'y) foo1))
-    (do-test-error nil "slot-makunbound returns wrong value"))
-
-  (unless (and (equal (get-foo-x foo1)
-                      (list (find-class 'foo) foo1 'x))
-               (equal (get-foo-y foo1)
-                      (list (find-class 'foo) foo1 'y))
-               (equal (get-x-1 foo1)
-                      (list (find-class 'foo) foo1 'x))
-               (equal (get-y-1 foo1)
-                      (list (find-class 'foo) foo1 'y))
-               (equal (foo-x foo1)
-                      (list (find-class 'foo) foo1 'x))
-               (equal (foo-y foo1)
-                      (list (find-class 'foo) foo1 'y)))
-    (do-test-error nil "slot-value/slot-unbound failed"))
-
-  (defmethod get-bar-x ((bar1 bar))
-    (slot-value bar1 'x))
-  (defmethod get-bar-y ((bar1 bar))
-    (slot-value bar1 'y))
-
-  (defun get-x-2 (bar1)
-    (slot-value bar1 'x))
-  (defun get-y-2 (bar1)
-    (slot-value bar1 'y))
-
-  (defmethod slot-unbound ((class standard-class) (instance bar) slot-name)
-    (list class instance slot-name))
-
-  (setq bar1 (make-instance 'bar))
-
-  (unless (and (equal (get-bar-x bar1)
-                      (list (find-class 'bar) bar1 'x))
-               (equal (get-bar-y bar1)
-                      (list (find-class 'bar) bar1 'y))
-               (equal (get-x-2 bar1)
-                      (list (find-class 'bar) bar1 'x))
-               (equal (get-y-2 bar1)
-                      (list (find-class 'bar) bar1 'y))
-               (equal (bar-x bar1)
-                      (list (find-class 'bar) bar1 'x))
-               (equal (bar-y bar1)
-                      (list (find-class 'bar) bar1 'y)))
-    (do-test-error nil "slot-value/slot-unbound failed")))
-
-  
-(do-test "defmethod/call-next-method/&aux variable"
-         ((:variables foo1 bar1)
-          (:classes foo bar)
-          (:functions test1 test2 test3))
-
-  (defclass foo ()
-    ((x :initform 0)
-     (y :initform 1)))
-
-  (defclass bar (foo) ())
-
-  (defmethod test1 ((foo1 foo) &aux aux-arg)
-    (setq aux-arg (list foo1)))
-
-  (defmethod test1 ((bar1 bar) &aux aux-arg)
-    (setq aux-arg (list (list bar1)))
-    (call-next-method)
-    aux-arg)
-
-  (setq foo1 (make-instance 'foo))
-  (setq bar1 (make-instance 'bar))
-  (unless (and (equal (test1 foo1) (list foo1))
-               (equal (test1 bar1) (list (list bar1))))
-    (do-test-error nil "defmethod with call-next-method and &aux failed")))
-
-;;;
-;;; defconstructor tests
-;;;
-(format t
-        "~%Testing defconstructor [methods, default/initform, slot-filling]")
-
-(defun check-slots (object &rest names-and-values)
-  (doplist (name value) names-and-values
-    (unless (if (eq value :unbound)
-                (not (slot-boundp object name))
-                (and (slot-boundp object name)
-                     (eq (slot-value object name) value)))
-      (return-from check-slots nil)))
-  't)
-
-;;;
-;;; [methods, default/initform, slot-filling]
-;;; methods:           [nil, :after, t]
-;;; default/initform:  [nil, :constant, t]
-;;; slot-filling:      [:instance, :class]
-;;;
-;;; supplied:          [nil, :constant, t]
-
-
-(cleanup-do-test '((:classes foo1 foo2 foo3 foo4
-                             foo5 foo6 foo7 foo8
-                             foo9 foo10 foo11 foo12)
-                   (:variables *a-initform* *b-initform* *c-initform*
-                               *a-default* *b-default* *c-default*
-                               *a-supplied* *b-supplied* *c-supplied*)
-                   (:functions foo1-test1 foo1-test2 foo1-test3
-                               foo2-test1 foo2-test2 foo2-test3
-                               foo3-test1 foo3-test2 foo3-test3
-                               foo4-test1 foo4-test2 foo4-test3
-                               foo5-test1 foo5-test2 foo5-test3
-                               foo6-test1 foo6-test2 foo6-test3
-                               foo7-test1 foo7-test2 foo7-test3
-                               foo8-test1 foo8-test2 foo8-test3
-                               foo9-test1 foo9-test2 foo9-test3
-                               foo10-test1 foo10-test2 foo10-test3
-                               foo11-test1 foo11-test2 foo11-test3
-                               foo12-test1 foo12-test2 foo12-test3)))
-
-(defvar *a-initform* 'a-initform)
-(defvar *b-initform* 'b-initform)
-(defvar *c-initform* 'c-initform)
-(defvar *a-default* 'a-default)
-(defvar *b-default* 'b-default)
-(defvar *c-default* 'c-default)
-(defvar *a-supplied* 'a-supplied)
-(defvar *b-supplied* 'b-supplied)
-(defvar *c-supplied* 'c-supplied)
-
-;;;
-;;; foo1
-;;; [methods, default/initform, slot-filing]
-;;; (t,       t,                :class)
-
-(defclass foo1 ()
-    ((a :initarg :a :initform *a-initform*)
-     (b :initarg :b :initform *b-initform*)
-     (c :initarg :c :allocation :class :initform *c-initform*))
-  (:default-initargs :b *b-default* :c *c-default*))
-
-(defmethod *initialize-instance :before ((instance foo1) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (t,       t,                :class) (1)"
-         ((:functions foo1-test1 foo1-test2 foo1-test3))
-
-  (defconstructor foo1-test1 foo1 ())
-  (defconstructor foo1-test2 foo1 () :a 1 :b 2 :c 3)
-  (defconstructor foo1-test3 foo1 (a b c) :a a :b b :c c)
-
-  (dotimes (i 2)                                ;Do it twice to be sure that
-                                                ;the constructor works more
-                                                ;than just the first time.
-    (unless (check-slots (foo1-test1)
-                         'a *a-initform*
-                         'b *b-default*
-                         'c *c-default*)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo1-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo1-test3 *a-supplied* *b-supplied* *c-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c *c-supplied*)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-;;;
-;;; foo2
-;;; [methods, default/initform, slot-filling]
-;;; (t,       t,                :class)
-
-(defclass foo2 ()
-    ((a :initform *a-initform* :initarg :a)
-     (b :initform *b-initform* :initarg :b)
-     (c :allocation :class :initform *c-initform* :initarg :c))
-  (:default-initargs :b *b-default*))
-
-(defmethod *initialize-instance :before ((instance foo2) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (t,       t,                :class) (2)"
-         ((:functions foo2-test1 foo2-test2 foo2-test3))
-
-  (defconstructor foo2-test1 foo2 ())
-  (defconstructor foo2-test2 foo2 () :a 1 :b 2 :c 3)
-  (defconstructor foo2-test3 foo2 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (foo2-test1) 'a *a-initform*
-                                      'b *b-default*
-                                      'c *c-initform*)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo2-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo2-test3 *a-supplied* *b-supplied* *c-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c *c-supplied*)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; foo3
-;;; [methods, default/initform, slot-filling]
-;;; (t,       t,                :instance)
-
-(defclass foo3 ()
-    ((a :initform *a-initform* :initarg :a)
-     (b :initform *b-initform* :initarg :b)
-     (c :allocation :class :initform *c-initform*))
-  (:default-initargs :b *b-default*))
-
-(defmethod *initialize-instance :before ((instance foo3) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (t,       t,                :instance) (1)"
-         ((:functions foo3-test1 foo3-test2 foo3-test3))
-
-  (defconstructor foo3-test1 foo3 ())
-  (defconstructor foo3-test2 foo3 () :a 1 :b 2)
-  (defconstructor foo3-test3 foo3 (a b) :a a :b b)
-  
-  
-  (dotimes (i 2)
-    (unless (check-slots (foo3-test1) 'a *a-initform*
-                                      'b *b-default*
-                                      'c *c-initform*)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo3-test2) 'a '1 'b '2 'c *c-initform*)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo3-test3 *a-supplied* *b-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c *c-initform*)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; foo4
-;;; [methods, default/initform, slot-filling]
-;;; (t,       t,                :instance)
-
-(defclass foo4 ()
-    ((a :initform *a-initform* :initarg :a)
-     (b :initform *b-initform* :initarg :b)
-     (c :allocation :class))
-  (:default-initargs :b *b-default*))
-
-(defmethod *initialize-instance :before ((instance foo4) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (t,       t,                :instance) (2)"
-         ((:functions foo4-test1 foo4-test2 foo4-test3))
-
-  (defconstructor foo4-test1 foo4 ())
-  (defconstructor foo4-test2 foo4 () :a 1 :b 2)
-  (defconstructor foo4-test3 foo4 (a b) :a a :b b)
-
-  (dotimes (i 2)
-    (unless (check-slots (foo4-test1) 'a *a-initform*
-                                      'b *b-default*
-                                      'c :unbound)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo4-test2) 'a '1 'b '2 'c :unbound)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo4-test3 *a-supplied* *b-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c :unbound)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; foo5
-;;; [methods, default/initform, slot-filling]
-;;; (:after,  t,                :class)
-
-(defclass foo5 ()
-    ((a :initarg :a :initform *a-initform*)
-     (b :initarg :b :initform *b-initform*)
-     (c :initarg :c :allocation :class :initform *c-initform*))
-  (:default-initargs :b *b-default* :c *c-default*))
-
-(defmethod *initialize-instance :after ((instance foo5) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (:after,  t,                :class) (1)"
-         ((:functions foo5-test1 foo5-test2 foo5-test3))
-
-  (defconstructor foo5-test1 foo5 ())
-  (defconstructor foo5-test2 foo5 () :a 1 :b 2 :c 3)
-  (defconstructor foo5-test3 foo5 (a b c) :a a
-                                          :b b
-                                          :c c)
-
-  (dotimes (i 2)
-    (unless (check-slots (foo5-test1) 'a *a-initform*
-                                      'b *b-default*
-                                      'c *c-default*)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo5-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo5-test3 *a-supplied* *b-supplied* *c-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c *c-supplied*)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; foo6
-;;; [methods, default/initform, slot-filling]
-;;; (:after,  t,                :class)
-
-(defclass foo6 ()
-    ((a :initform *a-initform* :initarg :a)
-     (b :initform *b-initform* :initarg :b)
-     (c :allocation :class :initform *c-initform* :initarg :c))
-  (:default-initargs :b *b-default*))
-
-(defmethod *initialize-instance :after ((instance foo6) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (:after,  t,                :class) (2)"
-         ((:functions foo6-test1 foo6-test2 foo6-test3))
-
-  (defconstructor foo6-test1 foo6 ())
-  (defconstructor foo6-test2 foo6 () :a 1 :b 2 :c 3)
-  (defconstructor foo6-test3 foo6 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (foo6-test1) 'a *a-initform*
-                                      'b *b-default*
-                                      'c *c-initform*)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo6-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo6-test3 *a-supplied* *b-supplied* *c-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c *c-supplied*)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; foo7
-;;; [methods, default/initform, slot-filling]
-;;; (:after,  t,                :instance)
-
-(defclass foo7 ()
-    ((a :initform *a-initform* :initarg :a)
-     (b :initform *b-initform* :initarg :b)
-     (c :allocation :class :initform *c-initform*))
-  (:default-initargs :b *b-default*))
-
-(defmethod *initialize-instance :after ((instance foo7) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (:after,  t,                :instance) (1)"
-         ((:functions foo7-test1 foo7-test2 foo7-test3))
-
-  (defconstructor foo7-test1 foo7 ())
-  (defconstructor foo7-test2 foo7 () :a 1 :b 2)
-  (defconstructor foo7-test3 foo7 (a b) :a a :b b)
-  
-  (dotimes (i 2)
-    (unless (check-slots (foo7-test1) 'a *a-initform*
-                                      'b *b-default*
-                                      'c *c-initform*)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo7-test2) 'a '1 'b '2 'c *c-initform*)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo7-test3 *a-supplied* *b-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c *c-initform*)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; foo8
-;;; [methods, default/initform, slot-filling]
-;;; (:after,  t,                :instance)
-
-(defclass foo8 ()
-    ((a :initform *a-initform* :initarg :a)
-     (b :initform *b-initform* :initarg :b)
-     (c :allocation :class))
-  (:default-initargs :b *b-default*))
-
-(defmethod *initialize-instance :after ((instance foo8) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (:after,  t,                :instance) (2)"
-         ((:functions foo8-test1 foo8-test2 foo8-test3))
-
-  (defconstructor foo8-test1 foo8 ())
-  (defconstructor foo8-test2 foo8 () :a 1 :b 2)
-  (defconstructor foo8-test3 foo8 (a b) :a a :b b)
-
-  (dotimes (i 2)
-    (unless (check-slots (foo8-test1) 'a *a-initform*
-                                      'b *b-default*
-                                      'c :unbound)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo8-test2) 'a '1 'b '2 'c :unbound)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo8-test3 *a-supplied* *b-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c :unbound)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; foo9
-;;; [methods, default/initform, slot-filling]
-;;; (nil,     t,                :class)
-
-(defclass foo9 ()
-    ((a :initarg :a :initform *a-initform*)
-     (b :initarg :b :initform *b-initform*)
-     (c :initarg :c :allocation :class :initform *c-initform*))
-  (:default-initargs :b *b-default* :c *c-default*))
-
-(do-test "defconstructor (nil,     t,                :class) (1)"
-         ((:functions foo9-test1 foo9-test2 foo9-test3))
-
-  (defconstructor foo9-test1 foo9 ())
-  (defconstructor foo9-test2 foo9 () :a 1 :b 2 :c 3)
-  (defconstructor foo9-test3 foo9 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (foo9-test1) 'a *a-initform*
-                                      'b *b-default*
-                                      'c *c-default*)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo9-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo9-test3 *a-supplied* *b-supplied* *c-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c *c-supplied*)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-    
-;;;
-;;; foo10
-;;; [methods, default/initform, slot-filling]
-;;; (nil,     t,                :class)
-
-(defclass foo10 ()
-    ((a :initform *a-initform* :initarg :a)
-     (b :initform *b-initform* :initarg :b)
-     (c :allocation :class :initform *c-initform* :initarg :c))
-  (:default-initargs :b *b-default*))
-
-(do-test "defconstructor (nil,     t,                :class) (2)"
-         ((:functions foo10-test1 foo10-test2 foo10-test3))
-
-  (defconstructor foo10-test1 foo10 ())
-  (defconstructor foo10-test2 foo10 () :a 1 :b 2 :c 3)
-  (defconstructor foo10-test3 foo10 (a b c) :a a
-                                            :b b
-                                            :c c)
-  (dotimes (i 2)
-    (unless (check-slots (foo10-test1) 'a *a-initform*
-                                       'b *b-default*
-                                       'c *c-initform*)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo10-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo10-test3 *a-supplied* *b-supplied* *c-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c *c-supplied*)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; foo11
-;;; [methods, default/initform, slot-filling]
-;;; (nil,     t,                :instance)
-
-(defclass foo11 ()
-    ((a :initform *a-initform* :initarg :a)
-     (b :initform *b-initform* :initarg :b)
-     (c :allocation :class :initform *c-initform*))
-  (:default-initargs :b *b-default*))
-
-(do-test "defconstructor (nil,     t,                :instance) (1)"
-         ((:functions foo11-test1 foo11-test2 foo11-test3))
-
-  (defconstructor foo11-test1 foo11 ())
-  (defconstructor foo11-test2 foo11 () :a 1 :b 2)
-  (defconstructor foo11-test3 foo11 (a b) :a a :b b)
-  
-  (dotimes (i 2)
-    (unless (check-slots (foo11-test1) 'a *a-initform*
-                                       'b *b-default*
-                                       'c *c-initform*)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo11-test2) 'a '1 'b '2 'c *c-initform*)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo11-test3 *a-supplied* *b-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c *c-initform*)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; foo12
-;;; [methods, default/initform, slot-filling]
-;;; (nil,     t,                :instance)
-
-(defclass foo12 ()
-    ((a :initform *a-initform* :initarg :a)
-     (b :initform *b-initform* :initarg :b)
-     (c :allocation :class))
-  (:default-initargs :b *b-default*))
-
-(defmethod *initialize-instance :after ((instance foo12) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (nil,     t,                :instance) (2)"
-         ((:functions foo12-test1 foo12-test2 foo12-test3))
-
-  (defconstructor foo12-test1 foo12 ())
-  (defconstructor foo12-test2 foo12 () :a 1 :b 2)
-  (defconstructor foo12-test3 foo12 (a b) :a a :b b)
-
-  (dotimes (i 2)
-    (unless (check-slots (foo12-test1) 'a *a-initform*
-                                       'b *b-default*
-                                       'c :unbound)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo12-test2) 'a '1 'b '2 'c :unbound)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (foo12-test3 *a-supplied* *b-supplied*)
-                         'a *a-supplied*
-                         'b *b-supplied*
-                         'c :unbound)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-
-(cleanup-do-test '((:classes bar1 bar2 bar3 bar4
-                             bar5 bar6 bar7 bar8
-                             bar9 bar10 bar11 bar12)
-                   (:functions bar1-test1 bar1-test2 bar1-test3
-                               bar2-test1 bar2-test2 bar2-test3
-                               bar3-test1 bar3-test2 bar3-test3
-                               bar4-test1 bar4-test2 bar4-test3
-                               bar5-test1 bar5-test2 bar5-test3
-                               bar6-test1 bar6-test2 bar6-test3
-                               bar7-test1 bar7-test2 bar7-test3
-                               bar8-test1 bar8-test2 bar8-test3
-                               bar9-test1 bar9-test2 bar9-test3
-                               bar10-test1 bar10-test2 bar10-test3
-                               bar11-test1 bar11-test2 bar11-test3
-                               bar12-test1 bar12-test2 bar12-test3)))
-
-;;;
-;;; bar1
-;;; [methods, default/initform, slot-filling]
-;;; (t,       :constant,        :class)
-
-(defclass bar1 ()
-    ((a :initarg :a :initform 1)
-     (b :initarg :b :initform 2)
-     (c :initarg :c :allocation :class :initform 3))
-  (:default-initargs :b 5 :c 6))
-
-(defmethod *initialize-instance :before ((instance bar1) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (t,       :constant,        :class) (1)"
-         ((:functions bar1-test1 bar1-test2 bar1-test3))
-
-  (defconstructor bar1-test1 bar1 ())
-  (defconstructor bar1-test2 bar1 () :a 1 :b 2 :c 3)
-  (defconstructor bar1-test3 bar1 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (bar1-test1) 'a '1 'b '5 'c '6)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar1-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar1-test3 7 8 9) 'a '7 'b '8 'c '9)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar2
-;;; [methods, default/initform, slot-filling]
-;;; (t,       :constant,        :class)
-
-(defclass bar2 ()
-    ((a :initform 1 :initarg :a)
-     (b :initform 2 :initarg :b)
-     (c :allocation :class :initform 3 :initarg :c))
-  (:default-initargs :b 5))
-
-(defmethod *initialize-instance :before ((instance bar2) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (t,       :constant,        :class) (2)"
-         ((:functions bar2-test1 bar2-test2 bar2-test3))
-
-  (defconstructor bar2-test1 bar2 ())
-  (defconstructor bar2-test2 bar2 () :a 1 :b 2 :c 3)
-  (defconstructor bar2-test3 bar2 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (bar2-test1) 'a '1 'b '5 'c '3)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar2-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar2-test3 7 8 9) 'a '7 'b '8 'c '9)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar3
-;;; [methods, default/initform, slot-filling]
-;;; (t,       :constant,        :instance)
-
-(defclass bar3 ()
-    ((a :initform 1 :initarg :a)
-     (b :initform 2 :initarg :b)
-     (c :allocation :class :initform 3))
-  (:default-initargs :b 5))
-
-(defmethod *initialize-instance :before ((instance bar3) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (t,       :constant,        :instance) (1)"
-         ((:functions bar3-test1 bar3-test2 bar3-test3))
-
-  (defconstructor bar3-test1 bar3 ())
-  (defconstructor bar3-test2 bar3 () :a 1 :b 2)
-  (defconstructor bar3-test3 bar3 (a b) :a a :b b)
-  
-  (dotimes (i 2)
-    (unless (check-slots (bar3-test1) 'a '1 'b '5 'c '3)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar3-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar3-test3 7 8) 'a '7 'b '8 'c '3)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar4
-;;; [methods, default/initform, slot-filling]
-;;; (t,       :constant,        :instance)
-
-(defclass bar4 ()
-    ((a :initform 1 :initarg :a)
-     (b :initform 2 :initarg :b)
-     (c :allocation :class))
-  (:default-initargs :b 5))
-
-(defmethod *initialize-instance :before ((instance bar4) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (t,       :constant,        :instance) (2)"
-         ((:functions bar4-test1 bar4-test2 bar4-test3))
-
-  (defconstructor bar4-test1 bar4 ())
-  (defconstructor bar4-test2 bar4 () :a 1 :b 2)
-  (defconstructor bar4-test3 bar4 (a b) :a a :b b)
-
-  (dotimes (i 2)
-    (unless (check-slots (bar4-test1) 'a '1 'b '5 'c :unbound)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar4-test2) 'a '1 'b '2 'c :unbound)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar4-test3 7 8) 'a '7 'b '8 'c :unbound)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar5
-;;; [methods, default/initform, slot-filling]
-;;; (:after,  :constant,        :class)
-
-(defclass bar5 ()
-    ((a :initarg :a :initform 1)
-     (b :initarg :b :initform 2)
-     (c :initarg :c :allocation :class :initform 3))
-  (:default-initargs :b 5 :c 6))
-
-(defmethod *initialize-instance :after ((instance bar5) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (:after,  :constant,        :class) (1)"
-         ((:functions bar5-test1 bar5-test2 bar5-test3))
-
-  (defconstructor bar5-test1 bar5 ())
-  (defconstructor bar5-test2 bar5 () :a 1 :b 2 :c 3)
-  (defconstructor bar5-test3 bar5 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (bar5-test1) 'a '1 'b '5 'c '6)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar5-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar5-test3 7 8 9) 'a '7 'b '8 'c '9)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar6
-;;; [methods, default/initform, slot-filling]
-;;; (:after,  :constant,        :class)
-
-(defclass bar6 ()
-    ((a :initform 1 :initarg :a)
-     (b :initform 2 :initarg :b)
-     (c :allocation :class :initform 3 :initarg :c))
-  (:default-initargs :b 5))
-
-(defmethod *initialize-instance :after ((instance bar6) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (:after,  :constant,        :class) (2)"
-         ((:functions bar6-test1 bar6-test2 bar6-test3))
-
-  (defconstructor bar6-test1 bar6 ())
-  (defconstructor bar6-test2 bar6 () :a 1 :b 2 :c 3)
-  (defconstructor bar6-test3 bar6 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (bar6-test1) 'a '1 'b '5 'c '3)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar6-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar6-test3 7 8 9) 'a '7 'b '8 'c '9)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar7
-;;; [methods, default/initform, slot-filling]
-;;; (:after,  :constant,        :instance)
-
-(defclass bar7 ()
-    ((a :initform 1 :initarg :a)
-     (b :initform 2 :initarg :b)
-     (c :allocation :class :initform 3))
-  (:default-initargs :b 5))
-
-(defmethod *initialize-instance :after ((instance bar7) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (:after,  :constant,        :instance) (1)"
-         ((:functions bar7-test1 bar7-test2 bar7-test3))
-
-  (defconstructor bar7-test1 bar7 ())
-  (defconstructor bar7-test2 bar7 () :a 1 :b 2)
-  (defconstructor bar7-test3 bar7 (a b) :a a :b b)
-  
-  (dotimes (i 2)
-    (unless (check-slots (bar7-test1) 'a '1 'b '5 'c '3)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar7-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar7-test3 7 8) 'a '7 'b '8 'c '3)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar8
-;;; [methods, default/initform, slot-filling]
-;;; (:after,  :constant,        :instance)
-
-(defclass bar8 ()
-    ((a :initform 1 :initarg :a)
-     (b :initform 2 :initarg :b)
-     (c :allocation :class))
-  (:default-initargs :b 5))
-
-(defmethod *initialize-instance :after ((instance bar8) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (:after,  :constant,        :instance) (2)"
-         ((:functions bar8-test1 bar8-test2 bar8-test3))
-
-  (defconstructor bar8-test1 bar8 ())
-  (defconstructor bar8-test2 bar8 () :a 1 :b 2)
-  (defconstructor bar8-test3 bar8 (a b) :a a :b b)
-
-  (dotimes (i 2)
-    (unless (check-slots (bar8-test1) 'a '1 'b '5 'c :unbound)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar8-test2) 'a '1 'b '2 'c :unbound)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar8-test3 7 8) 'a '7 'b '8 'c :unbound)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar9
-;;; [methods, default/initform, slot-filling]
-;;; (nil,     :constant,        :class)
-
-(defclass bar9 ()
-    ((a :initarg :a :initform 1)
-     (b :initarg :b :initform 2)
-     (c :initarg :c :allocation :class :initform 3))
-  (:default-initargs :b 5 :c 6))
-
-(do-test "defconstructor (nil,     :constant,        :class) (1)"
-         ((:functions bar9-test1 bar9-test2 bar9-test3))
-
-  (defconstructor bar9-test1 bar9 ())
-  (defconstructor bar9-test2 bar9 () :a 1 :b 2 :c 3)
-  (defconstructor bar9-test3 bar9 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (bar9-test1) 'a '1 'b '5 'c '6)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar9-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar9-test3 7 8 9) 'a '7 'b '8 'c '9)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar10
-;;; [methods, default/initform, slot-filling]
-;;; (nil,     :constant,        :class)
-
-(defclass bar10 ()
-    ((a :initform 1 :initarg :a)
-     (b :initform 2 :initarg :b)
-     (c :allocation :class :initform 3 :initarg :c))
-  (:default-initargs :b 5))
-
-(do-test "defconstructor (nil,     :constant,        :class) (2)"
-         ((:functions bar10-test1 bar10-test2 bar10-test3))
-
-  (defconstructor bar10-test1 bar10 ())
-  (defconstructor bar10-test2 bar10 () :a 1 :b 2 :c 3)
-  (defconstructor bar10-test3 bar10 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (bar10-test1) 'a '1 'b '5 'c '3)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar10-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar10-test3 7 8 9) 'a '7 'b '8 'c '9)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar11
-;;; [methods, default/initform, slot-filling]
-;;; (nil,     :constant,        :instance)
-
-(defclass bar11 ()
-    ((a :initform 1 :initarg :a)
-     (b :initform 2 :initarg :b)
-     (c :allocation :class :initform 3))
-  (:default-initargs :b 5))
-
-(do-test "defconstructor (nil,     :constant,        :instance) (1)"
-         ((:functions bar11-test1 bar11-test2 bar11-test3))
-
-  (defconstructor bar11-test1 bar11 ())
-  (defconstructor bar11-test2 bar11 () :a 1 :b 2)
-  (defconstructor bar11-test3 bar11 (a b) :a a :b b)
-  
-  (dotimes (i 2)
-    (unless (check-slots (bar11-test1) 'a '1 'b '5 'c '3)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar11-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar11-test3 7 8) 'a '7 'b '8 'c '3)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; bar12
-;;; [methods, default/initform, slot-filling]
-;;; (nil,     :constant,        :instance)
-
-(defclass bar12 ()
-    ((a :initform 1 :initarg :a)
-     (b :initform 2 :initarg :b)
-     (c :allocation :class))
-  (:default-initargs :b 5))
-
-(defmethod *initialize-instance :after ((instance bar12) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (nil,     :constant,        :instance) (2)"
-         ((:functions bar12-test1 bar12-test2 bar12-test3))
-
-  (defconstructor bar12-test1 bar12 ())
-  (defconstructor bar12-test2 bar12 () :a 1 :b 2)
-  (defconstructor bar12-test3 bar12 (a b) :a a :b b)
-
-  (dotimes (i 2)
-    (unless (check-slots (bar12-test1) 'a '1 'b '5 'c :unbound)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar12-test2) 'a '1 'b '2 'c :unbound)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (bar12-test3 7 8) 'a '7 'b '8 'c :unbound)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-
-(cleanup-do-test '((:classes baz1 baz2 baz3)
-                   (:functions baz1-test1 baz1-test2 baz1-test3
-                               baz2-test1 baz2-test2 baz2-test3
-                               baz3-test1 baz3-test2 baz3-test3)))
-
-;;;
-;;; baz1
-;;; [methods, default/initform, slot-filling]
-;;; (t,       nil,              :class)
-
-(defclass baz1 ()
-    ((a :initarg :a)
-     (b :initarg :b)
-     (c :initarg :c :allocation :class)))
-
-(defmethod *initialize-instance :before ((instance baz1) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (t,       nil,              :class) (1)"
-         ((:functions baz1-test1 baz1-test2 baz1-test3))
-
-  (defconstructor baz1-test1 baz1 ())
-  (defconstructor baz1-test2 baz1 () :a 1 :b 2 :c 3)
-  (defconstructor baz1-test3 baz1 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (baz1-test1) 'a :unbound 'b :unbound 'c :unbound)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (baz1-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (baz1-test3 7 8 9) 'a '7 'b '8 'c '9)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; baz2
-;;; [methods, default/initform, slot-filling]
-;;; (:after,  nil,              :class)
-
-(defclass baz2 ()
-    ((a :initarg :a)
-     (b :initarg :b)
-     (c :initarg :c :allocation :class)))
-
-(defmethod *initialize-instance :after ((instance baz2) &rest ignore)
-  (declare (ignore ignore))
-  ())
-
-(do-test "defconstructor (:after,  nil,              :class) (1)"
-         ((:functions baz2-test1 baz2-test2 baz2-test3))
-
-  (defconstructor baz2-test1 baz2 ())
-  (defconstructor baz2-test2 baz2 () :a 1 :b 2 :c 3)
-  (defconstructor baz2-test3 baz2 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (baz2-test1) 'a :unbound 'b :unbound 'c :unbound)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (baz2-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (baz2-test3 7 8 9) 'a '7 'b '8 'c '9)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-;;;
-;;; baz3
-;;; [methods, default/initform, slot-filling]
-;;; (nil,     nil,              :class)
-
-(defclass baz3 ()
-    ((a :initarg :a)
-     (b :initarg :b)
-     (c :initarg :c :allocation :class)))
-
-(do-test "defconstructor (nil,     nil,              :class) (1)"
-         ((:functions baz3-test1 baz3-test2 baz3-test3))
-
-  (defconstructor baz3-test1 baz3 ())
-  (defconstructor baz3-test2 baz3 () :a 1 :b 2 :c 3)
-  (defconstructor baz3-test3 baz3 (a b c) :a a
-                                          :b b
-                                          :c c)
-  
-  (dotimes (i 2)
-    (unless (check-slots (baz3-test1) 'a :unbound 'b :unbound 'c :unbound)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (baz3-test2) 'a '1 'b '2 'c '3)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (baz3-test3 7 8 9) 'a '7 'b '8 'c '9)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-
-(cleanup-do-test '((:classes foo bar)
-                   (:functions make-bar-1 make-bar-2 make-bar-3)))
-
-(setq *foo-a* 'foo-a
-      *foo-b* 'foo-b
-      *foo-c* 'foo-c
-      *bar-a* 'bar-a
-      *bar-b* 'bar-b
-      *bar-c* 'bar-c
-      *supplied-a* 'a
-      *supplied-b* 'b
-      *supplied-c* 'c)
-
-(defclass foo ()
-    ((a :initarg :a)
-     (b :initarg :b)
-     (c :initarg :c))
-  (:default-initargs :a *foo-a* :b *foo-b* :c *foo-c*))
-
-(defclass bar (foo)
-    ((c :initarg :a))
-  (:default-initargs :a *bar-a* :c *bar-c*))
-
-(defconstructor make-bar-1 bar ())
-(defconstructor make-bar-2 bar () :a 1 :b 2 :c 3)
-(defconstructor make-bar-3 bar (a b c) :a a :b b :c c)
-
-(do-test "defconstructor/shadowing"
-         ()
-
-  (dotimes (i 2)
-    (unless (check-slots (make-bar-1) 'a *bar-a* 'b *foo-b* 'c *bar-a*)
-      (do-test-error nil "no initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (make-bar-2) 'a '1 'b '2 'c '1)
-      (do-test-error nil "constant initargs failed (~D time)" i)))
-
-  (dotimes (i 2)
-    (unless (check-slots (make-bar-3 *supplied-a* *supplied-b* *supplied-c*)
-                         'a  *supplied-a* 'b *supplied-b* 'c *supplied-a*)
-      (do-test-error nil "non constant initargs failed (~D time)" i))))
-
-
-(do-test "defconstructor/only needed forms should be evaluated"
-         ((:classes foo)
-          (:functions make-foo-1 make-foo-2))
-
-  (defclass foo ()
-      ((x :initform (do-test-error nil "foo x initform was evaluated")
-          :initarg :x)
-       (y :initform (do-test-error nil "foo y initform was evaluated")
-          :initarg :y)
-       (z :initform (do-test-error nil "foo z initform was evaluated")
-          :initarg :z))
-    (:default-initargs :y 2
-                       :z (do-test-error
-                            nil
-                            "z default was evaluated")))
-
-  (defconstructor make-foo-1 foo () :x 1 :z 3)
-  (defconstructor make-foo-2 foo (x z) :x x :z z)
-
-  (make-foo-1)
-  (make-foo-1)
-  (make-foo-2 'x 'z)
-  (make-foo-2 'x 'z))
-
-(do-test "defconstructor/shadowing/only needed forms should be evaluated"
-         ((:classes foo bar)
-          (:functions make-bar-4 make-bar-5))
-
-  (defclass foo ()
-      ((x :initform (do-test-error nil "foo x initform was evaluated")
-          :initarg :x)
-       (y :initform (do-test-error nil "foo y initform was evaluated")
-          :initarg :y)
-       (z :initform (do-test-error nil "foo z initform was evaluated")
-          :initarg :z))
-    (:default-initargs :x (do-test-error
-                            nil
-                            "foo z default was evaluated")
-                       :y (do-test-error
-                            nil
-                            "foo y default was evaluated")
-                       :z (do-test-error
-                            nil
-                            "foo z default was evaluated")))
-  (defclass bar (foo)
-      ((x :initform (do-test-error nil "bar x initform was evaluated"))
-       (y :initform (do-test-error nil "bar y initform was evaluated"))
-       (z :initform (do-test-error nil "bar z initform was evaluated")))
-    (:default-initargs :y 2
-                       :z (do-test-error
-                            nil
-                            "bar z default was evaluated")))
-
-  (defconstructor make-bar-4 bar () :x 1 :z 3)
-  (defconstructor make-bar-5 bar (x z) :x x :z z)
-
-  (make-bar-4)
-  (make-bar-4)
-  (make-bar-5 'x 'z)
-  (make-bar-5 'x 'z))
-
-;;;
-;;; 11/1 test to make sure reader/writer call slot-value-using-class
-;;;
-;;; **********************************************************************
-;;; This test codes will have to change in each of the next releases
-;;; **********************************************************************
-;;;
-(cleanup-do-test '((:classes test-deoptimized-slot-access-class
-                             test-deoptimized-slot-access)
-                   (:functions test-a test-b test-c)
-                   (:setf-generic-functions test-a test-b)))
-
-(defclass test-deoptimized-slot-access-class (standard-class) ())
-
-(defmethod check-super-metaclass-compatibility
-    ((x test-deoptimized-slot-access-class) (y standard-class))
-  't)
-
-(defmethod all-std-class-reader-miss-1
-    ((class test-deoptimized-slot-access-class) wrapper slot-name)
-  (declare (ignore wrapper slot-name))
-  ())
-
-(defmethod lookup-pv-miss-1
-    ((class test-deoptimized-slot-access-class) slots pv)
-  (let ((pv (call-next-method)))
-    (make-list (length pv) :initial-element nil)))
-
-
-(defclass test-deoptimized-slot-access ()
-    ((a :initform 'a :accessor test-a)
-     (b :initform 'b :accessor test-b))
-  (:metaclass test-deoptimized-slot-access-class))
-
-(defmethod test-c ((o test-deoptimized-slot-access))
-  (list (slot-value o 'a) (slot-value o 'b)))
-
-(let ((called-p 'nil)
-      instance)
-  (defmethod slot-value-using-class ((class test-deoptimized-slot-access-class)
-                                     object
-                                     slot-name)
-    (setq called-p 'read)
-    (call-next-method))
-
-  (defmethod (setf slot-value-using-class)
-      (nv (class test-deoptimized-slot-access-class) object slot-name)
-    (setq called-p 'written)
-    (call-next-method))
-
-  (setq instance (make-instance 'test-deoptimized-slot-access))
-  
-  (do-test "deoptimized slot access should call slot-value-using-class"
-        ()
-    (unless (and (eq (test-a instance) 'a)
-                 (eq called-p 'read))
-      (do-test-error nil "reader doesn't call slot-value-using-class"))
-
-    (setq called-p 'nil)
-    (setf (test-b instance) 'c)
-    (unless (eq called-p 'written)
-      (do-test-error nil "writer doesn't call slot-value-using-class"))
-
-    (setq called-p 'nil)
-    (unless (and (equal (test-c instance) '(a c))
-                 (eq called-p 'read))
-      (do-test-error nil "slot-value doesn't call slot-value-using-class"))))
-
-;;;
-;;; 5/3/89 eql specializers tests
-;;; 
-
-(cleanup-do-test '((:classes foo bar)))
-(defclass foo () ())
-(defclass bar (foo) ())
-
-(do-test "eql specializers(eql and other methods/symbol only)"
-         ((:functions test)
-          (:variables i))
-
-  (defmethod test ((self foo) x) 'foo)
-  (defmethod test ((self bar) (x (eql 'a))) 'a)
-  (defmethod test ((self bar) (x (eql 'b))) 'b)
-  (setq i (make-instance 'bar))
-
-  (unless (eq (test i 'a) 'a)
-    (do-test-error () "for (bar (eql a)) wrong method was called"))
-  (unless (eq (test i 'b) 'b)
-    (do-test-error () "for (bar (eql b)) wrong method was called"))
-  (unless (eq (test i 'c) 'foo)
-    (do-test-error () "for (bar (eql c)) wrong method was called"))
-  )
-
-(do-test "eql specializers(only eql methods/symbol only)"
-         ((:functions test2)
-          (:variables i))
-
-  (defmethod test2 ((self bar) (x (eql 'a))) 'a)
-  (defmethod test2 ((self bar) (x (eql 'b))) 'b)
-  (setq i (make-instance 'bar))
-
-  (unless (eq (test2 i 'a) 'a)
-    (do-test-error () "for (bar (eql a)) wrong method was called"))
-  (unless (eq (test2 i 'b) 'b)
-    (do-test-error () "for (bar (eql b)) wrong method was called"))
-  )
-
-(do-test "eql specializers(only eql methods/symbol and integer)"
-         ((:functions test3))
-
-  (defmethod test3 ((x (eql 'a)) (y (eql '1))) 'a-1)
-  (defmethod test3 ((x (eql 'b)) (y (eql '1))) 'b-1)
-  (defmethod test3 ((x (eql 'c)) (y (eql '1))) 'c-1)
-  (defmethod test3 ((x (eql 'a)) (y (eql '2))) 'a-2)
-  (defmethod test3 ((x (eql 'b)) (y (eql '2))) 'b-2)
-  (defmethod test3 ((x (eql 'c)) (y (eql '2))) 'c-2)
-  (defmethod test3 ((x (eql 'a)) (y (eql '3))) 'a-3)
-  (defmethod test3 ((x (eql 'b)) (y (eql '3))) 'b-3)
-  (defmethod test3 ((x (eql 'c)) (y (eql '3))) 'c-3)
-  
-  (unless (eq (test3 'a '1) 'a-1)
-    (do-test-error () "for (a 1) wrong method was called"))
-  (unless (eq (test3 'a '2) 'a-2)
-    (do-test-error () "for (a 2) wrong method was called"))
-  (unless (eq (test3 'a '3) 'a-3)
-    (do-test-error () "for (a 3) wrong method was called"))
-  (unless (eq (test3 'b '1) 'b-1)
-    (do-test-error () "for (b 1) wrong method was called"))
-  (unless (eq (test3 'b '2) 'b-2)
-    (do-test-error () "for (b 2) wrong method was called"))
-  (unless (eq (test3 'b '3) 'b-3)
-    (do-test-error () "for (b 3) wrong method was called"))
-  (unless (eq (test3 'c '1) 'c-1)
-    (do-test-error () "for (c 1) wrong method was called"))
-  (unless (eq (test3 'c '2) 'c-2)
-    (do-test-error () "for (c 2) wrong method was called"))
-  (unless (eq (test3 'c '3) 'c-3)
-    (do-test-error () "for (c 3) wrong method was called"))
-
-  )
-
-(do-test "eql specializers(eql and other methods/symbol and integer)"
-         ((:functions test4))
-
-  (defmethod test4 ((x (eql 'a)) (y (eql '1))) 'a-1)
-  (defmethod test4 ((x (eql 'b)) (y (eql '1))) 'b-1)
-  (defmethod test4 ((x (eql 'c)) (y (eql '2))) 'c-2)
-  (defmethod test4 ((x (eql 'b)) (y (eql '3))) 'b-3)
-  (defmethod test4 (x y) 'other)
-  
-  (unless (eq (test4 'a '1) 'a-1)
-    (do-test-error () "for (a 1) wrong method was called"))
-  (unless (eq (test4 'a '2) 'other)
-    (do-test-error () "for (a 2) wrong method was called"))
-  (unless (eq (test4 'a '3) 'other)
-    (do-test-error () "for (a 3) wrong method was called"))
-  (unless (eq (test4 'b '1) 'b-1)
-    (do-test-error () "for (b 1) wrong method was called"))
-  (unless (eq (test4 'b '2) 'other)
-    (do-test-error () "for (b 2) wrong method was called"))
-  (unless (eq (test4 'b '3) 'b-3)
-    (do-test-error () "for (b 3) wrong method was called"))
-  (unless (eq (test4 'c '1) 'other)
-    (do-test-error () "for (c 1) wrong method was called"))
-  (unless (eq (test4 'c '2) 'c-2)
-    (do-test-error () "for (c 2) wrong method was called"))
-  (unless (eq (test4 'c '3) 'other)
-    (do-test-error () "for (c 3) wrong method was called"))
-
-  )
-
-(do-test "eql specializers(call-next-method)"
-         ((:functions test5))
-
-  (defmethod test5 (x) ())
-  (defmethod test5 ((x (eql 'a))) (cons 'a (call-next-method)))
-  (defmethod test5 ((x (eql 'b))) (cons 'b (call-next-method)))
-
-  (unless (equal (test5 'a) '(a))
-    (do-test-error () "for (a) wrong method was called"))
-  (unless (equal (test5 'b) '(b))
-    (do-test-error () "for (b) wrong method was called"))
-  (unless (eq (test5 'c) '())
-    (do-test-error () "for (c) wrong method was called"))
-  )
-
-(do-test "eql specializers(for random types)"
-         ((:functions test6))
-
-  (defmethod test6 (x) ())
-  (defmethod test6 ((x symbol))  (cons 'the-class-symbol  (call-next-method)))
-  (defmethod test6 ((x null))    (cons 'the-class-null    (call-next-method)))
-  (defmethod test6 ((x number))  (cons 'the-class-number  (call-next-method)))
-  (defmethod test6 ((x integer)) (cons 'the-class-integer (call-next-method)))
-  (defmethod test6 ((x (eql 'foo))) (cons 'foo (call-next-method)))
-  (defmethod test6 ((x (eql 'bar))) (cons 'bar (call-next-method)))
-  (defmethod test6 ((x (eql 'nil))) (cons 'nil (call-next-method)))
-  (defmethod test6 ((x (eql '1.7))) (cons '1.7 (call-next-method)))
-  (defmethod test6 ((x (eql '321))) (cons '321 (call-next-method)))
-
-  (unless (eq (test6 '(other)) ())
-    (do-test-error () "for ((other)) wrong method was called"))
-  (unless (equal (test6 'symbol) '(the-class-symbol))
-    (do-test-error () "for (symbol) wrong method was called"))
-  (unless (equal (test6 '5.5) '(the-class-number))
-    (do-test-error () "for (number) wrong method was called"))
-  (unless (equal (test6 '123) '(the-class-integer the-class-number))
-    (do-test-error () "for (integer) wrong method was called"))
-  (unless (equal (test6 'foo) '(foo the-class-symbol))
-    (do-test-error () "for ((eql foo)) wrong method was called"))
-  (unless (equal (test6 'bar) '(bar the-class-symbol))
-    (do-test-error () "for ((eql bar)) wrong method was called"))
-  (unless (equal (test6 'nil) '(nil the-class-null the-class-symbol))
-    (do-test-error () "for ((eql nil)) wrong method was called"))
-  (unless (equal (test6 '1.7) '(1.7 the-class-number))
-    (do-test-error () "for ((eql 1.7)) wrong method was called"))
-  (unless (equal (test6 '321) '(321 the-class-integer the-class-number))
-    (do-test-error () "for ((eql 321)) wrong method was called"))
-  )
-
-;;;
-;;; (5/3/89)Testing :allocation :class for funcallable-instance
-;;;
-
-(format t "~%Testing :allocation :class test(for standard-instance)~%")
-         
-(cleanup-do-test '((:classes foo bar)
-                   (:variables foo1 bar1)))
-
-(defclass foo ()
-    ((a :initform (list 'foo-a) :allocation :class)
-     (b :initform (list 'foo-b) :allocation :class)
-     (c :initform (list 'foo-c) :allocation :class)
-     (d :allocation :class)
-     (e :allocation :class)
-     (f :allocation :class)))
-
-(defclass bar (foo)
-    ((b :initform (list 'bar-b) :allocation :class)
-     (c :allocation :class)
-     (e :initform (list 'bar-e) :allocation :class)
-     (f :allocation :class)))
-
-(defmethod slot-missing ((class standard-class)
-                         (instance foo)
-                         slot-name operation &optional new-value)
-  (list* class instance slot-name operation new-value))
-
-(defmethod slot-missing ((class standard-class)
-                         (instance bar)
-                         slot-name operation &optional new-value)
-  (list* class instance slot-name operation new-value))
-
-(defmethod slot-unbound ((class standard-class)
-                         (instance foo)
-                         slot-name)
-  (list class instance slot-name))
-
-(defmethod slot-unbound ((class standard-class)
-                         (instance bar)
-                         slot-name)
-  (list class instance slot-name))
-
-(setq foo1 (make-instance 'foo)
-      bar1 (make-instance 'bar))
-
-(do-test ":allocation :class(:initform/slot-value)"
-  ()
-  (unless (and (equal (slot-value foo1 'a) '(foo-a))
-               (equal (slot-value foo1 'b) '(foo-b))
-               (equal (slot-value foo1 'c) '(foo-c))
-               (equal (slot-value bar1 'a) '(foo-a))
-               (equal (slot-value bar1 'b) '(bar-b))
-               (equal (slot-value bar1 'c) '(foo-c))
-               (equal (slot-value bar1 'e) '(bar-e)))
-    (do-test-error () ":initform/slot-value failed")))
-
-(do-test ":allocation :class(shared by instances of super and sub case)"
-  ()
-  (unless (eq (slot-value foo1 'a)
-              (slot-value bar1 'a))
-    (do-test-error () ":class slot should be shared by instances")))
-
-(do-test ":allocation :class(not shared by instances of super and sub case)"
-  ()
-  (unless (not (eq (slot-value foo1 'c)
-                   (slot-value bar1 'c)))
-    (do-test-error () ":class slot should not be shared by instances")))
-
-(do-test ":allocation :class(slot-boundp)"
-  ()
-  (unless (and (slot-boundp foo1 'a)
-               (slot-boundp foo1 'b)
-               (slot-boundp foo1 'c)
-               (not (slot-boundp foo1 'd))
-               (not (slot-boundp foo1 'e))
-               (not (slot-boundp foo1 'f))
-               (slot-boundp bar1 'a)
-               (slot-boundp bar1 'b)
-               (slot-boundp bar1 'c)
-               (not (slot-boundp bar1 'd))
-               (slot-boundp bar1 'e)
-               (not (slot-boundp bar1 'f)))
-    (do-test-error () "slot-boundp failed")))
-
-(slot-makunbound foo1 'a)
-(slot-makunbound foo1 'b)
-
-(do-test ":allocation :class(slot-makunbound)"
-  ()
-  (unless (and (not (slot-boundp foo1 'a))
-               (not (slot-boundp foo1 'b))
-               (not (slot-boundp bar1 'a))
-               (slot-boundp bar1 'b))
-    (do-test-error () "slot-makunbound failed")))
-
-(setf (slot-value foo1 'a) '(new-foo-a)
-      (slot-value foo1 'b) '(new-foo-b)
-      (slot-value foo1 'c) '(new-foo-c)
-      (slot-value bar1 'b) '(new-bar-b)
-      (slot-value bar1 'e) '(new-bar-e))
-
-(do-test ":allocation :class(slot-value/(setf slot-value))"
-  ()
-  (unless (and (equal (slot-value foo1 'a) '(new-foo-a))
-               (equal (slot-value foo1 'b) '(new-foo-b))
-               (equal (slot-value foo1 'c) '(new-foo-c))
-               (equal (slot-value bar1 'a) '(new-foo-a))
-               (equal (slot-value bar1 'b) '(new-bar-b))
-               (equal (slot-value bar1 'e) '(new-bar-e)))
-    (do-test-error () "slot-value/(setf slot-value failed")))
-
-(do-test ":allocation :class(slot-exists-p)"
-  ()
-  (unless (and (slot-exists-p foo1 'a)
-               (slot-exists-p foo1 'b)
-               (slot-exists-p foo1 'c)
-               (slot-exists-p foo1 'd)
-               (slot-exists-p foo1 'e)
-               (slot-exists-p foo1 'f)
-               (slot-exists-p bar1 'a)
-               (slot-exists-p bar1 'b)
-               (slot-exists-p bar1 'c)
-               (slot-exists-p bar1 'd)
-               (slot-exists-p bar1 'e)
-               (slot-exists-p bar1 'f))
-    (do-test-error () "slot-exist-p failed")))
-
-(do-test ":allocation :class(slot-missing)"
-  ()
-  (unless (and (equal (slot-value foo1 'x)
-                      (list (class-of foo1)
-                            foo1
-                            'x
-                            'slot-value))
-               (equal (setf (slot-value foo1 'x) 'dummy)
-                      (list* (class-of foo1)
-                             foo1
-                             'x
-                             'setf
-                             'dummy))
-               (equal (slot-boundp foo1 'x)
-                      (list (class-of foo1)
-                            foo1
-                            'x
-                            'slot-boundp))
-               
-               (equal (slot-makunbound foo1 'x)
-                      (list (class-of foo1)
-                            foo1
-                            'x
-                            'slot-makunbound))
-               (equal (slot-value bar1 'x)
-                      (list (class-of bar1)
-                            bar1
-                            'x
-                            'slot-value))
-               (equal (setf (slot-value bar1 'x) 'dummy)
-                      (list* (class-of bar1)
-                             bar1
-                             'x
-                             'setf
-                             'dummy))
-               (equal (slot-boundp bar1 'x)
-                      (list (class-of bar1)
-                            bar1
-                            'x
-                            'slot-boundp))
-               
-               (equal (slot-makunbound bar1 'x)
-                      (list (class-of bar1)
-                            bar1
-                            'x
-                            'slot-makunbound)))
-    (do-test-error () "slot-missing failed")))
-
-;;;
-;;; (5/4/89)Testing :allocation :class for funcallable-instance
-;;;
-
-(format t "~%Testing :allocation :class test~
-           (for funcallable-standard-instance)~%")
-         
-(cleanup-do-test '((:classes foo bar)
-                   (:variables foo2 bar2)))
-
-(defclass foo ()
-    ((a :initform (list 'foo-a) :allocation :class)
-     (b :initform (list 'foo-b) :allocation :class)
-     (c :initform (list 'foo-c) :allocation :class)
-     (d :allocation :class)
-     (e :allocation :class)
-     (f :allocation :class))
-  (:metaclass funcallable-standard-class))
-
-(defclass bar (foo)
-    ((b :initform (list 'bar-b) :allocation :class)
-     (c :allocation :class)
-     (e :initform (list 'bar-e) :allocation :class)
-     (f :allocation :class))
-  (:metaclass funcallable-standard-class))
-
-(defmethod slot-missing ((class standard-class)
-                         (instance foo)
-                         slot-name operation &optional new-value)
-  (list* class instance slot-name operation new-value))
-
-(defmethod slot-missing ((class standard-class)
-                         (instance bar)
-                         slot-name operation &optional new-value)
-  (list* class instance slot-name operation new-value))
-
-(defmethod slot-unbound ((class standard-class)
-                         (instance foo)
-                         slot-name)
-  (list class instance slot-name))
-
-(defmethod slot-unbound ((class standard-class)
-                         (instance bar)
-                         slot-name)
-  (list class instance slot-name))
-
-(setq foo2 (make-instance 'foo)
-      bar2 (make-instance 'bar))
-
-(do-test ":allocation :class(:initform/slot-value)"
-  ()
-  (unless (and (equal (slot-value foo2 'a) '(foo-a))
-               (equal (slot-value foo2 'b) '(foo-b))
-               (equal (slot-value foo2 'c) '(foo-c))
-               (equal (slot-value bar2 'a) '(foo-a))
-               (equal (slot-value bar2 'b) '(bar-b))
-               (equal (slot-value bar2 'c) '(foo-c))
-               (equal (slot-value bar2 'e) '(bar-e)))
-    (do-test-error () ":initform/slot-value failed")))
-
-(do-test ":allocation :class(shared by instances of super and sub case)"
-  ()
-  (unless (eq (slot-value foo2 'a)
-              (slot-value bar2 'a))
-    (do-test-error () ":class slot should be shared by instances")))
-
-(do-test ":allocation :class(not shared by instances of super and sub case)"
-  ()
-  (unless (not (eq (slot-value foo2 'c)
-                   (slot-value bar2 'c)))
-    (do-test-error () ":class slot should not be shared by instances")))
-
-(do-test ":allocation :class(slot-boundp)"
-  ()
-  (unless (and (slot-boundp foo2 'a)
-               (slot-boundp foo2 'b)
-               (slot-boundp foo2 'c)
-               (not (slot-boundp foo2 'd))
-               (not (slot-boundp foo2 'e))
-               (not (slot-boundp foo2 'f))
-               (slot-boundp bar2 'a)
-               (slot-boundp bar2 'b)
-               (slot-boundp bar2 'c)
-               (not (slot-boundp bar2 'd))
-               (slot-boundp bar2 'e)
-               (not (slot-boundp bar2 'f)))
-    (do-test-error () "slot-boundp failed")))
-
-(slot-makunbound foo2 'a)
-(slot-makunbound foo2 'b)
-
-(do-test ":allocation :class(slot-makunbound)"
-  ()
-  (unless (and (not (slot-boundp foo2 'a))
-               (not (slot-boundp foo2 'b))
-               (not (slot-boundp bar2 'a))
-               (slot-boundp bar2 'b))
-    (do-test-error () "slot-makunbound failed")))
-
-(setf (slot-value foo2 'a) '(new-foo-a)
-      (slot-value foo2 'b) '(new-foo-b)
-      (slot-value foo2 'c) '(new-foo-c)
-      (slot-value bar2 'b) '(new-bar-b)
-      (slot-value bar2 'e) '(new-bar-e))
-
-(do-test ":allocation :class(slot-value/(setf slot-value))"
-  ()
-  (unless (and (equal (slot-value foo2 'a) '(new-foo-a))
-               (equal (slot-value foo2 'b) '(new-foo-b))
-               (equal (slot-value foo2 'c) '(new-foo-c))
-               (equal (slot-value bar2 'a) '(new-foo-a))
-               (equal (slot-value bar2 'b) '(new-bar-b))
-               (equal (slot-value bar2 'e) '(new-bar-e)))
-    (do-test-error () "slot-value/(setf slot-value failed")))
-
-(do-test ":allocation :class(slot-exists-p)"
-  ()
-  (unless (and (slot-exists-p foo2 'a)
-               (slot-exists-p foo2 'b)
-               (slot-exists-p foo2 'c)
-               (slot-exists-p foo2 'd)
-               (slot-exists-p foo2 'e)
-               (slot-exists-p foo2 'f)
-               (slot-exists-p bar2 'a)
-               (slot-exists-p bar2 'b)
-               (slot-exists-p bar2 'c)
-               (slot-exists-p bar2 'd)
-               (slot-exists-p bar2 'e)
-               (slot-exists-p bar2 'f))
-    (do-test-error () "slot-exist-p failed")))
-
-;(do-test ":allocation :class(slot-missing)"
-;  ()
-;  (unless (and (equal (slot-value foo2 'x)
-;                      (list (class-of foo2)
-;                            foo2
-;                              'x
-;                            'slot-value))
-;               (equal (setf (slot-value foo2 'x) 'dummy)
-;                      (list* (class-of foo2)
-;                             foo2
-;                             'x
- ;                            'setf
-;                             'dummy))
-;               (equal (slot-boundp foo2 'x)
-;                      (list (class-of foo2)
-;                            foo2
-;                            'x
-;                            'slot-boundp))
-;               
-;               (equal (slot-makunbound foo2 'x)
-;                      (list (class-of foo2)
-;                            foo2
-;                            'x
-;                            'slot-makunbound))
-;               (equal (slot-value bar2 'x)
-;                      (list (class-of bar2)
-;                            bar2
-;                            'x
-;                            'slot-value))
-;               (equal (setf (slot-value bar2 'x) 'dummy)
-;                      (list* (class-of bar2)
-;                             bar2
-;                             'x
-;                             'setf
-;                             'dummy))
-;               (equal (slot-boundp bar2 'x)
-;                      (list (class-of bar2)
-;                            bar2
-;                            'x
-;                            'slot-boundp))
-;               
-;               (equal (slot-makunbound bar2 'x)
-;                      (list (class-of bar2)
-;                            bar2
-;                            'x
-;                            'slot-makunbound)))
-;    (do-test-error () "slot-missing failed")))
-
-
-
diff --git a/obsolete/clos/2.0/unchaged.lisp b/obsolete/clos/2.0/unchaged.lisp
deleted file mode 100644
index 4116cfd3..00000000
--- a/obsolete/clos/2.0/unchaged.lisp
+++ /dev/null
@@ -1,22 +0,0 @@
-boot
-braid
-cache
-combin
-compat
-construct
-cpl
-defcombin
-defs
-dlap
-env
-fixup
-fngen
-fsc
-lap
-methods
-plap
-precom2
-precom4
-test
-vector
-walk
\ No newline at end of file
diff --git a/obsolete/clos/2.0/vector.lisp b/obsolete/clos/2.0/vector.lisp
deleted file mode 100644
index 5f613f84..00000000
--- a/obsolete/clos/2.0/vector.lisp
+++ /dev/null
@@ -1,368 +0,0 @@
-;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;;
-;;; Permutation vectors.
-;;;
-
-(in-package 'clos)
-
-(defmacro instance-slot-index (wrapper slot-name)
-  `(let ((pos 0))
-     (block loop
-       (dolist (sn (wrapper-instance-slots-layout ,wrapper))
-	 (when (eq ,slot-name sn) (return-from loop pos))
-	 (incf pos)))))
-
-
-;;;
-;;;
-;;;
-(defmacro %isl-cache           (isl) `(%svref ,isl 1))
-(defmacro %isl-field           (isl) `(%svref ,isl 2))
-(defmacro %isl-mask            (isl) `(%svref ,isl 3))
-(defmacro %isl-size            (isl) `(%svref ,isl 4))
-(defmacro %isl-slot-name-lists (isl) `(%svref ,isl 5))
-
-(defun make-isl (slot-name-lists)
-  (multiple-value-bind (mask size)
-      (compute-primary-pv-cache-size slot-name-lists)
-    (make-isl-internal (wrapper-field 'number)
-		       (get-cache size)
-		       mask
-		       size
-		       slot-name-lists)))
-
-(defun make-isl-internal (field cache mask size slot-name-lists)  
-  (let ((isl (make-array 6)))
-    (setf (svref isl 0)               'isl
-	  (%isl-cache isl)            cache
-	  (%isl-field isl)            field
-	  (%isl-mask  isl)            mask
-	  (%isl-size  isl)            size
-	  (%isl-slot-name-lists isl)  slot-name-lists)
-    isl))
-
-(defun make-isl-type-declaration (var)
-  `(type simple-vector ,var))
-
-(defun islp (x)
-  (and (simple-vector-p x)
-       (= (array-dimension x 0) 5)
-       (eq (svref x 0) 'isl)))
-
-(defvar *slot-name-lists-inner* (make-hash-table :test #'equal))
-(defvar *slot-name-lists-outer* (make-hash-table :test #'equal))
-
-(defun intern-slot-name-lists (slot-name-lists)
-  (flet ((inner (x) 
-	   (or (gethash x *slot-name-lists-inner*)
-	       (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
-	 (outer (x) 
-	   (or (gethash x *slot-name-lists-outer*)
-	       (setf (gethash x *slot-name-lists-outer*) (make-isl (copy-list x))))))
-    (outer (mapcar #'inner slot-name-lists))))
-
-
-
-(defvar *pvs* (make-hash-table :test #'equal))
-
-(defvar default-svuc-method nil)
-(defvar default-setf-svuc-method nil)
-
-(defun optimize-slot-value-by-class-p (class slot-name setf-p)
-  (or (not (eq *boot-state* 'complete))
-      (let* ((slot-definition (find-slot-definition class slot-name))
-	     (gfun-name (if setf-p
-			    '(setf slot-value-using-class) 'slot-value-using-class))
-	     (gfun (gdefinition gfun-name))
-	     (csym (if setf-p 'default-setf-svuc-method 'default-svuc-method))
-	     (app-methods nil))
-	(dolist (method (generic-function-methods gfun))
-	  (let* ((mspecs (method-specializers method))
-		 (specs (if setf-p (cdr mspecs) mspecs)))
-	    (when (and (specializer-applicable-p (first specs) class)
-		       (specializer-applicable-using-class-p (second specs) class)
-		       (specializer-applicable-p (third specs) slot-definition))
-	      (push method app-methods))))
-	(and app-methods (null (cdr app-methods))
-	     (eq (car app-methods)
-		 (or (symbol-value csym)
-		     (let* ((specs (if setf-p
-				       '(t
-					 std-class 
-					 standard-object
-					 standard-effective-slot-definition)
-				       '(std-class 
-					 standard-object
-					 standard-effective-slot-definition)))
-			    (slist (mapcar #'find-class specs)))
-		       (set csym (get-method gfun nil slist)))))))))
-
-(defun lookup-pv (isl args)
-  (let* ((class-slot-p nil)
-	 (elements
-	  (gathering1 (collecting)
-	    (iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
-		      (arg (list-elements args)))
-	      (when slot-names
-		(let* ((wrapper     (check-wrapper-validity arg))
-		       (class       (wrapper-class wrapper))
-		       (class-slots (wrapper-class-slots wrapper)))
-		  (dolist (slot-name slot-names)
-		    (if (and (optimize-slot-value-by-class-p
-			      class slot-name nil)
-			     (optimize-slot-value-by-class-p
-			      class slot-name t))
-			(let ((index (instance-slot-index wrapper slot-name)))
-			  (if index
-			      (gather1 index)
-			      (let ((cell (assq slot-name class-slots)))
-				(if cell
-				    (progn (setq class-slot-p t) (gather1 cell))
-				    (gather1 nil)))))
-			(gather1 nil)))))))))
-    (if class-slot-p				;Sure is a shame Common Lisp doesn't
-	(make-permutation-vector elements)	;give me the right kind of hash table.
-	(or (gethash elements *pvs*)
-	    (setf (gethash elements *pvs*) (make-permutation-vector elements))))))
-
-(defun make-permutation-vector (indexes)
-  (make-array (length indexes) :initial-contents indexes))
-
-(defun make-pv-type-declaration (var)
-  `(type simple-vector ,var))
-
-(defmacro pvref (pv index)
-  `(svref ,pv ,index))
-
-
-
-(defun can-optimize-access (var required-parameters env)
-  (let ((rebound? (caddr (variable-declaration 'variable-rebinding var env))))
-    (if rebound?
-	(car (memq rebound? required-parameters))
-	(car (memq var required-parameters)))))
-
-(defun optimize-slot-value (slots parameter form)
-  (destructuring-bind (ignore ignore slot-name)
-		      form
-    (optimize-instance-access slots :read parameter (eval slot-name) nil)))
-
-(defun optimize-set-slot-value (slots parameter form)
-  (destructuring-bind (ignore ignore slot-name new-value)
-		      form
-    (optimize-instance-access slots :write parameter (eval slot-name) new-value)))
-
-;;;
-;;; The <slots> argument is an alist, the CAR of each entry is the name of
-;;; a required parameter to the function.  The alist is in order, so the
-;;; position of an entry in the alist corresponds to the argument's position
-;;; in the lambda list.
-;;; 
-(defun optimize-instance-access (slots read/write parameter slot-name new-value)
-  (let* ((parameter-entry (assq parameter slots))
-	 (slot-entry      (assq slot-name (cdr parameter-entry)))
-	 (position (position parameter-entry slots)))
-    (unless parameter-entry
-      (error "Internal error in slot optimization."))
-    (unless slot-entry
-      (setq slot-entry (list slot-name))
-      (push slot-entry (cdr parameter-entry)))
-    (ecase read/write
-      (:read
-	(let ((form (list 'instance-read ''.PV-OFFSET. parameter position 
-			  `',slot-name)))
-	  (push form (cdr slot-entry))
-	  form))
-      (:write
-	(let ((form (list 'instance-write ''.PV-OFFSET. parameter position 
-			  `',slot-name '.new-value.)))
-	  (push form (cdr slot-entry))
-	  `(let ((.new-value. ,new-value)) ,form))))))
-
-(define-walker-template instance-read)
-(define-walker-template instance-write)
-
-
-(defmacro instance-read (pv-offset parameter position slot-name)
-  `(locally
-     (declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
-     (let ((.INDEX. (pvref .PV. ,pv-offset)))
-       (if (and (typep .INDEX. 'fixnum)
-		(neq (setq .INDEX. (%svref ,(slot-vector-symbol position) .INDEX.))
-		     ',*slot-unbound*))
-	   .INDEX.
-	   (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name)))))
-
-(defmacro instance-write (pv-offset parameter position slot-name new-value)
-  `(locally
-     (declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
-     (let ((.INDEX. (pvref .PV. ,pv-offset)))
-       (if (typep .INDEX. 'fixnum)
-	   (setf (%svref ,(slot-vector-symbol position) .INDEX.) ,new-value)
-	   (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name ,new-value)))))
-
-(defun pv-access-trap (instance pv offset slot-name &optional (new-value nil nvp))
-  ;;
-  ;; First thing we do is a quick check to see if this is a class variable.
-  ;; This could be done inline by moving it to INSTANCE-READ/WRITE.  I did
-  ;; not do that because I don't know whether its worth it.
-  ;;
-  (let ((cell (pvref pv offset)))
-    (if (consp cell)
-	(if nvp (setf (cdr cell) new-value) (cdr cell))
-	;;
-	;; Well, now do a slow trap.
-	;; 
-	(if nvp
-	    (setf (slot-value instance slot-name) new-value)
-	    (slot-value instance slot-name)))))
-
-;;;
-;;; This magic function has quite a job to do indeed.
-;;;
-;;; The careful reader will recall that <slots> contains all of the optimized
-;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.  Each of these is
-;;; a call to either INSTANCE-READ or INSTANCE-WRITE.
-;;;
-;;; At the time these calls were produced, the first argument was specified as
-;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset
-;;; arguments into the actual number that is the correct offset into the pv.
-;;;
-;;; But first, oh but first, we sort <slots> a bit so that for each argument
-;;; we have the slots in alphabetical order.  This canonicalizes the ISL's a
-;;; bit and will hopefully lead to having fewer PV's floating around.  Even
-;;; if the gain is only modest, it costs nothing.
-;;;  
-(defun slot-name-lists-from-slots (slots)
-  (mapcar #'(lambda (parameter-entry) (mapcar #'car (cdr parameter-entry)))
-	  (mutate-slots slots)))
-
-(defun mutate-slots (slots)
-  (let ((sorted (sort-slots slots))
-	(pv-offset -1))
-    (dolist (parameter-entry sorted)
-      (dolist (slot-entry (cdr parameter-entry))
-	(incf pv-offset)	
-	(dolist (form (cdr slot-entry))
-	  (setf (cadr form) pv-offset))))
-    sorted))
-
-(defun sort-slots (slots)
-  (mapcar #'(lambda (parameter-entry)
-	      (cons (car parameter-entry)
-		    (sort (cdr parameter-entry)	;slot entries
-			  #'(lambda (a b)
-			      (string-lessp (symbol-name (car a))
-					    (symbol-name (car b)))))))
-	  slots))
-
-
-;;;
-;;; This needs to work in terms of metatypes and also needs to work for
-;;; automatically generated reader and writer functions.
-;;;   
-(defun add-pv-binding (method-body plist required-parameters)
-  (let* ((isl (getf plist :isl))
-	 (isl-cache-symbol (make-symbol "isl-cache")))
-    (nconc plist (list :isl-cache-symbol isl-cache-symbol))
-    (with-gathering ((slot-variables (collecting))
-		     (metatypes (collecting)))
-	  (iterate ((slots (list-elements isl))
-		    (i (interval :from 0)))
-	    (cond (slots
-		   (gather (slot-vector-symbol i) slot-variables)
-		   (gather 'standard-instance     metatypes))
-		  (t
-		   (gather nil slot-variables)
-		   (gather t   metatypes))))
-      `((let ((.ISL. (locally (declare (special ,isl-cache-symbol)) ,isl-cache-symbol))
-	      (.PV. *empty-vector*)
-	      ,@(remove nil slot-variables))
-	  (declare ,(make-isl-type-declaration '.ISL.)
-		   ,(make-pv-type-declaration '.PV.))
-	
-	  (let* ((cache (%isl-cache .ISL.))
-		 (size  (%isl-size  .ISL.))
-		 (mask  (%isl-mask  .ISL.))
-		 (field (%isl-field .ISL.)))
-	    ,(generating-lap-in-lisp '(cache size mask field)
-				     required-parameters
-	       (flatten-lap
-		 (emit-pv-dlap required-parameters metatypes slot-variables))))
-
-	  ,@method-body)))))
-
-(defun emit-pv-dlap (required-parameters metatypes slot-variables)
-  (let* ((slot-regs (mapcar #'(lambda (sv) (and sv (operand :lisp-variable sv)))
-			    slot-variables))
-	 (wrappers (dlap-wrappers metatypes))
-	 (nwrappers (remove nil wrappers)))
-    (flet ((wrapper-moves (miss-label)
-	     (dlap-wrapper-moves wrappers required-parameters metatypes miss-label slot-regs)))
-      (prog1 (emit-dlap-internal
-	       nwrappers                   ;wrapper-regs
-	       (wrapper-moves 'pv-miss)    ;wrapper-moves
-	       (opcode :exit-lap-in-lisp)  ;hit
-	       (flatten-lap		   ;miss
-		 (opcode :label 'pv-miss)
-		 (opcode :move
-			 (operand :lisp `(primary-pv-cache-miss
-					  .ISL. ,@required-parameters))
-			 (operand :lisp-variable '.PV.))
-		 (apply #'flatten-lap (wrapper-moves 'pv-wrapper-miss)) ; -- Maybe the wrappers have changed.
-		 (opcode :label 'pv-wrapper-miss)
-		 (opcode :exit-lap-in-lisp))                               
-	       'pv-miss			    ;miss-label
-	       (operand :lisp-variable '.PV.)) ;value-reg
-	   (mapc #'deallocate-register nwrappers)))))
-
-(defun compute-primary-pv-cache-size (slot-name-lists)
-  (compute-cache-parameters (- (length slot-name-lists) (count nil slot-name-lists))
-			    t
-			    2))
-
-(defun pv-cache-limit-fn (nlines)
-  (default-limit-fn nlines))
-
-(defun primary-pv-cache-miss (isl &rest args)
-  (let* ((wrappers
-	   (gathering1 (collecting) 
-	     (iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
-		       (arg        (list-elements args)))
-	       (when slot-names (gather1 (check-wrapper-validity arg))))))
-	 (pv (lookup-pv isl args))
-	 (field (%isl-field isl))
-	 (cache (%isl-cache isl))
-	 (nkeys (length wrappers)))
-    (multiple-value-bind (new-field new-cache new-mask new-size)
-	(fill-cache field cache nkeys t #'pv-cache-limit-fn
-		    (if (= nkeys 1) (car wrappers) wrappers)
-		    pv)
-      (when (or (not (= new-field field))
-		(not (eq new-cache cache)))
-	(without-interrupts			;NOTE:
-	  (setf (%isl-field isl) new-field	; There is no mechanism to
-		(%isl-cache isl) new-cache	; synchronize the reading of
-		(%isl-size  isl) new-size	; these values.  But, this is
-		(%isl-mask  isl) new-mask))	; a safe order to write them
-						; in.  Stricly speaking, the
-						; use of without-interrupts
-						; is superfluous.
-	(when (neq new-cache cache) (free-cache cache))))
-    pv))
-
-
-
-(defmethod wrapper-fetcher ((class standard-class))
-  'std-instance-wrapper)
-
-(defmethod slots-fetcher ((class standard-class))
-  'std-instance-slots)
-
-(defmethod raw-instance-allocator ((class standard-class))
-  '%%allocate-instance--class)
diff --git a/obsolete/clos/2.0/walk.lisp b/obsolete/clos/2.0/walk.lisp
deleted file mode 100644
index 2172c050..00000000
--- a/obsolete/clos/2.0/walk.lisp
+++ /dev/null
@@ -1,2005 +0,0 @@
-;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*-
-;;;
-;;; *************************************************************************
-;;; Copyright (c) 1991 Venue
-;;; All rights reserved.
-;;; *************************************************************************
-;;; 
-;;; A simple code walker, based IN PART on: (roll the credits)
-;;;   Larry Masinter's Masterscope
-;;;   Moon's Common Lisp code walker
-;;;   Gary Drescher's code walker
-;;;   Larry Masinter's simple code walker
-;;;   .
-;;;   .
-;;;   boy, thats fair (I hope).
-;;;
-;;; For now at least, this code walker really only does what CLOS needs it to
-;;; do.  Maybe it will grow up someday.
-;;;
-
-;;;
-;;; This code walker used to be completely portable.  Now it is just "Real
-;;; easy to port".  This change had to happen because the hack that made it
-;;; completely portable kept breaking in different releases of different
-;;; Common Lisps, and in addition it never worked entirely anyways.  So,
-;;; its now easy to port.  To port this walker, all you have to write is one
-;;; simple macro and two simple functions.  These macros and functions are
-;;; used by the walker to manipluate the macroexpansion environments of
-;;; the Common Lisp it is running in.
-;;;
-;;; The code which implements the macroexpansion environment manipulation
-;;; mechanisms is in the first part of the file, the real walker follows it.
-;;; 
-
-(in-package 'walker)
-
-;;;
-;;; The user entry points are walk-form and nested-walked-form.  In addition,
-;;; it is legal for user code to call the variable information functions:
-;;; variable-lexical-p, variable-special-p and variable-class.  Some users
-;;; will need to call define-walker-template, they will have to figure that
-;;; out for themselves.
-;;; 
-(export '(define-walker-template
-	  walk-form
-	  nested-walk-form
-	  variable-lexical-p
-	  variable-special-p
-	  variable-globally-special-p
-	  *variable-declarations*
-	  variable-declaration
-	  ))
-
-
-
-;;;
-;;; On the following pages are implementations of the implementation specific
-;;; environment hacking functions for each of the implementations this walker
-;;; has been ported to.  If you add a new one, so this walker can run in a new
-;;; implementation of Common Lisp, please send the changes back to us so that
-;;; others can also use this walker in that implementation of Common Lisp.
-;;;
-;;; This code just hacks 'macroexpansion environments'.  That is, it is only
-;;; concerned with the function binding of symbols in the environment.  The
-;;; walker needs to be able to tell if the symbol names a lexical macro or
-;;; function, and it needs to be able to build environments which contain
-;;; lexical macro or function bindings.  It must be able, when walking a
-;;; macrolet, flet or labels form to construct an environment which reflects
-;;; the bindings created by that form.  Note that the environment created
-;;; does NOT have to be sufficient to evaluate the body, merely to walk its
-;;; body.  This means that definitions do not have to be supplied for lexical
-;;; functions, only the fact that that function is bound is important.  For
-;;; macros, the macroexpansion function must be supplied.
-;;;
-;;; This code is organized in a way that lets it work in implementations that
-;;; stack cons their environments.  That is reflected in the fact that the
-;;; only operation that lets a user build a new environment is a with-body
-;;; macro which executes its body with the specified symbol bound to the new
-;;; environment.  No code in this walker or in CLOS will hold a pointer to
-;;; these environments after the body returns.  Other user code is free to do
-;;; so in implementations where it works, but that code is not considered
-;;; portable.
-;;;
-;;; There are 3 environment hacking tools.  One macro which is used for
-;;; creating new environments, and two functions which are used to access the
-;;; bindings of existing environments.
-;;;
-;;; WITH-AUGMENTED-ENVIRONMENT
-;;;
-;;; ENVIRONMENT-FUNCTION
-;;;
-;;; ENVIRONMENT-MACRO
-;;; 
-
-(defun unbound-lexical-function (&rest args)
-  (declare (ignore args))
-  (error "The evaluator was called to evaluate a form in a macroexpansion~%~
-          environment constructed by the CLOS portable code walker.  These~%~
-          environments are only useful for macroexpansion, they cannot be~%~
-          used for evaluation.~%~
-          This error should never occur when using CLOS.~%~
-          This most likely source of this error is a program which tries to~%~
-          to use the CLOS portable code walker to build its own evaluator."))
-
-
-;;;
-;;; In Coral Common Lisp, the macroexpansion environment is just a list
-;;; of environment entries.  The cadr of each element specifies the type
-;;; of the element.  The only types that interest us are CCL::MACRO and
-;;; FUNCTION.  In these cases the element is interpreted as follows.
-;;;
-;;;   (<function-name> CCL::MACRO . macroexpansion-function)
-;;;   
-;;;   (<function-name> FUNCTION . <fn>)
-;;;   
-;;;   When in the compiler, <fn> is a gensym which will be
-;;;   a variable which bound at run-time to the function.
-;;;   When in the interpreter, <fn> is the actual function.
-;;;   
-;;;
-#+:Coral
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  (dolist (f functions)
-    (push (list* f 'function (gensym)) env))
-  (dolist (m macros)
-    (push (list* (car m) 'ccl::macro (cadr m)) env))
-  env)
-
-(defun environment-function (env fn)
-  (let ((entry (assoc fn env :test #'equal)))
-    (and entry
-	 (eq (cadr entry) 'function)
-	 (cddr entry))))
-
-(defun environment-macro (env macro)
-  (let ((entry (assoc macro env :test #'equal)))
-    (and entry
-	 (eq (cadr entry) 'ccl::macro)
-	 (cddr entry))))
-
-);#+:Coral
-
-
-;;;
-;;; Franz Common Lisp is a lot like Coral Lisp.  The macroexpansion
-;;; environment is just a list of entries.  The cadr of each element
-;;; specifies the type of the element.  The types that interest us
-;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE.  These
-;;; are interpreted as follows:
-;;;
-;;;   (<function-name> FUNCTION . <a lexical closure>)
-;;;
-;;;      This happens in the interpreter with lexically
-;;;      bound functions.
-;;;
-;;;   (<function-name> COMPILER::FUNCTION-VALUE . <gensym>)
-;;;
-;;;      This happens in the compiler.  The gensym represents
-;;;      a variable which will be bound at run time to the
-;;;      function object.
-;;;
-;;;   (<function-name> EXCL::MACRO . <a lambda>)
-;;;
-;;;      In both interpreter and compiler, this is the
-;;;      representation used for macro definitions.
-;;;   
-;;;
-#+:ExCL
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  (dolist (f functions)
-    (push (list* f 'function #'unbound-lexical-function) env))
-  (dolist (m macros)
-    (push (list* (car m) 'excl::macro (cadr m)) env))
-  env)
-
-(defun environment-function (env fn)
-  (let ((entry (assoc fn env :test #'equal)))
-    (and entry
-	 (or (eq (cadr entry) 'function)
-	     (eq (cadr entry) 'compiler::function-value))
-	 (cddr entry))))
-
-(defun environment-macro (env macro)
-  (let ((entry (assoc macro env :test #'equal)))
-    (and entry
-	 (eq (cadr entry) 'excl::macro)
-	 (cddr entry))))
-
-);#+:ExCL
-
-
-#+Lucid
-(progn
-  
-(proclaim '(inline
-	    %alphalex-p
-	    add-contour-to-env-shape
-	    make-function-variable
-	    make-sfc-contour
-	    sfc-contour-type
-	    sfc-contour-elements
-	    add-sfc-contour
-	    add-function-contour
-	    add-macrolet-contour
-	    find-variable-in-contour
-	    find-alist-element-in-contour
-	    find-macrolet-in-contour))
-
-(defun %alphalex-p (object)
-  #-Prime
-  (eq (cadddr (cddddr object)) 'lucid::%alphalex)
-  #+Prime
-  (eq (caddr (cddddr object)) 'lucid::%alphalex))
-
-#+Prime 
-(defun lucid::augment-lexenv-fvars-dummy (lexical vars)
-  (lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '()))
-
-(defconstant function-contour 1)
-(defconstant macrolet-contour 5)
-
-(defstruct lucid::contour
-  type
-  elements)
-
-(defun add-contour-to-env-shape (contour-type elements env-shape)
-  (cons (make-contour :type contour-type
-		      :elements elements)
-	env-shape))
-
-(defstruct (variable (:constructor make-variable (name source-type)))
-  name
-  (identifier nil)
-  source-type)
-
-(defconstant function-sfc-contour 1)
-(defconstant macrolet-sfc-contour 8)
-(defconstant function-variable-type 1)
-
-(defun make-function-variable (name)
-  (make-variable name function-variable-type))
-
-(defun make-sfc-contour (type elements)
-  (cons type elements))
-
-(defun sfc-contour-type (sfc-contour)
-  (car sfc-contour))
-
-(defun sfc-contour-elements (sfc-contour)
-  (cdr sfc-contour))
-
-(defun add-sfc-contour (element-list environment type)
-  (cons (make-sfc-contour type element-list) environment))
-
-(defun add-function-contour (variable-list environment)
-  (add-sfc-contour variable-list environment function-sfc-contour))
-
-(defun add-macrolet-contour (alist environment)
-  (add-sfc-contour alist environment macrolet-sfc-contour))
-
-(defun find-variable-in-contour (name contour)
-  (dolist (element (sfc-contour-elements contour) nil)
-    (when (eq (variable-name element) name)
-      (return element))))
-
-(defun find-alist-element-in-contour (name contour)
-  (cdr (assoc name (sfc-contour-elements contour))))
-
-(defun find-macrolet-in-contour (name contour)
-  (find-alist-element-in-contour name contour))
-
-(defmacro do-sfc-contours ((contour-var environment &optional result)
-			   &body body)
-  `(dolist (,contour-var ,environment ,result) ,@body))
-
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)     
-  `(let* ((,new-env (with-augmented-environment-internal ,old-env
-							 ,functions
-							 ,macros)))
-     ,@body))
-
-;;;
-;;; with-augmented-environment-internal is where the real work of augmenting
-;;; the environment happens.
-;;; 
-(defun with-augmented-environment-internal (env functions macros)
-  (let ((function-names (mapcar #'first functions))
-	(macro-names (mapcar #'first macros))
-	(macro-functions (mapcar #'second macros)))
-    (cond ((or (null env)
-	       (contour-p (first env)))
-	   (when function-names
-	     (setq env (add-contour-to-env-shape function-contour
-						 function-names
-						 env)))
-	   (when macro-names
-	     (setq env (add-contour-to-env-shape macrolet-contour
-						 (pairlis macro-names
-							  macro-functions)
-						 env))))
-	  ((%alphalex-p env)
-	   (when function-names
-	     (setq env (lucid::augment-lexenv-fvars-dummy env function-names)))
-	   (when macro-names
-	     (setq env (lucid::augment-lexenv-mvars env
-						    macro-names
-						    macro-functions))))
-	  (t
-	   (when function-names
-	     (setq env (add-function-contour
-			 (mapcar #'make-function-variable function-names)
-			 env)))
-	   (when macro-names
-	     (setq env (add-macrolet-contour
-			 (pairlis macro-names macro-functions)
-			 env)))))
-    env))
-	 
-
-(defun environment-function (env fn)
-  (cond ((null env) nil)
-	((contour-p (first env))
-	 (if (lucid::find-lexical-function fn env)
-	     t
-	     nil))
-	((%alphalex-p env)
-	 (if (lucid::lexenv-fvar fn env)
-	     t
-	     nil))
-	(t (do-sfc-contours (contour env nil)
-	     (let ((type (sfc-contour-type contour)))
-	       (cond ((eql type function-sfc-contour)
-		      (when (find-variable-in-contour fn contour)
-			(return t)))
-		     ((eql type macrolet-sfc-contour)
-		      (when (find-macrolet-in-contour fn contour)
-			(return nil)))))))))
-		      
-(defun environment-macro (env macro)
-  (cond ((null env) nil)
-	((contour-p (first env))
-	 (lucid::find-lexical-macro macro env))
-	((%alphalex-p env)
-	 (lucid::lexenv-mvar macro env))
-	(t (do-sfc-contours (contour env nil)
-	     (let ((type (sfc-contour-type contour)))
-	       (cond ((eql type function-sfc-contour)
-		      (when (find-variable-in-contour macro contour)
-			(return nil)))
-		     ((eql type macrolet-sfc-contour)
-		      (let ((fn (find-macrolet-in-contour macro contour)))
-			(when fn
-			  (return fn))))))))))
-  
-
-);#+Lucid
-
-
-
-;;;
-;;; On the 3600, the documentation for how the environments are represented
-;;; is in sys:sys;eval.lisp.  That total information is not repeated here.
-;;; The important points are that:
-;;;    si:env-variables returns a list of which each element is:
-;;;
-;;;		(symbol value)
-;;;	     or (symbol . locative)
-;;;
-;;;	The first form is for lexical variables, the second for
-;;;	special and instance variables.  In either case CADR of
-;;;	the entry is the value and SETF of CADR is used to change
-;;;	the value.  Variables are looked up with ASSQ.
-;;;
-;;;    si:env-functions returns a list of which each element is:
-;;;     
-;;;		(symbol definition)
-;;;
-;;;	where definition is anything that could go in a function cell.
-;;;	This is used for both local functions and local macros.
-;;;
-;;; The 3600 stack conses its environments (at least in the interpreter).
-;;; This means that code written using this walker and running on the 3600
-;;; must not hold on to the environment after the walk-function returns.
-;;; No code in this walker or in CLOS does that.
-;;;
-#+Genera
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  (let ((funs (make-symbol "FNS"))
-	(macs (make-symbol "MACROS"))
-	(new  (make-symbol "NEW")))
-    `(let ((,funs ,functions)
-	   (,macs ,macros)
-	   (,new ()))
-       (dolist (f ,funs)
-	 (push `(,(car f) ,#'unbound-lexical-function) ,new))
-       (dolist (m ,macs)
-	 (push `(,(car m) (special ,(cadr m))) ,new))
-       (let* ((.old-env. ,old-env)
-	      (.old-vars. (pop .old-env.))
-	      (.old-funs. (pop .old-env.))
-	      (.old-blks. (pop .old-env.))
-	      (.old-tags. (pop .old-env.))
-	      (.old-dcls. (pop .old-env.)))
-	 (si:with-interpreter-environment (,new-env
-					   .old-env.
-					   .old-vars.
-					   (append ,new .old-funs.)
-					   .old-blks.
-					   .old-tags.
-					   .old-dcls.)
-	   ,@body)))))
-  
-
-(defun environment-function (env fn)
-  (if (null env)
-      (values nil nil)
-      (let ((entry (assoc fn (si:env-functions env) :test #'equal)))
-	(if (and entry
-		 (or (not (listp (cadr entry)))
-		     (not (eq (caadr entry) 'special))))
-	    (values (cadr entry) t)
-	    (environment-function (si:env-parent env) fn)))))
-
-(defun environment-macro (env macro)
-  (if (null env)
-      (values nil nil)
-      (let ((entry (assoc macro (si:env-functions env) :test #'equal)))
-	(if (and entry
-		 (listp (cadr entry))
-		 (eq (caadr entry) 'special))
-	    (values (cadadr entry) t)
-	    (environment-macro (si:env-parent env) macro)))))
-
-);#+Genera
-
-#+Cloe-Runtime
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  functions
-  (dolist (m macros)
-    (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env)))
-  env)
-
-(defun environment-function (env fn)
-  nil)
-
-(defun environment-macro (env macro)
-  (let ((entry (getf env macro)))
-    (if (and (consp entry)
-	     (eq (car entry) 'compiler::macro))
-	(values (cdr entry) t)
-	(values nil nil))))
-
-);#+Cloe-Runtime
-
-
-;;;
-;;; In Xerox Lisp, the compiler and interpreter use different structures for
-;;; the environment.  This doesn't cause a serious problem, the parts of the
-;;; environments we are concerned with are fairly similar.
-;;; 
-#+:Xerox
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)     
-  `(let* ((,new-env (with-augmented-environment-internal ,old-env
-							 ,functions
-							 ,macros)))
-     ,@body))
-
-;;;
-;;; with-augmented-environment-internal is where the real work of augmenting
-;;; the environment happens.  Before it gets there, env had better not be NIL
-;;; anymore because we have to know what kind of environment we are supposed
-;;; to be building up.  This is probably never a real concern in practice.
-;;; It better not be because we don't do anything about it.
-;;; 
-(defun with-augmented-environment-internal (env functions macros)
-  (cond
-     ((compiler::env-p env)
-	(dolist (f functions)
-	   (setq env (compiler::copy-env-with-function
-		       env f :function)))
-	(dolist (m macros)
-	   (setq env (compiler::copy-env-with-function
-	 	  env (car m) :macro (cadr m)))))
-     (t (setq env (if (il:environment-p env)
-		    (il:\\copy-environment env)
-		    (il:\\make-environment)))
-	;; The functions field of the environment is a plist of function names
-	;; and conses like (:function . fn) or (:macro . expansion-fn).
-	;; Note that we can't smash existing entries in this plist since these
-	;; are likely shared with older environments.
-	(dolist (f functions)
-	  (setf (il:environment-functions env)
-		(list* f (cons :function #'unbound-lexical-function)
-		       (il:environment-functions env))))
-	(dolist (m macros)
-	  (setf (il:environment-functions env)
-		(list* (car m) (cons :macro (cadr m))
-		       (il:environment-functions env))))))
-  env)
-
-(defun environment-function (env fn)
-  (cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function))
-	((il:environment-p env) (eq (getf (il:environment-functions env) fn)
-				    :function))
-	(t nil)))
-
-(defun environment-macro (env macro) 
-  (cond ((compiler::env-p env)
-	 (multiple-value-bind (type def)
-	     (compiler:env-fboundp env macro)
-	   (when (eq type :macro) def)))
-	((il:environment-p env)
-	 (xcl:destructuring-bind (type . def)
-	     (getf (il:environment-functions env) macro)
-	   (when (eq type :macro) def)))
-	(t nil)))
-
-);#+:Xerox
-
-
-;;;
-;;; In IBUKI Common Lisp, the macroexpansion environment is a three element
-;;; list.  The second element describes lexical functions and macros.  The 
-;;; function entries in this list have the form 
-;;;     (<name> . (FUNCTION . (<function-value> . nil))
-;;; The macro entries have the form 
-;;;     (<name> . (MACRO . (<macro-value> . nil)).
-;;;
-;;;
-#+(or KCL IBCL)
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-	  `(let ((,new-env (with-augmented-environment-internal ,old-env
-								,functions
-								,macros)))
-	     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  (let ((first (first env))
-	(lexicals (second env))
-	(third (third env)))
-    (dolist (f functions)
-      (push `(,(car f) .  (function  . (,#'unbound-lexical-function . nil)))
-	    lexicals))
-    (dolist (m macros)
-      (push `(,(car m)  .  (macro . ( ,(cadr m) . nil))) 
-	    lexicals))
-    (list first lexicals third)))
-
-(defun environment-function (env fn)
-  (when env
-	(let ((entry (assoc fn (second env))))
-	  (and entry
-	       (eq (cadr entry) 'function)
-	       (caddr entry)))))
-
-(defun environment-macro (env macro)
-  (when env
-	(let ((entry (assoc macro (second env))))
-	  (and entry
-	       (eq (cadr entry) 'macro)
-	       (caddr entry)))))
-);#+(or KCL IBCL)
-
-
-;;;   --- TI Explorer --
-
-;;; An environment is a two element list, whose car we can ignore and
-;;; whose cadr is list of the local-definitions-frames. Each
-;;; local-definitions-frame holds either macros or functions, but not
-;;; both.  Each frame is a plist of <name> <def> <name> <def> ...  where
-;;; <name> is a locative to the function cell of the symbol that names
-;;; the function or macro, and <def> is the new def or NIL if this is function
-;;; redefinition or (cons 'ticl:macro <macro-expansion-function>) if this is a macro
-;;; redefinition.
-;;;
-;;; Here's an example.  For the form:
-;;; (defun foo ()
-;;;   (macrolet ((bar (a b) (list a b))
-;;;	         (bar2 (a b) (list a b)))
-;;;     (flet ((some-local-fn (c d) (print (list c d)))
-;;;	       (another (c d) (print (list c d))))
-;;;       (bar (some-local-fn 1 2) 3))))
-
-;;; the environment arg to macroexpand-1 when called on
-;;; (bar (some-local-fn 1 2) 3)
-;;;is 
-;;;(NIL ((#<DTP-LOCATIVE 4710602> NIL
-;;;       #<DTP-LOCATIVE 4710671> NIL)
-;;;      (#<DTP-LOCATIVE 7346562>
-;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B)))
-;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
-;;;		   (BLOCK BAR ....))
-;;;       #<DTP-LOCATIVE 4710664>
-;;;       (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B)))
-;;;		   (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*)
-;;;		   (BLOCK BAR2 ....))))
-#+TI
-(progn 
-
-;;; from sys:site;macros.lisp
-(eval-when (compile load eval)
-  
-(DEFMACRO MACRO-DEF? (thing)
-  `(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO)))
-
-;; the following macro generates code to check the 'local' environment
-;; for a macro definition for THE SYMBOL <name>. Such a definition would
-;; be set up only by a MACROLET. If a macro definition for <name> is
-;; found, its expander function is returned.
-
-(DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment)
-  `(IF ,local-function-environment
-       (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name))))
-	 (DOLIST (frame  ,local-function-environment)
-	   ;; <value> is nil or a locative
-	   (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame)
-						  vcell))) 
-	     (When value (RETURN (CAR value))))))
-       nil)))
-
- 
-;;;Edited by Reed Hastings         13 Jan 88  16:29
-(defun environment-macro (env macro)
-  "returns what macro-function would, ie. the expansion function"
-  ;;some code picked off macroexpand-1
-  (let* ((local-definitions (cadr env))
-	 (local-def (find-local-definition macro local-definitions)))
-    (if (macro-def? local-def)
-	(cdr local-def))))
-
-;;;Edited by Reed Hastings         13 Jan 88  16:29
-;;;Edited by Reed Hastings         7 Mar 88  19:07
-(defun environment-function (env fn)
-  (let* ((local-definitions (cadr env)))
-    (dolist (frame local-definitions)
-      (let ((val (getf frame
-		       (ticl::locf (symbol-function fn))
-		       :not-found-marker)))
-	(cond ((eq val :not-found-marker))
-	      ((functionp val) (return t))
-	      ((and (listp val)
-		    (eq (car val) 'ticl::macro))
-	       (return nil))
-	      (t
-	       (error "we are confused")))))))
-	     
-
-;;;Edited by Reed Hastings         13 Jan 88  16:29
-;;;Edited by Reed Hastings         7 Mar 88  19:07
-(defun with-augmented-environment-internal (env functions macros)
-  (let ((local-definitions (cadr env))
-	(new-local-fns-frame
-	  (mapcan #'(lambda (fn)
-		      (list (ticl:locf (symbol-function (car fn)))
-			    #'unbound-lexical-function))
-		  functions))
-	 (new-local-macros-frame
-	   (mapcan #'(lambda (m)
-		       (list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m))))
-		   macros)))
-    (when new-local-fns-frame 
-      (push new-local-fns-frame local-definitions))
-    (when new-local-macros-frame
-      (push new-local-macros-frame local-definitions))   
-    `(,(car env) ,local-definitions)))
-
-
-;;;Edited by Reed Hastings         7 Mar 88  19:07
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-);#+TI
-
-
-#+(and dec vax common)
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  #'(lambda (op &optional (arg nil arg-p))
-      (cond ((eq op :macro-function) 
-	     (unless arg-p (error "Invalid environment use."))
-	     (lookup-macro-function arg env functions macros))
-            (arg-p
-	     (error "Invalid environment operation: ~S ~S" op arg))
-            (t
-	     (lookup-macro-function op env functions macros)))))
-
-(defun lookup-macro-function (name env fns macros)
-  (let ((m (assoc name macros)))
-    (cond (m                (cadr m))
-          ((assoc name fns) :function)
-          (env              (funcall env name))
-          (t                nil))))
-
-(defun environment-macro (env macro)
-  (let ((m (and env (funcall env macro))))
-    (and (not (eq m :function)) 
-         m)))
-
-;;; Nobody calls environment-function.  What would it return, anyway?
-);#+(and dec vax common)
-
-
-;;;
-;;; In Golden Common Lisp, the macroexpansion environment is just a list
-;;; of environment entries.  Unless the car of the list is :compiler-menv 
-;;; it is an interpreted environment.  The cadr of each element specifies 
-;;; the type of the element.  The only types that interest us are GCL:MACRO
-;;; and FUNCTION.  In these cases the element is interpreted as follows.
-;;;
-;;; Compiled:
-;;;   (<function-name> <gensym> macroexpansion-function)
-;;;   (<function-name> <fn>)
-;;;   
-;;; Interpreted:
-;;;   (<function-name> GCL:MACRO macroexpansion-function)
-;;;   (<function-name> <fn>)
-;;;   
-;;;   When in the compiler, <fn> is a gensym which will be
-;;;   a variable which bound at run-time to the function.
-;;;   When in the interpreter, <fn> is the actual function.
-;;;   
-;;;
-#+gclisp
-(progn
-
-(defmacro with-augmented-environment
-	  ((new-env old-env &key functions macros) &body body)
-  `(let ((,new-env (with-augmented-environment-internal ,old-env
-							,functions
-							,macros)))
-     ,@body))
-
-(defun with-augmented-environment-internal (env functions macros)
-  (let ((new-entries nil))
-    (dolist (f functions)
-      (push (cons (car f) nil) new-entries))
-    (dolist (m macros)
-      (push (cons (car m)
-		  (if (eq :compiler-menv (car env))
-		      (if (eq (caadr m) 'lisp::lambda)
-			  `(,(gensym) ,(cadr m))
-			`(,(gensym) ,@(cadr m)))
-		    `(gclisp:MACRO ,@(cadr m))))
-	      new-entries))
-    (if (eq :compiler-menv (car env))
-	`(:compiler-menv ,@new-entries ,@(cdr env))
-      (append new-entries env))))
-
-(defun environment-function (env fn)
-  (let ((entry (lisp::lexical-function fn env)))
-    (and entry 
-	 (eq entry 'lisp::lexical-function)
-	 fn)))
-
-(defun environment-macro (env macro)
-  (let ((entry (assoc macro (if (eq :compiler-menv (first env))
-				 (rest env)
-			       env))))
-    (and entry
-	 (consp entry)
-	 (symbolp (car entry))			;name
-	 (symbolp (cadr entry))			;gcl:macro or gensym
-	 (nthcdr 2 entry))))
-
-);#+gclisp
-
-
-
-(defmacro with-new-definition-in-environment
-	  ((new-env old-env macrolet/flet/labels-form) &body body)
-  (let ((functions (make-symbol "Functions"))
-	(macros (make-symbol "Macros")))
-    `(let ((,functions ())
-	   (,macros ()))
-       (ecase (car ,macrolet/flet/labels-form)
-	 ((flet labels)
-	  (dolist (fn (cadr ,macrolet/flet/labels-form))
-	    (push fn ,functions)))
-	 ((macrolet)
-	  (dolist (mac (cadr ,macrolet/flet/labels-form))
-	    (push (list (car mac)
-			(convert-macro-to-lambda (cadr mac)
-						 (cddr mac)
-						 (string (car mac))))
-		  ,macros))))
-       (with-augmented-environment
-	      (,new-env ,old-env :functions ,functions :macros ,macros)
-	 ,@body))))
-
-#-Genera
-(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro"))
-  (let ((gensym (make-symbol name)))
-    (eval `(defmacro ,gensym ,llist ,@body))
-    (macro-function gensym)))
-
-#+Genera
-(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro"))
-  (si:defmacro-1
-    'sys:named-lambda 'sys:special (make-symbol name) llist body))
-
-
-
-
-
-;;;
-;;; Now comes the real walker.
-;;;
-;;; As the walker walks over the code, it communicates information to itself
-;;; about the walk.  This information includes the walk function, variable
-;;; bindings, declarations in effect etc.  This information is inherently
-;;; lexical, so the walker passes it around in the actual environment the
-;;; walker passes to macroexpansion functions.  This is what makes the
-;;; nested-walk-form facility work properly.
-;;;
-(defmacro walker-environment-bind ((var env &rest key-args)
-				      &body body)
-  `(with-augmented-environment
-     (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
-     .,body))
-
-(defvar *key-to-walker-environment* (gensym))
-
-(defun env-lock (env)
-  (environment-macro env *key-to-walker-environment*))
-
-(defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
-					   (walk-form nil wfop)
-					   (declarations nil decp)
-					   (lexical-variables nil lexp))
-  (let ((lock (environment-macro env *key-to-walker-environment*)))
-    (list
-      (list *key-to-walker-environment*
-	    (list (if wfnp walk-function     (car lock))
-		  (if wfop walk-form         (cadr lock))
-		  (if decp declarations      (caddr lock))
-		  (if lexp lexical-variables (cadddr lock)))))))
-		  
-(defun env-walk-function (env)
-  (car (env-lock env)))
-
-(defun env-walk-form (env)
-  (cadr (env-lock env)))
-
-(defun env-declarations (env)
-  (caddr (env-lock env)))
-
-(defun env-lexical-variables (env)
-  (cadddr (env-lock env)))
-
-
-(defun note-declaration (declaration env)
-  (let ((lock (env-lock env)))
-    (setf (caddr lock)
-	  (cons declaration (caddr lock)))))
-
-(defun note-lexical-binding (thing env)
-  (let ((lock (env-lock env)))
-    (setf (cadddr lock)
-	  (cons thing (cadddr lock)))))
-
-
-(defun VARIABLE-LEXICAL-P (var env)
-  (member var (env-lexical-variables env)))
-
-(defvar *VARIABLE-DECLARATIONS* '(special))
-
-(defun VARIABLE-DECLARATION (declaration var env)
-  (if (not (member declaration *variable-declarations*))
-      (error "~S is not a reckognized variable declaration." declaration)
-      (let ((id (or (member var (env-lexical-variables env)) var)))
-	(dolist (decl (env-declarations env))
-	  (when (and (eq (car decl) declaration)
-		     (eq (cadr decl) id))
-	    (return decl))))))
-
-(defun VARIABLE-SPECIAL-P (var env)
-  (or (not (null (variable-declaration 'special var env)))
-      (variable-globally-special-p var)))
-
-;;;
-;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been
-;;; declared globally special.  Any particular CommonLisp implementation
-;;; should customize this function accordingly and send their customization
-;;; back.
-;;;
-;;; The default version of variable-globally-special-p is probably pretty
-;;; slow, so it uses *globally-special-variables* as a cache to remember
-;;; variables that it has already figured out are globally special.
-;;;
-;;; This would need to be reworked if an unspecial declaration got added to
-;;; Common Lisp.
-;;;
-;;; Common Lisp nit:
-;;;   variable-globally-special-p should be defined in Common Lisp.
-;;;
-#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
-      GCLisp TI pyramid)
-(defvar *globally-special-variables* ())
-
-(defun variable-globally-special-p (symbol)
-  #+Genera                      (si:special-variable-p symbol)
-  #+Cloe-Runtime		(compiler::specialp symbol)
-  #+Lucid                       (lucid::proclaimed-special-p symbol)
-  #+TI                          (get symbol 'special)
-  #+Xerox                       (il:variable-globally-special-p symbol)
-  #+(and dec vax common)        (get symbol 'system::globally-special)
-  #+(or KCL IBCL)               (si:specialp symbol)
-  #+excl                        (get symbol 'excl::.globally-special.)
-  #+:CMU			(or (get symbol 'lisp::globally-special)
-				    (get symbol
-					 'clc::globally-special-in-compiler))
-  #+HP-HPLabs                   (member (get symbol 'impl:vartype)
-					'(impl:fluid impl:global)
-					:test #'eq)
-  #+:GCLISP                     (gclisp::special-p symbol)
-  #+pyramid			(or (get symbol 'lisp::globally-special)
-				    (get symbol
-					 'clc::globally-special-in-compiler))
-  #+:CORAL                      (ccl::proclaimed-special-p symbol)
-  #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs
-	GCLisp TI pyramid :CORAL)
-  (or (not (null (member symbol *globally-special-variables* :test #'eq)))
-      (when (eval `(flet ((ref () ,symbol))
-		     (let ((,symbol '#,(list nil)))
-		       (and (boundp ',symbol) (eq ,symbol (ref))))))
-	(push symbol *globally-special-variables*)
-	t)))
-
-
-  ;;   
-;;;;;; Handling of special forms (the infamous 24).
-  ;;
-;;;
-;;; and I quote...
-;;; 
-;;;     The set of special forms is purposely kept very small because
-;;;     any program analyzing program (read code walker) must have
-;;;     special knowledge about every type of special form. Such a
-;;;     program needs no special knowledge about macros...
-;;;
-;;; So all we have to do here is a define a way to store and retrieve
-;;; templates which describe how to walk the 24 special forms and we are all
-;;; set...
-;;;
-;;; Well, its a nice concept, and I have to admit to being naive enough that
-;;; I believed it for a while, but not everyone takes having only 24 special
-;;; forms as seriously as might be nice.  There are (at least) 3 ways to
-;;; lose:
-;;
-;;;   1 - Implementation x implements a Common Lisp special form as a macro
-;;;       which expands into a special form which:
-;;;         - Is a common lisp special form (not likely)
-;;;         - Is not a common lisp special form (on the 3600 IF --> COND).
-;;;
-;;;     * We can safe ourselves from this case (second subcase really) by
-;;;       checking to see if there is a template defined for something
-;;;       before we check to see if we we can macroexpand it.
-;;;
-;;;   2 - Implementation x implements a Common Lisp macro as a special form.
-;;;
-;;;     * This is a screw, but not so bad, we save ourselves from it by
-;;;       defining extra templates for the macros which are *likely* to
-;;;       be implemented as special forms.  (DO, DO* ...)
-;;;
-;;;   3 - Implementation x has a special form which is not on the list of
-;;;       Common Lisp special forms.
-;;;
-;;;     * This is a bad sort of a screw and happens more than I would like
-;;;       to think, especially in the implementations which provide more
-;;;       than just Common Lisp (3600, Xerox etc.).
-;;;       The fix is not terribly staisfactory, but will have to do for
-;;;       now.  There is a hook in get walker-template which can get a
-;;;       template from the implementation's own walker.  That template
-;;;       has to be converted, and so it may be that the right way to do
-;;;       this would actually be for that implementation to provide an
-;;;       interface to its walker which looks like the interface to this
-;;;       walker.
-;;;
-
-(eval-when (compile load eval)
-
-(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because
-  `(get ,x 'walker-template))		   ;Golden Common Lisp doesn't hack
-					   ;compile time definition of macros
-					   ;right for setf.
-
-(defmacro define-walker-template
-	  (name &optional (template '(nil repeat (eval))))
-  `(eval-when (load eval)
-     (setf (get-walker-template-internal ',name) ',template)))
-)
-
-(defun get-walker-template (x)
-  (cond ((symbolp x)
-	 (or (get-walker-template-internal x)
-	     (get-implementation-dependent-walker-template x)))
-	((and (listp x) (eq (car x) 'lambda))
-	 '(lambda repeat (eval)))
-	(t
-	 (error "Can't get template for ~S" x))))
-
-(defun get-implementation-dependent-walker-template (x)
-  (declare (ignore x))
-  ())
-
-
-  ;;   
-;;;;;; The actual templates
-  ;;   
-
-(define-walker-template BLOCK                (NIL NIL REPEAT (EVAL)))
-(define-walker-template CATCH                (NIL EVAL REPEAT (EVAL)))
-(define-walker-template COMPILER-LET         walk-compiler-let)
-(define-walker-template DECLARE              walk-unexpected-declare)
-(define-walker-template EVAL-WHEN            (NIL QUOTE REPEAT (EVAL)))
-(define-walker-template FLET                 walk-flet)
-(define-walker-template FUNCTION             (NIL CALL))
-(define-walker-template GO                   (NIL QUOTE))
-(define-walker-template IF                   walk-if)
-(define-walker-template LABELS               walk-labels)
-(define-walker-template LAMBDA               walk-lambda)
-(define-walker-template LET                  walk-let)
-(define-walker-template LET*                 walk-let*)
-(define-walker-template MACROLET             walk-macrolet)
-(define-walker-template MULTIPLE-VALUE-CALL  (NIL EVAL REPEAT (EVAL)))
-(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
-(define-walker-template MULTIPLE-VALUE-SETQ  (NIL (REPEAT (SET)) EVAL))
-(define-walker-template MULTIPLE-VALUE-BIND  walk-multiple-value-bind)
-(define-walker-template PROGN                (NIL REPEAT (EVAL)))
-(define-walker-template PROGV                (NIL EVAL EVAL REPEAT (EVAL)))
-(define-walker-template QUOTE                (NIL QUOTE))
-(define-walker-template RETURN-FROM          (NIL QUOTE REPEAT (RETURN)))
-(define-walker-template SETQ                 (NIL REPEAT (SET EVAL)))
-(define-walker-template TAGBODY              walk-tagbody)
-(define-walker-template THE                  (NIL QUOTE EVAL))
-(define-walker-template THROW                (NIL EVAL EVAL))
-(define-walker-template UNWIND-PROTECT       (NIL RETURN REPEAT (EVAL)))
-
-;;; The new special form.
-;(define-walker-template clos::LOAD-TIME-EVAL       (NIL EVAL))
-
-;;;
-;;; And the extra templates...
-;;;
-(define-walker-template DO      walk-do)
-(define-walker-template DO*     walk-do*)
-(define-walker-template PROG    walk-prog)
-(define-walker-template PROG*   walk-prog*)
-(define-walker-template COND    (NIL REPEAT ((TEST REPEAT (EVAL)))))
-
-#+Genera
-(progn
-  (define-walker-template zl::named-lambda walk-named-lambda)
-  (define-walker-template SCL:LETF walk-let)
-  (define-walker-template SCL:LETF* walk-let*)
-  )
-
-#+Lucid
-(progn
-  (define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda
-			  #-LCL3.0 sys:named-lambda walk-named-lambda)
-  )
-
-#+(or KCL IBCL)
-(progn
-  (define-walker-template lambda-block walk-named-lambda);Not really right,
-							 ;we don't hack block
-						         ;names anyways.
-  )
-
-#+TI
-(progn
-  (define-walker-template TICL::LET-IF walk-let-if)
-  )
-
-#+:Coral
-(progn
-  (define-walker-template ccl:%stack-block walk-let)
-  )
-
-
-
-(defun WALK-FORM (form
-		  &optional environment
-			    (walk-function
-			      #'(lambda (subform context env)
-				  (declare (ignore context env))
-				  subform)))
-  (walker-environment-bind (new-env environment :walk-function walk-function)
-    (walk-form-internal form :eval new-env)))
-
-;;;
-;;; nested-walk-form provides an interface that allows nested macros, each
-;;; of which must walk their body to just do one walk of the body of the
-;;; inner macro.  That inner walk is done with a walk function which is the
-;;; composition of the two walk functions.
-;;;
-;;; This facility works by having the walker annotate the environment that
-;;; it passes to macroexpand-1 to know which form is being macroexpanded.
-;;; If then the &whole argument to the macroexpansion function is eq to
-;;; the env-walk-form of the environment, nested-walk-form can be certain
-;;; that there are no intervening layers and that a nested walk is alright.
-;;;
-;;; There are some semantic problems with this facility.  In particular, if
-;;; the outer walk function returns T as its walk-no-more-p value, this will
-;;; prevent the inner walk function from getting a chance to walk the subforms
-;;; of the form.  This is almost never what you want, since it destroys the
-;;; equivalence between this nested-walk-form function and two seperate
-;;; walk-forms.
-;;;
-(defun NESTED-WALK-FORM (whole
-			 form
-			 &optional environment
-				   (walk-function
-				     #'(lambda (subform context env)
-					 (declare (ignore context env))
-					 subform)))
-  (if (eq whole (env-walk-form environment))
-      (let ((outer-walk-function (env-walk-function environment)))
-	(throw whole
-	  (walk-form
-	    form
-	    environment
-	    #'(lambda (f c e)
-		;; First loop to make sure the inner walk function
-		;; has done all it wants to do with this form.
-		;; Basically, what we are doing here is providing
-		;; the same contract walk-form-internal normally
-		;; provides to the inner walk function.
-		(let ((inner-result nil)
-		      (inner-no-more-p nil)
-		      (outer-result nil)
-		      (outer-no-more-p nil))
-		  (loop
-		    (multiple-value-setq (inner-result inner-no-more-p)
-					 (funcall walk-function f c e))
-		    (cond (inner-no-more-p (return))
-			  ((not (eq inner-result f)))
-			  ((not (consp inner-result)) (return))
-			  ((get-walker-template (car inner-result)) (return))
-			  (t
-			   (multiple-value-bind (expansion macrop)
-			       (walker-environment-bind
-				     (new-env e :walk-form inner-result)
-				 (macroexpand-1 inner-result new-env))
-			     (if macrop
-				 (setq inner-result expansion)
-				 (return)))))
-		    (setq f inner-result))
-		  (multiple-value-setq (outer-result outer-no-more-p)
-				       (funcall outer-walk-function
-						inner-result
-						c
-						e))
-		  (values outer-result
-			  (and inner-no-more-p outer-no-more-p)))))))
-      (walk-form form environment walk-function)))
-
-;;;
-;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
-;;; takes a form and the current context and walks the form calling itself or
-;;; the appropriate template recursively.
-;;;
-;;;   "It is recommended that a program-analyzing-program process a form
-;;;    that is a list whose car is a symbol as follows:
-;;;
-;;;     1. If the program has particular knowledge about the symbol,
-;;;        process the form using special-purpose code.  All of the
-;;;        standard special forms should fall into this category.
-;;;     2. Otherwise, if macro-function is true of the symbol apply
-;;;        either macroexpand or macroexpand-1 and start over.
-;;;     3. Otherwise, assume it is a function call. "
-;;;     
-
-(defun walk-form-internal (form context env
-			   &aux newform newnewform
-				walk-no-more-p macrop
-				fn template)
-  ;; First apply the walk-function to perform whatever translation
-  ;; the user wants to this form.  If the second value returned
-  ;; by walk-function is T then we don't recurse...
-  (catch form
-    (multiple-value-setq (newform walk-no-more-p)
-      (funcall (env-walk-function env) form context env))
-    (catch newform
-      (cond (walk-no-more-p newform)
-	    ((not (eq form newform))
-	     (walk-form-internal newform context env))
-	    ((not (consp newform)) newform)
-	    ((setq template (get-walker-template (setq fn (car newform))))
-	     (if (symbolp template)
-		 (funcall template newform context env)
-		 (walk-template newform template context env)))
-	    (t
-	     (multiple-value-setq (newnewform macrop)
-	       (walker-environment-bind (new-env env :walk-form newform)
-		 (macroexpand-1 newform new-env)))
-	     (cond (macrop (walk-form-internal newnewform context env))
-		   ((and (symbolp fn)
-			 (not (fboundp fn))
-			 (special-form-p fn))
-		    (error
-		      "~S is a special form, not defined in the CommonLisp.~%~
-                       manual This code walker doesn't know how to walk it.~%~
-                       Define a template for this special form and try again."
-		      fn))
-		   (t
-		    ;; Otherwise, walk the form as if its just a standard 
-		    ;; functioncall using a template for standard function
-		    ;; call.
-		    (walk-template
-		      newnewform '(call repeat (eval)) context env))))))))
-
-(defun walk-template (form template context env)
-  (if (atom template)
-      (ecase template
-        ((EVAL FUNCTION TEST EFFECT RETURN)
-         (walk-form-internal form :EVAL env))
-        ((QUOTE NIL) form)
-        (SET
-          (walk-form-internal form :SET env))
-        ((LAMBDA CALL)
-	 (cond ((symbolp form) form)
-	       #+Lispm
-	       ((sys:validate-function-spec form) form)
-	       (t (walk-form-internal form context env)))))
-      (case (car template)
-        (REPEAT
-          (walk-template-handle-repeat form
-                                       (cdr template)
-				       ;; For the case where nothing happens
-				       ;; after the repeat optimize out the
-				       ;; call to length.
-				       (if (null (cddr template))
-					   ()
-					   (nthcdr (- (length form)
-						      (length
-							(cddr template)))
-						   form))
-                                       context
-				       env))
-        (IF
-	  (walk-template form
-			 (if (if (listp (cadr template))
-				 (eval (cadr template))
-				 (funcall (cadr template) form))
-			     (caddr template)
-			     (cadddr template))
-			 context
-			 env))
-        (REMOTE
-          (walk-template form (cadr template) context env))
-        (otherwise
-          (cond ((atom form) form)
-                (t (recons form
-                           (walk-template
-			     (car form) (car template) context env)
-                           (walk-template
-			     (cdr form) (cdr template) context env))))))))
-
-(defun walk-template-handle-repeat (form template stop-form context env)
-  (if (eq form stop-form)
-      (walk-template form (cdr template) context env)
-      (walk-template-handle-repeat-1 form
-				     template
-				     (car template)
-				     stop-form
-				     context
-				     env)))
-
-(defun walk-template-handle-repeat-1 (form template repeat-template
-					   stop-form context env)
-  (cond ((null form) ())
-        ((eq form stop-form)
-         (if (null repeat-template)
-             (walk-template stop-form (cdr template) context env)       
-             (error "While handling repeat:
-                     ~%~Ran into stop while still in repeat template.")))
-        ((null repeat-template)
-         (walk-template-handle-repeat-1
-	   form template (car template) stop-form context env))
-        (t
-         (recons form
-                 (walk-template (car form) (car repeat-template) context env)
-                 (walk-template-handle-repeat-1 (cdr form)
-						template
-						(cdr repeat-template)
-						stop-form
-						context
-						env)))))
-
-(defun walk-repeat-eval (form env)
-  (and form
-       (recons form
-	       (walk-form-internal (car form) :eval env)
-	       (walk-repeat-eval (cdr form) env))))
-
-(defun recons (x car cdr)
-  (if (or (not (eq (car x) car))
-          (not (eq (cdr x) cdr)))
-      (cons car cdr)
-      x))
-
-(defun relist (x &rest args)
-  (relist-internal x args nil))
-
-(defun relist* (x &rest args)
-  (relist-internal x args 't))
-
-(defun relist-internal (x args *p)
-  (if (null (cdr args))
-      (if *p (car args) (list (car args)))
-      (recons x
-	      (car args)
-	      (relist-internal (cdr x) (cdr args) *p))))
-
-
-  ;;   
-;;;;;; Special walkers
-  ;;
-
-(defun walk-declarations (body fn env
-			       &optional doc-string-p declarations old-body
-			       &aux (form (car body)) macrop new-form)
-  (cond ((and (stringp form)			;might be a doc string
-              (cdr body)			;isn't the returned value
-              (null doc-string-p)		;no doc string yet
-              (null declarations))		;no declarations yet
-         (recons body
-                 form
-                 (walk-declarations (cdr body) fn env t)))
-        ((and (listp form) (eq (car form) 'declare))
-         ;; Got ourselves a real live declaration.  Record it, look for more.
-         (dolist (declaration (cdr form))
-	   (let ((type (car declaration))
-		 (name (cadr declaration))
-		 (args (cddr declaration)))
-	     (if (member type *variable-declarations*)
-		 (note-declaration `(,type
-				     ,(or (variable-lexical-p name env) name)
-				     ,.args)
-				   env)
-		 (note-declaration declaration env))
-	     (push declaration declarations)))
-         (recons body
-                 form
-                 (walk-declarations
-		   (cdr body) fn env doc-string-p declarations)))
-        ((and form
-	      (listp form)
-	      (null (get-walker-template (car form)))
-	      (progn
-		(multiple-value-setq (new-form macrop)
-				     (macroexpand-1 form env))
-		macrop))
-	 ;; This form was a call to a macro.  Maybe it expanded
-	 ;; into a declare?  Recurse to find out.
-	 (walk-declarations (recons body new-form (cdr body))
-			    fn env doc-string-p declarations
-			    (or old-body body)))
-	(t
-	 ;; Now that we have walked and recorded the declarations,
-	 ;; call the function our caller provided to expand the body.
-	 ;; We call that function rather than passing the real-body
-	 ;; back, because we are RECONSING up the new body.
-	 (funcall fn (or old-body body) env))))
-
-
-(defun walk-unexpected-declare (form context env)
-  (declare (ignore context env))
-  (warn "Encountered declare ~S in a place where a declare was not expected."
-	form)
-  form)
-
-(defun walk-arglist (arglist context env &optional (destructuringp nil)
-					 &aux arg)
-  (cond ((null arglist) ())
-        ((symbolp (setq arg (car arglist)))
-         (or (member arg lambda-list-keywords)
-             (note-lexical-binding arg env))
-         (recons arglist
-                 arg
-                 (walk-arglist (cdr arglist)
-                               context
-			       env
-                               (and destructuringp
-				    (not (member arg
-						 lambda-list-keywords))))))
-        ((consp arg)
-         (prog1 (if destructuringp
-                    (walk-arglist arg context env destructuringp)
-                    (recons arglist
-                            (relist* arg
-                                     (car arg)
-                                     (walk-form-internal (cadr arg) :eval env)
-                                     (cddr arg))
-                            (walk-arglist (cdr arglist) context env nil)))
-                (if (symbolp (car arg))
-                    (note-lexical-binding (car arg) env)
-                    (note-lexical-binding (cadar arg) env))
-                (or (null (cddr arg))
-                    (not (symbolp (caddr arg)))
-                    (note-lexical-binding (caddr arg) env))))
-          (t
-	   (error "Can't understand something in the arglist ~S" arglist))))
-
-(defun walk-let (form context env)
-  (walk-let/let* form context env nil))
-
-(defun walk-let* (form context env)
-  (walk-let/let* form context env t))
-
-(defun walk-prog (form context env)
-  (walk-prog/prog* form context env nil))
-
-(defun walk-prog* (form context env)
-  (walk-prog/prog* form context env t))
-
-(defun walk-do (form context env)
-  (walk-do/do* form context env nil))
-
-(defun walk-do* (form context env)
-  (walk-do/do* form context env t))
-
-(defun walk-let/let* (form context old-env sequentialp)
-  (walker-environment-bind (new-env old-env)
-    (let* ((let/let* (car form))
-	   (bindings (cadr form))
-	   (body (cddr form))
-	   (walked-bindings 
-	     (walk-bindings-1 bindings
-			      old-env
-			      new-env
-			      context
-			      sequentialp))
-	   (walked-body
-	     (walk-declarations body #'walk-repeat-eval new-env)))
-      (relist*
-	form let/let* walked-bindings walked-body))))
-
-(defun walk-prog/prog* (form context old-env sequentialp)
-  (walker-environment-bind (new-env old-env)
-    (let* ((possible-block-name (second form))
-	   (blocked-prog (and (symbolp possible-block-name)
-			      (not (eq possible-block-name 'nil)))))
-      (multiple-value-bind (let/let* block-name bindings body)
-	  (if blocked-prog
-	      (values (car form) (cadr form) (caddr form) (cdddr form))
-	      (values (car form) nil	     (cadr  form) (cddr  form)))
-	(let* ((walked-bindings 
-		 (walk-bindings-1 bindings
-				  old-env
-				  new-env
-				  context
-				  sequentialp))
-	       (walked-body
-		 (walk-declarations 
-		   body
-		   #'(lambda (real-body real-env)
-		       (walk-tagbody-1 real-body context real-env))
-		   new-env)))
-	  (if block-name
-	      (relist*
-		form let/let* block-name walked-bindings walked-body)
-	      (relist*
-		form let/let* walked-bindings walked-body)))))))
-
-(defun walk-do/do* (form context old-env sequentialp)
-  (walker-environment-bind (new-env old-env)
-    (let* ((do/do* (car form))
-	   (bindings (cadr form))
-	   (end-test (caddr form))
-	   (body (cdddr form))
-	   (walked-bindings (walk-bindings-1 bindings
-					     old-env
-					     new-env
-					     context
-					     sequentialp))
-	   (walked-body
-	     (walk-declarations body #'walk-repeat-eval new-env)))
-      (relist* form
-	       do/do*
-	       (walk-bindings-2 bindings walked-bindings context new-env)
-	       (walk-template end-test '(test repeat (eval)) context new-env)
-	       walked-body))))
-
-(defun walk-let-if (form context env)
-  (let ((test (cadr form))
-	(bindings (caddr form))
-	(body (cdddr form)))
-    (walk-form-internal
-      `(let ()
-	 (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
-				     bindings)))
-	 (flet ((.let-if-dummy. () ,@body))
-	   (if ,test
-	       (let ,bindings (.let-if-dummy.))
-	       (.let-if-dummy.))))
-      context
-      env)))
-
-(defun walk-multiple-value-bind (form context old-env)
-  (walker-environment-bind (new-env old-env)
-    (let* ((mvb (car form))
-	   (bindings (cadr form))
-	   (mv-form (walk-template (caddr form) 'eval context old-env))
-	   (body (cdddr form))
-	   walked-bindings
-	   (walked-body
-	     (walk-declarations 
-	       body
-	       #'(lambda (real-body real-env)
-		   (setq walked-bindings
-			 (walk-bindings-1 bindings
-					  old-env
-					  new-env
-					  context
-					  nil))
-		   (walk-repeat-eval real-body real-env))
-	       new-env)))
-      (relist* form mvb walked-bindings mv-form walked-body))))
-
-(defun walk-bindings-1 (bindings old-env new-env context sequentialp)
-  (and bindings
-       (let ((binding (car bindings)))
-         (recons bindings
-                 (if (symbolp binding)
-                     (prog1 binding
-                            (note-lexical-binding binding new-env))
-                     (prog1 (relist* binding
-				     (car binding)
-				     (walk-form-internal (cadr binding)
-							 context
-							 (if sequentialp
-							     new-env
-							     old-env))
-				     (cddr binding))	;save cddr for DO/DO*
-						        ;it is the next value
-						        ;form. Don't walk it
-						        ;now though.
-                            (note-lexical-binding (car binding) new-env)))
-                 (walk-bindings-1 (cdr bindings)
-				  old-env
-				  new-env
-				  context
-				  sequentialp)))))
-
-(defun walk-bindings-2 (bindings walked-bindings context env)
-  (and bindings
-       (let ((binding (car bindings))
-             (walked-binding (car walked-bindings)))
-         (recons bindings
-		 (if (symbolp binding)
-		     binding
-		     (relist* binding
-			      (car walked-binding)
-			      (cadr walked-binding)
-			      (walk-template (cddr binding)
-					     '(eval)
-					     context
-					     env)))		 
-                 (walk-bindings-2 (cdr bindings)
-				  (cdr walked-bindings)
-				  context
-				  env)))))
-
-(defun walk-lambda (form context old-env)
-  (walker-environment-bind (new-env old-env)
-    (let* ((arglist (cadr form))
-           (body (cddr form))
-           (walked-arglist (walk-arglist arglist context new-env))
-           (walked-body
-             (walk-declarations body #'walk-repeat-eval new-env)))
-      (relist* form
-               (car form)
-	       walked-arglist
-               walked-body))))
-
-(defun walk-named-lambda (form context old-env)
-  (walker-environment-bind (new-env old-env)
-    (let* ((name (cadr form))
-	   (arglist (caddr form))
-           (body (cdddr form))
-           (walked-arglist (walk-arglist arglist context new-env))
-           (walked-body
-             (walk-declarations body #'walk-repeat-eval new-env)))
-      (relist* form
-               (car form)
-	       name
-	       walked-arglist
-               walked-body))))  
-
-(defun walk-tagbody (form context env)
-  (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
-
-(defun walk-tagbody-1 (form context env)
-  (and form
-       (recons form
-               (walk-form-internal (car form)
-				   (if (symbolp (car form)) 'quote context)
-				   env)
-               (walk-tagbody-1 (cdr form) context env))))
-
-(defun walk-compiler-let (form context old-env)
-  (declare (ignore context))
-  (let ((vars ())
-	(vals ()))
-    (dolist (binding (cadr form))
-      (cond ((symbolp binding) (push binding vars) (push nil vals))
-	    (t
-	     (push (car binding) vars)
-	     (push (eval (cadr binding)) vals))))
-    (relist* form
-	     (car form)
-	     (cadr form)
-	     (progv vars vals (walk-repeat-eval (cddr form) old-env)))))
-
-(defun walk-macrolet (form context old-env)
-  (walker-environment-bind (macro-env
-			    nil
-			    :walk-function (env-walk-function old-env))
-    (labels ((walk-definitions (definitions)
-	       (and definitions
-		    (let ((definition (car definitions)))
-		      (recons definitions
-                              (relist* definition
-                                       (car definition)
-                                       (walk-arglist (cadr definition)
-						     context
-						     macro-env
-						     t)
-                                       (walk-declarations (cddr definition)
-							  #'walk-repeat-eval
-							  macro-env))
-			      (walk-definitions (cdr definitions)))))))
-      (with-new-definition-in-environment (new-env old-env form)
-	(relist* form
-		 (car form)
-		 (walk-definitions (cadr form))
-		 (walk-declarations (cddr form)
-				    #'walk-repeat-eval
-				    new-env))))))
-
-(defun walk-flet (form context old-env)
-  (labels ((walk-definitions (definitions)
-	     (if (null definitions)
-		 ()
-		 (recons definitions
-			 (walk-lambda (car definitions) context old-env)
-			 (walk-definitions (cdr definitions))))))
-    (recons form
-	    (car form)
-	    (recons (cdr form)
-		    (walk-definitions (cadr form))
-		    (with-new-definition-in-environment (new-env old-env form)
-		      (walk-declarations (cddr form)
-					 #'walk-repeat-eval
-					 new-env))))))
-
-(defun walk-labels (form context old-env)
-  (with-new-definition-in-environment (new-env old-env form)
-    (labels ((walk-definitions (definitions)
-	       (if (null definitions)
-		   ()
-		   (recons definitions
-			   (walk-lambda (car definitions) context new-env)
-			   (walk-definitions (cdr definitions))))))
-      (recons form
-	      (car form)
-	      (recons (cdr form)
-		      (walk-definitions (cadr form))
-		      (walk-declarations (cddr form)
-					 #'walk-repeat-eval
-					 new-env))))))
-
-(defun walk-if (form context env)
-  (let ((predicate (cadr form))
-	(arm1 (caddr form))
-	(arm2 
-	  (if (cddddr form)
-	      (progn
-		(warn "In the form:~%~S~%~
-                       IF only accepts three arguments, you are using ~D.~%~
-                       It is true that some Common Lisps support this, but ~
-                       it is not~%~
-                       truly legal Common Lisp.  For now, this code ~
-                       walker is interpreting ~%~
-                       the extra arguments as extra else clauses. ~
-                       Even if this is what~%~
-                       you intended, you should fix your source code."
-		      form
-		      (length (cdr form)))
-		(cons 'progn (cdddr form)))
-	      (cadddr form))))
-    (relist form
-	    'if
-	    (walk-form-internal predicate context env)
-	    (walk-form-internal arm1 context env)
-	    (walk-form-internal arm2 context env))))
-
-
-;;;
-;;; Tests tests tests
-;;;
-
-#|
-;;; 
-;;; Here are some examples of the kinds of things you should be able to do
-;;; with your implementation of the macroexpansion environment hacking
-;;; mechanism.
-;;; 
-;;; with-lexical-macros is kind of like macrolet, but it only takes names
-;;; of the macros and actual macroexpansion functions to use to macroexpand
-;;; them.  The win about that is that for macros which want to wrap several
-;;; macrolets around their body, they can do this but have the macroexpansion
-;;; functions be compiled.  See the WITH-RPUSH example.
-;;;
-;;; If the implementation had a special way of communicating the augmented
-;;; environment back to the evaluator that would be totally great.  It would
-;;; mean that we could just augment the environment then pass control back
-;;; to the implementations own compiler or interpreter.  We wouldn't have
-;;; to call the actual walker.  That would make this much faster.  Since the
-;;; principal client of this is defmethod it would make compiling defmethods
-;;; faster and that would certainly be a win.
-;;;
-(defmacro with-lexical-macros (macros &body body &environment old-env)
-  (with-augmented-environment (new-env old-env :macros macros)
-    (walk-form (cons 'progn body) :environment new-env)))
-
-(defun expand-rpush (form env)
-  `(push ,(caddr form) ,(cadr form)))
-
-(defmacro with-rpush (&body body)
-  `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
-
-
-;;;
-;;; Unfortunately, I don't have an automatic tester for the walker.  
-;;; Instead there is this set of test cases with a description of
-;;; how each one should go.
-;;; 
-(defmacro take-it-out-for-a-test-walk (form)
-  `(take-it-out-for-a-test-walk-1 ',form))
-
-(defun take-it-out-for-a-test-walk-1 (form)
-  (terpri)
-  (terpri)
-  (let ((copy-of-form (copy-tree form))
-	(result (walk-form form nil
-		  #'(lambda (x y env)
-		      (format t "~&Form: ~S ~3T Context: ~A" x y)
-		      (when (symbolp x)
-			(let ((lexical (variable-lexical-p x env))
-			      (special (variable-special-p x env)))
-			  (when lexical
-			    (format t ";~3T")
-			    (format t "lexically bound"))
-			  (when special
-			    (format t ";~3T")
-			    (format t "declared special"))
-			  (when (boundp x)
-			    (format t ";~3T")
-			    (format t "bound: ~S " (eval x)))))
-		      x))))
-    (cond ((not (equal result copy-of-form))
-	   (format t "~%Warning: Result not EQUAL to copy of start."))
-	  ((not (eq result form))
-	   (format t "~%Warning: Result not EQ to copy of start.")))
-    (pprint result)
-    result))
-
-(defmacro foo (&rest ignore) ''global-foo)
-
-(defmacro bar (&rest ignore) ''global-bar)
-
-(take-it-out-for-a-test-walk (list arg1 arg2 arg3))
-(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))
-
-(take-it-out-for-a-test-walk (progn (foo) (bar 1)))
-
-(take-it-out-for-a-test-walk (block block-name a b c))
-(take-it-out-for-a-test-walk (block block-name (list a) b c))
-
-(take-it-out-for-a-test-walk (catch catch-tag (list a) b c))
-;;;
-;;; This is a fairly simple macrolet case.  While walking the body of the
-;;; macro, x should be lexically bound. In the body of the macrolet form
-;;; itself, x should not be bound.
-;;; 
-(take-it-out-for-a-test-walk
-  (macrolet ((foo (x) (list x) ''inner))
-    x
-    (foo 1)))
-
-;;;
-;;; A slightly more complex macrolet case.  In the body of the macro x
-;;; should not be lexically bound.  In the body of the macrolet form itself
-;;; x should be bound.  Note that THIS CASE WILL CAUSE AN ERROR when it
-;;; tries to macroexpand the call to foo.
-;;; 
-(take-it-out-for-a-test-walk
-     (let ((x 1))
-       (macrolet ((foo () (list x) ''inner))
-	 x
-	 (foo))))
-
-;;;
-;;; A truly hairy use of compiler-let and macrolet.  In the body of the
-;;; macro x should not be lexically bound.  In the body of the macrolet
-;;; itself x should not be lexically bound.  But the macro should expand
-;;; into 1.
-;;; 
-(take-it-out-for-a-test-walk
-  (compiler-let ((x 1))
-    (let ((x 2))
-      (macrolet ((foo () x))
-	x
-	(foo)))))
-
-
-(take-it-out-for-a-test-walk
-  (flet ((foo (x) (list x y))
-	 (bar (x) (list x y)))
-    (foo 1)))
-
-(take-it-out-for-a-test-walk
-  (let ((y 2))
-    (flet ((foo (x) (list x y))
-	   (bar (x) (list x y)))
-      (foo 1))))
-
-(take-it-out-for-a-test-walk
-  (labels ((foo (x) (bar x))
-	   (bar (x) (foo x)))
-    (foo 1)))
-
-(take-it-out-for-a-test-walk
-  (flet ((foo (x) (foo x)))
-    (foo 1)))
-
-(take-it-out-for-a-test-walk
-  (flet ((foo (x) (foo x)))
-    (flet ((bar (x) (foo x)))
-      (bar 1))))
-
-(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b))
-(take-it-out-for-a-test-walk (prog () (declare (special a b))))
-(take-it-out-for-a-test-walk (let (a b c)
-                               (declare (special a b))
-                               (foo a) b c))
-(take-it-out-for-a-test-walk (let (a b c)
-                               (declare (special a) (special b))
-                               (foo a) b c))
-(take-it-out-for-a-test-walk (let (a b c)
-                               (declare (special a))
-                               (declare (special b))
-                               (foo a) b c))
-(take-it-out-for-a-test-walk (let (a b c)
-                               (declare (special a))
-                               (declare (special b))
-                               (let ((a 1))
-                                 (foo a) b c)))
-(take-it-out-for-a-test-walk (eval-when ()
-                               a
-                               (foo a)))
-(take-it-out-for-a-test-walk (eval-when (eval when load)
-                               a
-                               (foo a)))
-
-(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))
-(take-it-out-for-a-test-walk (multiple-value-bind (a b)
-				 (foo a b)
-			       (declare (special a))
-			       (list a b)))
-(take-it-out-for-a-test-walk (progn (function foo)))
-(take-it-out-for-a-test-walk (progn a b (go a)))
-(take-it-out-for-a-test-walk (if a b c))
-(take-it-out-for-a-test-walk (if a b))
-(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
-(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
-			      1 2))
-(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
-(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
-(take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
-                               (declare (special a b))
-                               (list a b c)))
-(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
-                               (declare (special a b))
-                               (list a b c)))
-(take-it-out-for-a-test-walk (let ((a 1) (b 2))
-                               (foo bar)
-                               (declare (special a))
-                               (foo a b)))
-(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
-(take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
-(take-it-out-for-a-test-walk (progn a b c))
-(take-it-out-for-a-test-walk (progv vars vals a b c))
-(take-it-out-for-a-test-walk (quote a))
-(take-it-out-for-a-test-walk (return-from block-name a b c))
-(take-it-out-for-a-test-walk (setq a 1))
-(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
-(take-it-out-for-a-test-walk (tagbody a b c (go a)))
-(take-it-out-for-a-test-walk (the foo (foo-form a b c)))
-(take-it-out-for-a-test-walk (throw tag-form a))
-(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
-
-(defmacro flet-1 (a b) ''outer)
-(defmacro labels-1 (a b) ''outer)
-
-(take-it-out-for-a-test-walk
-  (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
-    (flet-1 1 2)
-    (foo 1 2)))
-(take-it-out-for-a-test-walk
-  (labels ((label-1 (a b) () (label-1 a b)(list a b)))
-    (label-1 1 2)
-    (foo 1 2)))
-(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
-                               (macrolet-1 a b)
-                               (foo 1 2)))
-
-(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
-                               (foo 1)))
-
-(take-it-out-for-a-test-walk (progn (bar 1)
-                                    (macrolet ((bar (a)
-						 `(inner-bar-expanded ,a)))
-                                      (bar 2))))
-
-(take-it-out-for-a-test-walk (progn (bar 1)
-                                    (macrolet ((bar (s)
-						 (bar s)
-						 `(inner-bar-expanded ,s)))
-                                      (bar 2))))
-
-(take-it-out-for-a-test-walk (cond (a b)
-                                   ((foo bar) a (foo a))))
-
-
-(let ((the-lexical-variables ()))
-  (walk-form '(let ((a 1) (b 2))
-		#'(lambda (x) (list a b x y)))
-	     ()
-	     #'(lambda (form context env)
-		 (when (and (symbolp form)
-			    (variable-lexical-p form env))
-		   (push form the-lexical-variables))
-		 form))
-  (or (and (= (length the-lexical-variables) 3)
-	   (member 'a the-lexical-variables)
-	   (member 'b the-lexical-variables)
-	   (member 'x the-lexical-variables))
-      (error "Walker didn't do lexical variables of a closure properly.")))
-    
-|#
-
-()
diff --git a/obsolete/clos/2.01big/CLOS-BROWSER.TEDIT b/obsolete/clos/2.01big/CLOS-BROWSER.TEDIT
deleted file mode 100644
index 21d02b63..00000000
Binary files a/obsolete/clos/2.01big/CLOS-BROWSER.TEDIT and /dev/null differ
diff --git a/obsolete/clos/2.01big/NEW-CLOS-BROWSER.DFASL b/obsolete/clos/2.01big/NEW-CLOS-BROWSER.DFASL
deleted file mode 100644
index 1add0989..00000000
Binary files a/obsolete/clos/2.01big/NEW-CLOS-BROWSER.DFASL and /dev/null differ
diff --git a/obsolete/clos/2.01big/WEB-EDITOR.DFASL b/obsolete/clos/2.01big/WEB-EDITOR.DFASL
deleted file mode 100644
index 677def40..00000000
Binary files a/obsolete/clos/2.01big/WEB-EDITOR.DFASL and /dev/null differ
diff --git a/obsolete/clos/2.01big/boot.dfasl b/obsolete/clos/2.01big/boot.dfasl
deleted file mode 100644
index 06971f5f..00000000
Binary files a/obsolete/clos/2.01big/boot.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/braid.dfasl b/obsolete/clos/2.01big/braid.dfasl
deleted file mode 100644
index 6d0d54fa..00000000
Binary files a/obsolete/clos/2.01big/braid.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/cache.dfasl b/obsolete/clos/2.01big/cache.dfasl
deleted file mode 100644
index 2371e8e0..00000000
Binary files a/obsolete/clos/2.01big/cache.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/clos-env-internal.DFASL b/obsolete/clos/2.01big/clos-env-internal.DFASL
deleted file mode 100644
index 3f4811d6..00000000
Binary files a/obsolete/clos/2.01big/clos-env-internal.DFASL and /dev/null differ
diff --git a/obsolete/clos/2.01big/clos-env.DFASL b/obsolete/clos/2.01big/clos-env.DFASL
deleted file mode 100644
index 34289504..00000000
Binary files a/obsolete/clos/2.01big/clos-env.DFASL and /dev/null differ
diff --git a/obsolete/clos/2.01big/combin.dfasl b/obsolete/clos/2.01big/combin.dfasl
deleted file mode 100644
index d5810482..00000000
Binary files a/obsolete/clos/2.01big/combin.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/compat.dfasl b/obsolete/clos/2.01big/compat.dfasl
deleted file mode 100644
index f0bae057..00000000
Binary files a/obsolete/clos/2.01big/compat.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/construct.dfasl b/obsolete/clos/2.01big/construct.dfasl
deleted file mode 100644
index fd30ec49..00000000
Binary files a/obsolete/clos/2.01big/construct.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/cpl.dfasl b/obsolete/clos/2.01big/cpl.dfasl
deleted file mode 100644
index e4334140..00000000
Binary files a/obsolete/clos/2.01big/cpl.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/ctypes.dfasl b/obsolete/clos/2.01big/ctypes.dfasl
deleted file mode 100644
index aea567f5..00000000
Binary files a/obsolete/clos/2.01big/ctypes.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/defclass.dfasl b/obsolete/clos/2.01big/defclass.dfasl
deleted file mode 100644
index 7a37b676..00000000
Binary files a/obsolete/clos/2.01big/defclass.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/defcombin.dfasl b/obsolete/clos/2.01big/defcombin.dfasl
deleted file mode 100644
index 3dd0d755..00000000
Binary files a/obsolete/clos/2.01big/defcombin.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/defs.dfasl b/obsolete/clos/2.01big/defs.dfasl
deleted file mode 100644
index 1684e017..00000000
Binary files a/obsolete/clos/2.01big/defs.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/defsys.DFASL b/obsolete/clos/2.01big/defsys.DFASL
deleted file mode 100644
index 748c1593..00000000
Binary files a/obsolete/clos/2.01big/defsys.DFASL and /dev/null differ
diff --git a/obsolete/clos/2.01big/dfun.dfasl b/obsolete/clos/2.01big/dfun.dfasl
deleted file mode 100644
index 035d479a..00000000
Binary files a/obsolete/clos/2.01big/dfun.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/dlap.dfasl b/obsolete/clos/2.01big/dlap.dfasl
deleted file mode 100644
index cf52e2b1..00000000
Binary files a/obsolete/clos/2.01big/dlap.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/env.dfasl b/obsolete/clos/2.01big/env.dfasl
deleted file mode 100644
index decb1a80..00000000
Binary files a/obsolete/clos/2.01big/env.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/fin.dfasl b/obsolete/clos/2.01big/fin.dfasl
deleted file mode 100644
index 715e2d29..00000000
Binary files a/obsolete/clos/2.01big/fin.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/fixup.dfasl b/obsolete/clos/2.01big/fixup.dfasl
deleted file mode 100644
index 2f111caf..00000000
Binary files a/obsolete/clos/2.01big/fixup.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/fngen.dfasl b/obsolete/clos/2.01big/fngen.dfasl
deleted file mode 100644
index 81212cd5..00000000
Binary files a/obsolete/clos/2.01big/fngen.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/fsc.dfasl b/obsolete/clos/2.01big/fsc.dfasl
deleted file mode 100644
index fff65ea9..00000000
Binary files a/obsolete/clos/2.01big/fsc.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/init.dfasl b/obsolete/clos/2.01big/init.dfasl
deleted file mode 100644
index ae72d647..00000000
Binary files a/obsolete/clos/2.01big/init.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/iterate.dfasl b/obsolete/clos/2.01big/iterate.dfasl
deleted file mode 100644
index ed34b9aa..00000000
Binary files a/obsolete/clos/2.01big/iterate.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/lap.dfasl b/obsolete/clos/2.01big/lap.dfasl
deleted file mode 100644
index f587ef04..00000000
Binary files a/obsolete/clos/2.01big/lap.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/load-clos.lisp b/obsolete/clos/2.01big/load-clos.lisp
deleted file mode 100644
index 8ba7e9a2..00000000
--- a/obsolete/clos/2.01big/load-clos.lisp
+++ /dev/null
@@ -1,42 +0,0 @@
-;;; -*- Mode: Lisp; Package: xcl-User ; Base: 10.; Syntax: Common-Lisp -*-
-;;;
-
-(in-package "CLOS" :use (list (or (find-package :walker)
-				    (make-package :walker :use '(:lisp)))
-				(or (find-package :iterate)
-				    (make-package :iterate
-						  :use '(:lisp :walker)))
-				(find-package :lisp)))
-(export (intern (symbol-name :iterate)		;Have to do this here,
-		(find-package :iterate))	;because in the defsystem
-	(find-package :iterate))		;(later in this file)
-						;we use the symbol iterate
-						;to name the file
-
-(defun load-truename (&optional (errorp nil))
-  (flet ((bad-time ()
-	   (when errorp
-	     (error "LOAD-TRUENAME called but a file isn't being loaded."))))
-    (let ((filename (pathname (il:fullname *standard-input*))))
-      (if filename
-	  (make-pathname :host (pathname-host filename) :device
-			 (pathname-device filename) :directory
-			 (pathname-directory filename) :name "") 
-	  (bad-time)))))
-
-(defvar *clos-directory* (load-truename))
-
-(defun load-clos (&optional pathname)
-  (defvar *clos-system-date* "7/14/91 Medley 2.0 (interim)")
-  (defvar *the-clos-package* (find-package :clos))
-  (dolist (filename '(patch pkg walk iterate macros low low2 fin
-		    defclass defs fngen lap plap cache dlap boot
-		    vector slots init std-class cpl braid fsc methods
-		    combin dfun precom1 precom2 precom4 fixup
-		    defcombin ctypes construct env))
-
-    (load (merge-pathnames 
-			 (make-pathname  :name (string-downcase filename) :type
-					 "dfasl") (or pathname *clos-directory*))))
-  (pushnew :clos cl:*features*))
-
diff --git a/obsolete/clos/2.01big/low.dfasl b/obsolete/clos/2.01big/low.dfasl
deleted file mode 100644
index 7ba900eb..00000000
Binary files a/obsolete/clos/2.01big/low.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/low2.dfasl b/obsolete/clos/2.01big/low2.dfasl
deleted file mode 100644
index f0e021c7..00000000
Binary files a/obsolete/clos/2.01big/low2.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/macros.dfasl b/obsolete/clos/2.01big/macros.dfasl
deleted file mode 100644
index c5900f91..00000000
Binary files a/obsolete/clos/2.01big/macros.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/methods.dfasl b/obsolete/clos/2.01big/methods.dfasl
deleted file mode 100644
index 0d99a4ea..00000000
Binary files a/obsolete/clos/2.01big/methods.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/patch.dfasl b/obsolete/clos/2.01big/patch.dfasl
deleted file mode 100644
index 23d002f8..00000000
Binary files a/obsolete/clos/2.01big/patch.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/pkg.dfasl b/obsolete/clos/2.01big/pkg.dfasl
deleted file mode 100644
index 01eb5465..00000000
Binary files a/obsolete/clos/2.01big/pkg.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/plap.dfasl b/obsolete/clos/2.01big/plap.dfasl
deleted file mode 100644
index a0e96c70..00000000
Binary files a/obsolete/clos/2.01big/plap.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/precom1.dfasl b/obsolete/clos/2.01big/precom1.dfasl
deleted file mode 100644
index 13c3abd2..00000000
Binary files a/obsolete/clos/2.01big/precom1.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/precom2.dfasl b/obsolete/clos/2.01big/precom2.dfasl
deleted file mode 100644
index 633f8e42..00000000
Binary files a/obsolete/clos/2.01big/precom2.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/precom4.dfasl b/obsolete/clos/2.01big/precom4.dfasl
deleted file mode 100644
index f547707d..00000000
Binary files a/obsolete/clos/2.01big/precom4.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/slots.dfasl b/obsolete/clos/2.01big/slots.dfasl
deleted file mode 100644
index ef784156..00000000
Binary files a/obsolete/clos/2.01big/slots.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/std-class.dfasl b/obsolete/clos/2.01big/std-class.dfasl
deleted file mode 100644
index 818e18c8..00000000
Binary files a/obsolete/clos/2.01big/std-class.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/vector.dfasl b/obsolete/clos/2.01big/vector.dfasl
deleted file mode 100644
index 71697f84..00000000
Binary files a/obsolete/clos/2.01big/vector.dfasl and /dev/null differ
diff --git a/obsolete/clos/2.01big/walk.dfasl b/obsolete/clos/2.01big/walk.dfasl
deleted file mode 100644
index 93c99e8f..00000000
Binary files a/obsolete/clos/2.01big/walk.dfasl and /dev/null differ
diff --git a/obsolete/fonts/xerox/FlemishScriptII.wd.Z b/obsolete/fonts/xerox/FlemishScriptII.wd.Z
deleted file mode 100644
index 52d09c10..00000000
Binary files a/obsolete/fonts/xerox/FlemishScriptII.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Helvetica.Bold.Italic.cd.Z b/obsolete/fonts/xerox/Helvetica.Bold.Italic.cd.Z
deleted file mode 100644
index e3106f24..00000000
Binary files a/obsolete/fonts/xerox/Helvetica.Bold.Italic.cd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Helvetica.Bold.cd.Z b/obsolete/fonts/xerox/Helvetica.Bold.cd.Z
deleted file mode 100644
index 0fbab49b..00000000
Binary files a/obsolete/fonts/xerox/Helvetica.Bold.cd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Helvetica.Italic.cd.Z b/obsolete/fonts/xerox/Helvetica.Italic.cd.Z
deleted file mode 100644
index bb58ec0a..00000000
Binary files a/obsolete/fonts/xerox/Helvetica.Italic.cd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Helvetica.cd.Z b/obsolete/fonts/xerox/Helvetica.cd.Z
deleted file mode 100644
index 81c1873a..00000000
Binary files a/obsolete/fonts/xerox/Helvetica.cd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCBauhaus.wd.Z b/obsolete/fonts/xerox/ITCBauhaus.wd.Z
deleted file mode 100644
index 333a6174..00000000
Binary files a/obsolete/fonts/xerox/ITCBauhaus.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCBauhaus10-C0.DISPLAYFONT.Z b/obsolete/fonts/xerox/ITCBauhaus10-C0.DISPLAYFONT.Z
deleted file mode 100644
index 6053d463..00000000
Binary files a/obsolete/fonts/xerox/ITCBauhaus10-C0.DISPLAYFONT.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCBauhaus10-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus10-C0.wd.Z
deleted file mode 100644
index 333a6174..00000000
Binary files a/obsolete/fonts/xerox/ITCBauhaus10-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCBauhaus12-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus12-C0.wd.Z
deleted file mode 100644
index 333a6174..00000000
Binary files a/obsolete/fonts/xerox/ITCBauhaus12-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCBauhaus14-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus14-C0.wd.Z
deleted file mode 100644
index 333a6174..00000000
Binary files a/obsolete/fonts/xerox/ITCBauhaus14-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCBauhaus18-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus18-C0.wd.Z
deleted file mode 100644
index 333a6174..00000000
Binary files a/obsolete/fonts/xerox/ITCBauhaus18-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCBauhaus24-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus24-C0.wd.Z
deleted file mode 100644
index 333a6174..00000000
Binary files a/obsolete/fonts/xerox/ITCBauhaus24-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCBauhaus6-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus6-C0.wd.Z
deleted file mode 100644
index 333a6174..00000000
Binary files a/obsolete/fonts/xerox/ITCBauhaus6-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCBauhaus8-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus8-C0.wd.Z
deleted file mode 100644
index 333a6174..00000000
Binary files a/obsolete/fonts/xerox/ITCBauhaus8-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCCushing.wd.Z b/obsolete/fonts/xerox/ITCCushing.wd.Z
deleted file mode 100644
index d3be7bac..00000000
Binary files a/obsolete/fonts/xerox/ITCCushing.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond.wd.Z b/obsolete/fonts/xerox/ITCGaramond.wd.Z
deleted file mode 100644
index d535b574..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond11-C0.ac.Z b/obsolete/fonts/xerox/ITCGaramond11-C0.ac.Z
deleted file mode 100644
index fb85bde7..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond11-C0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond11MRR72C0.ac.Z b/obsolete/fonts/xerox/ITCGaramond11MRR72C0.ac.Z
deleted file mode 100644
index fb85bde7..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond11MRR72C0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c0.ac.Z
deleted file mode 100644
index 45e9eb07..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c356.ac.Z
deleted file mode 100644
index 1fb6daa5..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c357.ac.Z
deleted file mode 100644
index 9b1917a9..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c360.ac.Z
deleted file mode 100644
index cff07a31..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c361.ac.Z
deleted file mode 100644
index a207f341..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c41.ac.Z
deleted file mode 100644
index 7d965eef..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c0.ac.Z
deleted file mode 100644
index e2cbd66c..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c356.ac.Z
deleted file mode 100644
index 4e1279c0..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c357.ac.Z
deleted file mode 100644
index f21b1f7c..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c360.ac.Z
deleted file mode 100644
index c74d19e9..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c361.ac.Z
deleted file mode 100644
index e6f76634..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c41.ac.Z
deleted file mode 100644
index 5a50d677..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c0.ac.Z
deleted file mode 100644
index 72dd024c..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c356.ac.Z
deleted file mode 100644
index f2117fde..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c357.ac.Z
deleted file mode 100644
index b4eddb3c..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c360.ac.Z
deleted file mode 100644
index d1d6f897..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c361.ac.Z
deleted file mode 100644
index 7d239bda..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c41.ac.Z
deleted file mode 100644
index 8c1cd383..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c0.ac.Z
deleted file mode 100644
index 2beacb8b..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c356.ac.Z
deleted file mode 100644
index 7941fd50..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c357.ac.Z
deleted file mode 100644
index 771d5a94..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c360.ac.Z
deleted file mode 100644
index 34e2bf98..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c361.ac.Z
deleted file mode 100644
index e1c06c38..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond12-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c41.ac.Z
deleted file mode 100644
index d832ba8b..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond12-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c0.ac.Z
deleted file mode 100644
index c5e2cfac..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c356.ac.Z
deleted file mode 100644
index bbb594c9..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c357.ac.Z
deleted file mode 100644
index c0123407..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c360.ac.Z
deleted file mode 100644
index 970e5718..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c361.ac.Z
deleted file mode 100644
index 10a6c9a6..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c41.ac.Z
deleted file mode 100644
index ea5552d4..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c0.ac.Z
deleted file mode 100644
index cc380da7..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c356.ac.Z
deleted file mode 100644
index dceacdd1..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c357.ac.Z
deleted file mode 100644
index 92211e14..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c360.ac.Z
deleted file mode 100644
index f217ffe4..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c361.ac.Z
deleted file mode 100644
index b23504bc..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c41.ac.Z
deleted file mode 100644
index 04b46936..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c0.ac.Z
deleted file mode 100644
index c87c32a8..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c356.ac.Z
deleted file mode 100644
index c65ed3a9..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c357.ac.Z
deleted file mode 100644
index 26c056d5..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c360.ac.Z
deleted file mode 100644
index 040e6d9e..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c361.ac.Z
deleted file mode 100644
index 7112678f..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c41.ac.Z
deleted file mode 100644
index 9bc70c8b..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c0.ac.Z
deleted file mode 100644
index e21df0e4..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c356.ac.Z
deleted file mode 100644
index d4681ba2..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c357.ac.Z
deleted file mode 100644
index 7c5a2761..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c360.ac.Z
deleted file mode 100644
index c4722627..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c361.ac.Z
deleted file mode 100644
index 55cefc3d..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond14-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c41.ac.Z
deleted file mode 100644
index cee5f116..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond14-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c0.ac.Z
deleted file mode 100644
index 0dc26d37..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c356.ac.Z
deleted file mode 100644
index de8f6ea2..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c357.ac.Z
deleted file mode 100644
index 73000d84..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c360.ac.Z
deleted file mode 100644
index 63f9a8c9..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c361.ac.Z
deleted file mode 100644
index 7e3922ab..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c41.ac.Z
deleted file mode 100644
index 3b64e5dc..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c0.ac.Z
deleted file mode 100644
index 6865dd3c..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c356.ac.Z
deleted file mode 100644
index b85671b6..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c357.ac.Z
deleted file mode 100644
index 874c499b..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c360.ac.Z
deleted file mode 100644
index 7d598976..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c361.ac.Z
deleted file mode 100644
index f8c8ef74..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c41.ac.Z
deleted file mode 100644
index 7df9dd52..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c0.ac.Z
deleted file mode 100644
index 90dc8a33..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c356.ac.Z
deleted file mode 100644
index 068da7c1..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c357.ac.Z
deleted file mode 100644
index 6052cdd5..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c360.ac.Z
deleted file mode 100644
index 9fc95f7c..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c361.ac.Z
deleted file mode 100644
index a03c4bf2..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c41.ac.Z
deleted file mode 100644
index d9550299..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c0.ac.Z
deleted file mode 100644
index 33bfdfab..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c356.ac.Z
deleted file mode 100644
index 030e8730..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c357.ac.Z
deleted file mode 100644
index 36560326..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c360.ac.Z
deleted file mode 100644
index 6acb6580..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c361.ac.Z
deleted file mode 100644
index 48891c2f..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond18-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c41.ac.Z
deleted file mode 100644
index e29fee37..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond18-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c0.ac.Z
deleted file mode 100644
index add1317f..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c356.ac.Z
deleted file mode 100644
index eabf7ac2..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c357.ac.Z
deleted file mode 100644
index 991e23a4..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c360.ac.Z
deleted file mode 100644
index 1a9909b6..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c361.ac.Z
deleted file mode 100644
index 095cbd60..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c41.ac.Z
deleted file mode 100644
index 712612ee..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c0.ac.Z
deleted file mode 100644
index 41035a44..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c356.ac.Z
deleted file mode 100644
index 5a5f8624..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c357.ac.Z
deleted file mode 100644
index a0d8b60a..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c360.ac.Z
deleted file mode 100644
index a8dd2c29..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c361.ac.Z
deleted file mode 100644
index 53eb96e4..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c41.ac.Z
deleted file mode 100644
index 705a6d6e..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c0.ac.Z
deleted file mode 100644
index 253d8e75..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c356.ac.Z
deleted file mode 100644
index 07391653..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c357.ac.Z
deleted file mode 100644
index 0dcd7d76..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c360.ac.Z
deleted file mode 100644
index f583e983..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c361.ac.Z
deleted file mode 100644
index 80fedc21..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c41.ac.Z
deleted file mode 100644
index 62d2c358..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-c0.ac.Z
deleted file mode 100644
index 98e31c3a..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond24-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-c356.ac.Z
deleted file mode 100644
index 3e253bfc..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond24-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c0.ac.Z
deleted file mode 100644
index 221425d2..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c356.ac.Z
deleted file mode 100644
index c2fe1db8..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c357.ac.Z
deleted file mode 100644
index 1bfec6f1..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c360.ac.Z
deleted file mode 100644
index ef2fad40..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c361.ac.Z
deleted file mode 100644
index 6dc98ac4..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c41.ac.Z
deleted file mode 100644
index ff93943c..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c0.ac.Z
deleted file mode 100644
index 5f955ff6..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c356.ac.Z
deleted file mode 100644
index 2e7337a6..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c357.ac.Z
deleted file mode 100644
index 36cbc9e2..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c360.ac.Z
deleted file mode 100644
index 2070f7a7..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c361.ac.Z
deleted file mode 100644
index e5acedf2..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c41.ac.Z
deleted file mode 100644
index 8455010f..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c0.ac.Z
deleted file mode 100644
index 66fe0025..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c356.ac.Z
deleted file mode 100644
index 20460502..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c357.ac.Z
deleted file mode 100644
index 6681f4d7..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c360.ac.Z
deleted file mode 100644
index d053bd42..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c361.ac.Z
deleted file mode 100644
index cefca376..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c41.ac.Z
deleted file mode 100644
index f2a32894..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-c356.ac.Z
deleted file mode 100644
index 2ff79b89..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-c357.ac.Z
deleted file mode 100644
index a0dc6681..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-c360.ac.Z
deleted file mode 100644
index 8279eb35..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-c361.ac.Z
deleted file mode 100644
index 9ef60df8..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond30-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-c41.ac.Z
deleted file mode 100644
index 21eb2134..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond30-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c0.ac.Z
deleted file mode 100644
index 4fe8ccff..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c356.ac.Z
deleted file mode 100644
index 94be34d3..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c357.ac.Z
deleted file mode 100644
index 96a778ce..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c360.ac.Z
deleted file mode 100644
index deb04f24..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c361.ac.Z
deleted file mode 100644
index 67b8d99b..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c41.ac.Z
deleted file mode 100644
index a9673e1c..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c0.ac.Z
deleted file mode 100644
index ae4c196b..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c356.ac.Z
deleted file mode 100644
index 7e3040d8..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c357.ac.Z
deleted file mode 100644
index 2c7380c5..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c360.ac.Z
deleted file mode 100644
index 7afa5f2d..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c361.ac.Z
deleted file mode 100644
index c656d8bb..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c41.ac.Z
deleted file mode 100644
index 4aafb785..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c0.ac.Z
deleted file mode 100644
index ff1c8bc9..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c356.ac.Z
deleted file mode 100644
index 96391829..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c357.ac.Z
deleted file mode 100644
index 5832dbc6..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c360.ac.Z
deleted file mode 100644
index d6229cb3..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c361.ac.Z
deleted file mode 100644
index 1d528db1..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c41.ac.Z
deleted file mode 100644
index aba4b8f7..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c0.ac.Z
deleted file mode 100644
index 2a64e8f9..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-c0.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c356.ac.Z
deleted file mode 100644
index 1296250e..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-c356.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c357.ac.Z
deleted file mode 100644
index 37c96ed7..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-c357.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c360.ac.Z
deleted file mode 100644
index a0f04688..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-c360.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c361.ac.Z
deleted file mode 100644
index 5c192ef7..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-c361.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ITCGaramond36-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c41.ac.Z
deleted file mode 100644
index d767985e..00000000
Binary files a/obsolete/fonts/xerox/ITCGaramond36-c41.ac.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Logo1.wd.Z b/obsolete/fonts/xerox/Logo1.wd.Z
deleted file mode 100644
index 54e8726b..00000000
Binary files a/obsolete/fonts/xerox/Logo1.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C0.wd.Z
deleted file mode 100644
index 4b30e124..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C356.wd.Z
deleted file mode 100644
index aaeff29c..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C357.wd.Z
deleted file mode 100644
index eb9d6d06..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C360.wd.Z
deleted file mode 100644
index 0ec03c10..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C361.wd.Z
deleted file mode 100644
index dfd7b2e3..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C41.wd.Z
deleted file mode 100644
index 6142d5f8..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C42.wd.Z
deleted file mode 100644
index d63e9421..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C43.wd.Z
deleted file mode 100644
index 2dd8aae5..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C0.wd.Z
deleted file mode 100644
index e678c10c..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C356.wd.Z
deleted file mode 100644
index 224abb6e..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C357.wd.Z
deleted file mode 100644
index 8aa5cd20..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C360.wd.Z
deleted file mode 100644
index d7c50952..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C361.wd.Z
deleted file mode 100644
index 41995838..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C41.wd.Z
deleted file mode 100644
index 8adf037c..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C42.wd.Z
deleted file mode 100644
index f2aa3a91..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C43.wd.Z
deleted file mode 100644
index 225b0585..00000000
Binary files a/obsolete/fonts/xerox/Optima06-BRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C0.wd.Z
deleted file mode 100644
index 851964f6..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C356.wd.Z
deleted file mode 100644
index 13c9d752..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C357.wd.Z
deleted file mode 100644
index 5a6e2893..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C360.wd.Z
deleted file mode 100644
index 2d54f0ee..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C361.wd.Z
deleted file mode 100644
index c4e57029..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C41.wd.Z
deleted file mode 100644
index bf21c2b1..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C42.wd.Z
deleted file mode 100644
index 7f14b0f4..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C43.wd.Z
deleted file mode 100644
index 17bbef89..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C0.wd.Z
deleted file mode 100644
index 13bafc69..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C356.wd.Z
deleted file mode 100644
index 78db5164..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C357.wd.Z
deleted file mode 100644
index 9734d009..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C360.wd.Z
deleted file mode 100644
index b3e72dcc..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C361.wd.Z
deleted file mode 100644
index 141c4c62..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C41.wd.Z
deleted file mode 100644
index 95a5a463..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C42.wd.Z
deleted file mode 100644
index 6257198b..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima06-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C43.wd.Z
deleted file mode 100644
index ab5a661c..00000000
Binary files a/obsolete/fonts/xerox/Optima06-MRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C0.wd.Z
deleted file mode 100644
index 392220ed..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C356.wd.Z
deleted file mode 100644
index f694754d..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C357.wd.Z
deleted file mode 100644
index 2619347f..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C360.wd.Z
deleted file mode 100644
index d52c40fa..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C361.wd.Z
deleted file mode 100644
index 30dd0f9f..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C41.wd.Z
deleted file mode 100644
index c17d6ab2..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C42.wd.Z
deleted file mode 100644
index d0e9ab50..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C43.wd.Z
deleted file mode 100644
index e42095e1..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C0.wd.Z
deleted file mode 100644
index cc6adc69..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C356.wd.Z
deleted file mode 100644
index 1586b2e2..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C357.wd.Z
deleted file mode 100644
index 69ba5d6e..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C360.wd.Z
deleted file mode 100644
index f318ae18..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C361.wd.Z
deleted file mode 100644
index 2a02146f..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C41.wd.Z
deleted file mode 100644
index 277c6e3d..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C42.wd.Z
deleted file mode 100644
index 4b88cb54..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C43.wd.Z
deleted file mode 100644
index 67e9552c..00000000
Binary files a/obsolete/fonts/xerox/Optima07-BRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C0.wd.Z
deleted file mode 100644
index cb69ab21..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C356.wd.Z
deleted file mode 100644
index aee6efe4..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C357.wd.Z
deleted file mode 100644
index c2ceac3c..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C360.wd.Z
deleted file mode 100644
index 6a7f7b76..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C361.wd.Z
deleted file mode 100644
index 78683be0..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C41.wd.Z
deleted file mode 100644
index 5bda30c2..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C42.wd.Z
deleted file mode 100644
index fa45e730..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C43.wd.Z
deleted file mode 100644
index 92e65aae..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C0.wd.Z
deleted file mode 100644
index 9b1fe80f..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C356.wd.Z
deleted file mode 100644
index ec943065..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C357.wd.Z
deleted file mode 100644
index 9d025257..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C360.wd.Z
deleted file mode 100644
index 8e20c318..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C361.wd.Z
deleted file mode 100644
index c6661dd0..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C41.wd.Z
deleted file mode 100644
index 3089ebe7..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C42.wd.Z
deleted file mode 100644
index 58f54ca7..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima07-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C43.wd.Z
deleted file mode 100644
index 95ccddbf..00000000
Binary files a/obsolete/fonts/xerox/Optima07-MRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C0.wd.Z
deleted file mode 100644
index d83e658c..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C356.wd.Z
deleted file mode 100644
index 3ec89fc0..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C357.wd.Z
deleted file mode 100644
index 33fab467..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C360.wd.Z
deleted file mode 100644
index 2f288a0e..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C361.wd.Z
deleted file mode 100644
index 5ce7100f..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C41.wd.Z
deleted file mode 100644
index e1625c81..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C42.wd.Z
deleted file mode 100644
index faa99bc3..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C43.wd.Z
deleted file mode 100644
index 038a0d9d..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C0.wd.Z
deleted file mode 100644
index e789ee49..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C356.wd.Z
deleted file mode 100644
index d7969a23..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C357.wd.Z
deleted file mode 100644
index d5a23ff3..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C360.wd.Z
deleted file mode 100644
index b944a223..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C361.wd.Z
deleted file mode 100644
index 86c4704e..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C41.wd.Z
deleted file mode 100644
index d30f68ef..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C42.wd.Z
deleted file mode 100644
index cf016b03..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C43.wd.Z
deleted file mode 100644
index 6c4d0445..00000000
Binary files a/obsolete/fonts/xerox/Optima08-BRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C0.wd.Z
deleted file mode 100644
index 4422e7f9..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C356.wd.Z
deleted file mode 100644
index abd7f15f..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C357.wd.Z
deleted file mode 100644
index 99b78bcc..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C360.wd.Z
deleted file mode 100644
index 95f94777..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C361.wd.Z
deleted file mode 100644
index 794b6152..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C41.wd.Z
deleted file mode 100644
index 8de1e75a..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C42.wd.Z
deleted file mode 100644
index 7cabc977..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C43.wd.Z
deleted file mode 100644
index dde1407b..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C0.wd.Z
deleted file mode 100644
index 21449490..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C356.wd.Z
deleted file mode 100644
index 25eb065e..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C357.wd.Z
deleted file mode 100644
index 379c26a4..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C360.wd.Z
deleted file mode 100644
index d7861326..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C361.wd.Z
deleted file mode 100644
index 06f45ced..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C41.wd.Z
deleted file mode 100644
index baafd8f8..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C42.wd.Z
deleted file mode 100644
index 95eba98d..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima08-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C43.wd.Z
deleted file mode 100644
index d3ef2c5b..00000000
Binary files a/obsolete/fonts/xerox/Optima08-MRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C0.wd.Z
deleted file mode 100644
index 19dc6f86..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C356.wd.Z
deleted file mode 100644
index 20b8ad7c..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C357.wd.Z
deleted file mode 100644
index 8742fb7a..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C360.wd.Z
deleted file mode 100644
index 1631c149..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C361.wd.Z
deleted file mode 100644
index 159a1dc6..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C41.wd.Z
deleted file mode 100644
index b405836f..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C42.wd.Z
deleted file mode 100644
index fa504ac5..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C43.wd.Z
deleted file mode 100644
index 7c1f5f34..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C0.wd.Z
deleted file mode 100644
index 5eca9f1e..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C356.wd.Z
deleted file mode 100644
index 56d11d92..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C357.wd.Z
deleted file mode 100644
index 49f5990f..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C360.wd.Z
deleted file mode 100644
index fdf13e83..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C361.wd.Z
deleted file mode 100644
index 128be853..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C41.wd.Z
deleted file mode 100644
index 52c64d3e..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C42.wd.Z
deleted file mode 100644
index 58d7f20e..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C43.wd.Z
deleted file mode 100644
index dbfc9b79..00000000
Binary files a/obsolete/fonts/xerox/Optima09-BRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C0.wd.Z
deleted file mode 100644
index 629049ec..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C356.wd.Z
deleted file mode 100644
index 605f4f91..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C357.wd.Z
deleted file mode 100644
index e524bdab..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C360.wd.Z
deleted file mode 100644
index 80a3a47b..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C361.wd.Z
deleted file mode 100644
index c2a58ad2..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C41.wd.Z
deleted file mode 100644
index df88c545..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C42.wd.Z
deleted file mode 100644
index a039faca..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C43.wd.Z
deleted file mode 100644
index 42efc235..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C0.wd.Z
deleted file mode 100644
index 341b93ae..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C356.wd.Z
deleted file mode 100644
index 3a001681..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MRR-C357.wd b/obsolete/fonts/xerox/Optima09-MRR-C357.wd
deleted file mode 100644
index 32453eb0..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MRR-C357.wd and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C357.wd.Z
deleted file mode 100644
index ae0492fc..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C360.wd.Z
deleted file mode 100644
index ca260877..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C361.wd.Z
deleted file mode 100644
index e2435861..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C41.wd.Z
deleted file mode 100644
index c189e6f3..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C42.wd.Z
deleted file mode 100644
index 302911c8..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima09-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C43.wd.Z
deleted file mode 100644
index 21545185..00000000
Binary files a/obsolete/fonts/xerox/Optima09-MRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C0.wd.Z
deleted file mode 100644
index 6ebb2335..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C356.wd.Z
deleted file mode 100644
index 1502f3a6..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C357.wd.Z
deleted file mode 100644
index 4eb51521..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C360.wd.Z
deleted file mode 100644
index 848714ad..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C361.wd.Z
deleted file mode 100644
index 7fb26430..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C41.wd.Z
deleted file mode 100644
index d025e704..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C42.wd.Z
deleted file mode 100644
index 7e164fc3..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C43.wd.Z
deleted file mode 100644
index c911ceeb..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C0.wd.Z
deleted file mode 100644
index 01af4d2b..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C356.wd.Z
deleted file mode 100644
index f8cb632d..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C357.wd.Z
deleted file mode 100644
index ac7ec290..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C360.wd.Z
deleted file mode 100644
index 812a004a..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C361.wd.Z
deleted file mode 100644
index 53d8fd49..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C41.wd.Z
deleted file mode 100644
index 8c2a3c10..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C42.wd.Z
deleted file mode 100644
index 94556645..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C43.wd.Z
deleted file mode 100644
index 9b9f105f..00000000
Binary files a/obsolete/fonts/xerox/Optima10-BRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C0.wd.Z
deleted file mode 100644
index 88810ac9..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C356.wd.Z
deleted file mode 100644
index c401a829..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C357.wd.Z
deleted file mode 100644
index 5f01365f..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C360.wd.Z
deleted file mode 100644
index 66e7f050..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C361.wd.Z
deleted file mode 100644
index c15f1440..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C41.wd.Z
deleted file mode 100644
index e9e3bd82..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C42.wd.Z
deleted file mode 100644
index 9ba96c80..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C43.wd.Z
deleted file mode 100644
index e53bfb1b..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C0.wd.Z
deleted file mode 100644
index 386e0741..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C356.wd.Z
deleted file mode 100644
index 346668df..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C357.wd.Z
deleted file mode 100644
index 747a378f..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C360.wd.Z
deleted file mode 100644
index 1e2d2130..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C361.wd.Z
deleted file mode 100644
index d40c8a72..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C41.wd.Z
deleted file mode 100644
index 65cfa038..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C42.wd.Z
deleted file mode 100644
index 258a03f5..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima10-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C43.wd.Z
deleted file mode 100644
index 897fbe19..00000000
Binary files a/obsolete/fonts/xerox/Optima10-MRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C0.wd.Z
deleted file mode 100644
index 63e5ca83..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C356.wd.Z
deleted file mode 100644
index 7e8a45bb..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C357.wd.Z
deleted file mode 100644
index d222eecb..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C360.wd.Z
deleted file mode 100644
index acdcda50..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C361.wd.Z
deleted file mode 100644
index c3beeffb..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C41.wd.Z
deleted file mode 100644
index 52992b35..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C42.wd.Z
deleted file mode 100644
index dd777ed2..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C43.wd.Z
deleted file mode 100644
index 404da8da..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C0.wd.Z
deleted file mode 100644
index aa440c40..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C356.wd.Z
deleted file mode 100644
index 07232a8c..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C357.wd.Z
deleted file mode 100644
index df460749..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C360.wd.Z
deleted file mode 100644
index dd24643d..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C361.wd.Z
deleted file mode 100644
index 76f1964a..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C41.wd.Z
deleted file mode 100644
index 7eb8e5a1..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C42.wd.Z
deleted file mode 100644
index 3c06b609..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C43.wd.Z
deleted file mode 100644
index cde1bf05..00000000
Binary files a/obsolete/fonts/xerox/Optima11-BRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C0.wd.Z
deleted file mode 100644
index 2a81ddce..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C356.wd.Z
deleted file mode 100644
index 19b1cfe1..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C357.wd.Z
deleted file mode 100644
index efd12b65..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C360.wd.Z
deleted file mode 100644
index f21cb75f..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C361.wd.Z
deleted file mode 100644
index 12a4d465..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C41.wd.Z
deleted file mode 100644
index a582f62d..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C42.wd.Z
deleted file mode 100644
index 92bdb901..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C43.wd.Z
deleted file mode 100644
index 6efffd80..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C0.wd.Z
deleted file mode 100644
index 43a047ce..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C356.wd.Z
deleted file mode 100644
index 46c1a114..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C357.wd.Z
deleted file mode 100644
index 424be8d2..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C360.wd.Z
deleted file mode 100644
index 1d085005..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C361.wd.Z
deleted file mode 100644
index 6d782031..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C41.wd.Z
deleted file mode 100644
index 91eb54ae..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C42.wd.Z
deleted file mode 100644
index 036a09ba..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima11-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C43.wd.Z
deleted file mode 100644
index e252c335..00000000
Binary files a/obsolete/fonts/xerox/Optima11-MRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C0.wd.Z
deleted file mode 100644
index 4a636f8a..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C356.wd.Z
deleted file mode 100644
index cbb77d5a..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C357.wd.Z
deleted file mode 100644
index abc6d493..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C360.wd.Z
deleted file mode 100644
index d26bda85..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C361.wd.Z
deleted file mode 100644
index 8a941be9..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C41.wd.Z
deleted file mode 100644
index 817800e9..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C42.wd.Z
deleted file mode 100644
index a1e0cfb5..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C43.wd.Z
deleted file mode 100644
index 5aa05a86..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C0.wd.Z
deleted file mode 100644
index 464d956b..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C356.wd.Z
deleted file mode 100644
index 260459bc..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C357.wd.Z
deleted file mode 100644
index 5b2d42ff..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C360.wd.Z
deleted file mode 100644
index c90904dd..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C361.wd.Z
deleted file mode 100644
index 85fcc676..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C41.wd.Z
deleted file mode 100644
index 7365c0ca..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C42.wd.Z
deleted file mode 100644
index 5ddd5b8c..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C43.wd.Z
deleted file mode 100644
index 51598167..00000000
Binary files a/obsolete/fonts/xerox/Optima12-BRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C0.wd.Z
deleted file mode 100644
index 37982f24..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C356.wd.Z
deleted file mode 100644
index c71e2b5e..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C357.wd.Z
deleted file mode 100644
index 5a436382..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C360.wd.Z
deleted file mode 100644
index eadb2076..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C361.wd.Z
deleted file mode 100644
index e910416c..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C41.wd.Z
deleted file mode 100644
index a35b723b..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C42.wd.Z
deleted file mode 100644
index 784e0bfc..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C43.wd.Z
deleted file mode 100644
index dd3fe037..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C0.wd.Z
deleted file mode 100644
index fead936b..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C356.wd.Z
deleted file mode 100644
index 187c28f3..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C357.wd.Z
deleted file mode 100644
index aeadbb60..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C360.wd.Z
deleted file mode 100644
index 5afd6fd7..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C361.wd.Z
deleted file mode 100644
index 4c382f68..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C41.wd.Z
deleted file mode 100644
index 920dd62e..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C42.wd.Z
deleted file mode 100644
index 60721463..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima12-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C43.wd.Z
deleted file mode 100644
index 8524e14f..00000000
Binary files a/obsolete/fonts/xerox/Optima12-MRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C0.wd.Z
deleted file mode 100644
index 337b4d24..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C356.wd.Z
deleted file mode 100644
index 3dc063e1..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C357.wd.Z
deleted file mode 100644
index 8bb6b3f1..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C360.wd.Z
deleted file mode 100644
index 69ddd6e9..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C361.wd.Z
deleted file mode 100644
index 61dcf51f..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C41.wd.Z
deleted file mode 100644
index f60133ea..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C42.wd.Z
deleted file mode 100644
index f5b4005e..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C43.wd.Z
deleted file mode 100644
index f876ed43..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C0.wd.Z
deleted file mode 100644
index 1ce5f133..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C356.wd.Z
deleted file mode 100644
index e0ed88e9..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C357.wd.Z
deleted file mode 100644
index c35b7dde..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C360.wd.Z
deleted file mode 100644
index d688d00d..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C361.wd.Z
deleted file mode 100644
index 6fb3733b..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C41.wd.Z
deleted file mode 100644
index d58236c8..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C42.wd.Z
deleted file mode 100644
index b836b388..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C43.wd.Z
deleted file mode 100644
index 8f912d4c..00000000
Binary files a/obsolete/fonts/xerox/Optima14-BRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C0.wd.Z
deleted file mode 100644
index f1934fb6..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C356.wd.Z
deleted file mode 100644
index b00c05be..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C357.wd.Z
deleted file mode 100644
index 93108f0e..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C360.wd.Z
deleted file mode 100644
index 3ebeec75..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C361.wd.Z
deleted file mode 100644
index 73e30ff7..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C41.wd.Z
deleted file mode 100644
index b7410d1a..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C42.wd.Z
deleted file mode 100644
index 9e37040c..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C43.wd.Z
deleted file mode 100644
index d1361e38..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C0.wd.Z
deleted file mode 100644
index 596f7d3a..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C356.wd.Z
deleted file mode 100644
index e77e7715..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C357.wd.Z
deleted file mode 100644
index fb8b9356..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C360.wd.Z
deleted file mode 100644
index 6cc2c7eb..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C361.wd.Z
deleted file mode 100644
index 6da624f9..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C41.wd.Z
deleted file mode 100644
index fdee537e..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C42.wd.Z
deleted file mode 100644
index fefa8e30..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima14-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C43.wd.Z
deleted file mode 100644
index e6cd2a80..00000000
Binary files a/obsolete/fonts/xerox/Optima14-MRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C0.wd.Z
deleted file mode 100644
index 702e419b..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C356.wd.Z
deleted file mode 100644
index 914ce963..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C357.wd.Z
deleted file mode 100644
index 09811a5c..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C360.wd.Z
deleted file mode 100644
index 39f87d98..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C361.wd.Z
deleted file mode 100644
index 51bd7d90..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C41.wd.Z
deleted file mode 100644
index 5f9d7342..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C42.wd.Z
deleted file mode 100644
index 102cf737..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C43.wd.Z
deleted file mode 100644
index eb05afd2..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C0.wd.Z
deleted file mode 100644
index b0aa05fe..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C356.wd.Z
deleted file mode 100644
index 7801ad7a..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C357.wd.Z
deleted file mode 100644
index 5527e63d..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C360.wd.Z
deleted file mode 100644
index 4d18dc79..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C361.wd.Z
deleted file mode 100644
index cd5602f2..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C41.wd.Z
deleted file mode 100644
index 05812d5d..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C42.wd.Z
deleted file mode 100644
index 128f4db9..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C43.wd.Z
deleted file mode 100644
index bfa58ac5..00000000
Binary files a/obsolete/fonts/xerox/Optima18-BRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C0.wd.Z
deleted file mode 100644
index c5e017dc..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C356.wd.Z
deleted file mode 100644
index 5d6ddf77..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C357.wd.Z
deleted file mode 100644
index b23d5426..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C360.wd.Z
deleted file mode 100644
index 06aeb2d5..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C361.wd.Z
deleted file mode 100644
index b56b9fe3..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C41.wd.Z
deleted file mode 100644
index 9021534a..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C42.wd.Z
deleted file mode 100644
index 92c99192..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C43.wd.Z
deleted file mode 100644
index 992235c5..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C0.wd.Z
deleted file mode 100644
index 5f815a33..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C356.wd.Z
deleted file mode 100644
index dfb2c8ca..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C357.wd.Z
deleted file mode 100644
index a40ac4be..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C360.wd.Z
deleted file mode 100644
index bccfe919..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C361.wd.Z
deleted file mode 100644
index f2657a4b..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C41.wd.Z
deleted file mode 100644
index 56f25446..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C42.wd.Z
deleted file mode 100644
index 6fb38def..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima18-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C43.wd.Z
deleted file mode 100644
index b46621a2..00000000
Binary files a/obsolete/fonts/xerox/Optima18-MRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C0.wd.Z
deleted file mode 100644
index b6b0ff19..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C356.wd.Z
deleted file mode 100644
index 4ff19451..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C357.wd.Z
deleted file mode 100644
index 89eea879..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C360.wd.Z
deleted file mode 100644
index ecf6c6a3..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C361.wd.Z
deleted file mode 100644
index 12ec7819..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C41.wd.Z
deleted file mode 100644
index d901a3a8..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C42.wd.Z
deleted file mode 100644
index 862666d9..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C43.wd.Z
deleted file mode 100644
index 05b15c53..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C0.wd.Z
deleted file mode 100644
index baf5e83e..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C356.wd.Z
deleted file mode 100644
index 1c3a2f85..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C357.wd.Z
deleted file mode 100644
index e2667a61..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C360.wd.Z
deleted file mode 100644
index aeebae72..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C361.wd.Z
deleted file mode 100644
index 6623d118..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C41.wd.Z
deleted file mode 100644
index 5c86783a..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C42.wd.Z
deleted file mode 100644
index 7a1107e1..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C43.wd.Z
deleted file mode 100644
index 29208984..00000000
Binary files a/obsolete/fonts/xerox/Optima24-BRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C0.wd.Z
deleted file mode 100644
index 7bc4898b..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MIR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C356.wd.Z
deleted file mode 100644
index bf7e6dc6..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MIR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C357.wd.Z
deleted file mode 100644
index 8b2db7c6..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MIR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C360.wd.Z
deleted file mode 100644
index a8881d1f..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MIR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C361.wd.Z
deleted file mode 100644
index 5510824e..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MIR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C41.wd.Z
deleted file mode 100644
index 8e0e3593..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MIR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C42.wd.Z
deleted file mode 100644
index 56117b2d..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MIR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C43.wd.Z
deleted file mode 100644
index dd708f9d..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MIR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C0.wd.Z
deleted file mode 100644
index d487e4fd..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MRR-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C356.wd.Z
deleted file mode 100644
index 74ced308..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MRR-C356.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C357.wd.Z
deleted file mode 100644
index 3d439655..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MRR-C357.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C360.wd.Z
deleted file mode 100644
index b3157e80..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MRR-C360.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C361.wd.Z
deleted file mode 100644
index 0199f570..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MRR-C361.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C41.wd.Z
deleted file mode 100644
index f3959147..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MRR-C41.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C42.wd.Z
deleted file mode 100644
index e2fee30e..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MRR-C42.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Optima24-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C43.wd.Z
deleted file mode 100644
index 7fb8abd6..00000000
Binary files a/obsolete/fonts/xerox/Optima24-MRR-C43.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/OptimaItalic.NovaFont b/obsolete/fonts/xerox/OptimaItalic.NovaFont
deleted file mode 100644
index c16887e6..00000000
Binary files a/obsolete/fonts/xerox/OptimaItalic.NovaFont and /dev/null differ
diff --git a/obsolete/fonts/xerox/OptimaMedium.NovaFont b/obsolete/fonts/xerox/OptimaMedium.NovaFont
deleted file mode 100644
index 0bd7a685..00000000
Binary files a/obsolete/fonts/xerox/OptimaMedium.NovaFont and /dev/null differ
diff --git a/obsolete/fonts/xerox/README.TXT b/obsolete/fonts/xerox/README.TXT
deleted file mode 100644
index 2bc12d9e..00000000
--- a/obsolete/fonts/xerox/README.TXT
+++ /dev/null
@@ -1,3 +0,0 @@
-This directory contains fonts and font information which are to be used for Xerox internal uses only.  Under no circumstances can these fonts be released for customer use.  For information, contact Frank Shih, Lisp Development, Xerox Artificial Intelligence Systems.
-
-The screen fonts labelled ITCBauhaus are in fact just renamed copies of the font Modern.  This is because ITCBauhaus is not yet available at 72 dpi, and so the generic Modern is substituted instead.  Printers containing the font ITCBauhaus should be able to correctly render the file, however.
diff --git a/obsolete/fonts/xerox/ShimmerWide.wd.Z b/obsolete/fonts/xerox/ShimmerWide.wd.Z
deleted file mode 100644
index 8e15b003..00000000
Binary files a/obsolete/fonts/xerox/ShimmerWide.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ShimmerWideMIR.wd.Z b/obsolete/fonts/xerox/ShimmerWideMIR.wd.Z
deleted file mode 100644
index f1519951..00000000
Binary files a/obsolete/fonts/xerox/ShimmerWideMIR.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/ShimmerWideMRR.wd.Z b/obsolete/fonts/xerox/ShimmerWideMRR.wd.Z
deleted file mode 100644
index 14b49257..00000000
Binary files a/obsolete/fonts/xerox/ShimmerWideMRR.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Souvenir.wd.Z b/obsolete/fonts/xerox/Souvenir.wd.Z
deleted file mode 100644
index 42cdef41..00000000
Binary files a/obsolete/fonts/xerox/Souvenir.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/SouvenirBIRC0.wd.Z b/obsolete/fonts/xerox/SouvenirBIRC0.wd.Z
deleted file mode 100644
index c5e9deec..00000000
Binary files a/obsolete/fonts/xerox/SouvenirBIRC0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/SouvenirBRRC0.wd.Z b/obsolete/fonts/xerox/SouvenirBRRC0.wd.Z
deleted file mode 100644
index 3461533e..00000000
Binary files a/obsolete/fonts/xerox/SouvenirBRRC0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/SouvenirMIRC0.wd.Z b/obsolete/fonts/xerox/SouvenirMIRC0.wd.Z
deleted file mode 100644
index 2805dc07..00000000
Binary files a/obsolete/fonts/xerox/SouvenirMIRC0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/SouvenirMRRC0.wd.Z b/obsolete/fonts/xerox/SouvenirMRRC0.wd.Z
deleted file mode 100644
index 39c098de..00000000
Binary files a/obsolete/fonts/xerox/SouvenirMRRC0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/TROFF.wd.Z b/obsolete/fonts/xerox/TROFF.wd.Z
deleted file mode 100644
index 12afd1b0..00000000
Binary files a/obsolete/fonts/xerox/TROFF.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/TROFFFonts.widths b/obsolete/fonts/xerox/TROFFFonts.widths
deleted file mode 100644
index feb89704..00000000
Binary files a/obsolete/fonts/xerox/TROFFFonts.widths and /dev/null differ
diff --git a/obsolete/fonts/xerox/Times10-C0.wd.Z b/obsolete/fonts/xerox/Times10-C0.wd.Z
deleted file mode 100644
index 515b499f..00000000
Binary files a/obsolete/fonts/xerox/Times10-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Times12-C0.wd.Z b/obsolete/fonts/xerox/Times12-C0.wd.Z
deleted file mode 100644
index 515b499f..00000000
Binary files a/obsolete/fonts/xerox/Times12-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Times14-C0.wd.Z b/obsolete/fonts/xerox/Times14-C0.wd.Z
deleted file mode 100644
index 515b499f..00000000
Binary files a/obsolete/fonts/xerox/Times14-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Times18-C0.wd.Z b/obsolete/fonts/xerox/Times18-C0.wd.Z
deleted file mode 100644
index 515b499f..00000000
Binary files a/obsolete/fonts/xerox/Times18-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Times24-C0.wd.Z b/obsolete/fonts/xerox/Times24-C0.wd.Z
deleted file mode 100644
index 515b499f..00000000
Binary files a/obsolete/fonts/xerox/Times24-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Times36-C0.wd.Z b/obsolete/fonts/xerox/Times36-C0.wd.Z
deleted file mode 100644
index 515b499f..00000000
Binary files a/obsolete/fonts/xerox/Times36-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Times8-C0.wd.Z b/obsolete/fonts/xerox/Times8-C0.wd.Z
deleted file mode 100644
index 515b499f..00000000
Binary files a/obsolete/fonts/xerox/Times8-C0.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.FlemishScriptII b/obsolete/fonts/xerox/Xerox.XC1-1-1.FlemishScriptII
deleted file mode 100644
index 3d9f8c79..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.FlemishScriptII and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Gacha b/obsolete/fonts/xerox/Xerox.XC1-1-1.Gacha
deleted file mode 100644
index 3b51d735..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Gacha and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Bold.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Bold.Z
deleted file mode 100644
index b3908291..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Bold.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Z
deleted file mode 100644
index 499f3154..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Italic.Z
deleted file mode 100644
index cff26fdb..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Italic.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Z
deleted file mode 100644
index 17fd10bb..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Italic.Z
deleted file mode 100644
index 42d6fb4f..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Italic.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Z
deleted file mode 100644
index 5815198f..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Italic.Z
deleted file mode 100644
index 99d8b1da..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Italic.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Z
deleted file mode 100644
index 20aa00f4..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Italic.Z
deleted file mode 100644
index 781b0462..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Italic.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Z
deleted file mode 100644
index 451a2921..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Italic.Z
deleted file mode 100644
index 58b5c603..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Italic.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Z
deleted file mode 100644
index d7f9c46b..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Italic.Z
deleted file mode 100644
index 8c915e9c..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Italic.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Z
deleted file mode 100644
index 1095bcc5..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Italic.Z
deleted file mode 100644
index 951d6d68..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Italic.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Z
deleted file mode 100644
index 1ed25117..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Italic.Z
deleted file mode 100644
index 9e553fc8..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Italic.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Z
deleted file mode 100644
index 200fbbef..00000000
Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/itcberkeley.wd.Z b/obsolete/fonts/xerox/itcberkeley.wd.Z
deleted file mode 100644
index 83219d3b..00000000
Binary files a/obsolete/fonts/xerox/itcberkeley.wd.Z and /dev/null differ
diff --git a/obsolete/fonts/xerox/tffonts.widths b/obsolete/fonts/xerox/tffonts.widths
deleted file mode 100644
index eb47c1f3..00000000
Binary files a/obsolete/fonts/xerox/tffonts.widths and /dev/null differ
diff --git a/obsolete/greetfiles/INIT b/obsolete/greetfiles/INIT
deleted file mode 100644
index c28c86e5..00000000
Binary files a/obsolete/greetfiles/INIT and /dev/null differ
diff --git a/obsolete/greetfiles/INIT.LCOM b/obsolete/greetfiles/INIT.LCOM
deleted file mode 100644
index e3628377..00000000
Binary files a/obsolete/greetfiles/INIT.LCOM and /dev/null differ
diff --git a/obsolete/greetfiles/LOCAL-INIT b/obsolete/greetfiles/LOCAL-INIT
deleted file mode 100644
index 2f56dcaf..00000000
--- a/obsolete/greetfiles/LOCAL-INIT
+++ /dev/null
@@ -1,55 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Oct-2020 15:19:00" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>greetfiles>LOCAL-INIT.;45 10099  

      previous date%: "19-Oct-2020 15:15:23" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>greetfiles>LOCAL-INIT.;44)


(PRETTYCOMPRINT LOCAL-INITCOMS)

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

        (FNS INTERLISPMODE)
        (VARS (COMPILEIGNOREDECL T)
              (MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))
              (SITE 'LOCAL-MAC))
        (P (BKSYSBUF " ")
                                                             (* ; 
                                                       "So tty window doesn't hang during greeting")
           (INTERLISPMODE)
           (DEFCOMMAND ("show" :QUIET)
                  (&REST EVENTSPEC)
                  (CL:PPRINT (VALUOF EVENTSPEC T)
                         T)))
        (FNS LOCAL-INIT LoadPatches COLLECT-PATCH-FILES)
        (FUNCTIONS WITHOUT.PAGEHOLD)
        (VARS (LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
                                          (CONCAT MEDLEYDIR "/lispcore/library")))
              (LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))
              (DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
                                  LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))
              (LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches")))
        [VARS (USERGREETFILES '(({DSK}/Users/ USER /Lisp/INIT.LCOM)
                                ({DSK}/Users/ USER /Lisp/INIT.DFASL)
                                ({DSK}/Users/ USER /Lisp/INIT]
        [VARS (*USEOLDFONTDIRECTORIES* NIL)
              [DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
                                            (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts]
              [INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts]
              (POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts]
        (DECLARE%: DONTEVAL@LOAD DOCOPY [P (KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE]
               (P (LOCAL-INIT)
                                                             (* ; 
                                                           "(SETQ USERNAME (UNIX-GETENV %"USER%"))")
                  )
                                                             (* ; "To get personal greeting to work, since GREET computes the USERNAME before USERNAMEPATCH is loaded.")
               )
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA])



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

(DEFINEQ

(INTERLISPMODE
-  [LAMBDA (OLD?)                                         (* N.H.Briggs " 2-Feb-88 14:26")
-    (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD?
-                                                      then "OLD-INTERLISP-T"
-                                                    else "INTERLISP")))
-    (XCL:SET-DEFAULT-EXEC-TYPE (if OLD?
-                                   then "OLD-INTERLISP-T"
-                                 else "INTERLISP"))
-    (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD?
-                                                              then "OLD-INTERLISP-FILE"
-                                                            else "INTERLISP")
-                                               :PACKAGE "INTERLISP"])
)

(RPAQQ COMPILEIGNOREDECL T)

(RPAQ MEDLEYDIR (UNIX-GETENV 'MEDLEYDIR))

(RPAQQ SITE LOCAL-MAC)

(BKSYSBUF " ")

                                                             (* ; 
                                                       "So tty window doesn't hang during greeting")

(INTERLISPMODE)

(DEFCOMMAND ("show" :QUIET) (&REST EVENTSPEC) (CL:PPRINT (VALUOF EVENTSPEC T)
                                                     T))
(DEFINEQ

(LOCAL-INIT
  [LAMBDA NIL
    (DECLARE (GLOBALVARS MAKESYSNAME LOCALPATCHDIRECTORY))
                                                          (* ; "Edited 14-Jun-2017 14:45 by kaplan")
                                                          (* ; "Edited 14-Jun-2017 11:15 by kaplan")

    (* ;; "This is what gets called when LOCAL-INIT is loaded.")

    (BKSYSBUF " ")

    (* ;; "do the real work")

    (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT))
           (CL:WHEN LOCALPATCHDIRECTORY
               (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))])

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

(DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS)
   `(RESETLST
        (LET* ((TTYWINDOW ,WINDOW)
               (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN))
               (NEW.PAGEFULLFN (FUNCTION NILL)))
              (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN)
                     (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)
                                       (COND
                                          ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN)
                                               NEW.PAGEFULLFN)
                                           (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN]
                           TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)))
        ,@FORMS))

(RPAQ LISPUSERSDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/lispusers")
                                     (CONCAT MEDLEYDIR "/lispcore/library")))

(RPAQ LISPSOURCEDIRECTORIES (LIST (CONCAT MEDLEYDIR "/lispcore/sources")))

(RPAQ DIRECTORIES (APPEND (CONS (CONCAT MEDLEYDIR "/lispcore/patches"))
                             LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES))

(RPAQ LOCALPATCHDIRECTORY (CONCAT MEDLEYDIR "/lispcore/patches"))

(RPAQQ USERGREETFILES (({DSK}/Users/ USER /Lisp/INIT.LCOM)
                           ({DSK}/Users/ USER /Lisp/INIT.DFASL)
                           ({DSK}/Users/ USER /Lisp/INIT)))

(RPAQQ *USEOLDFONTDIRECTORIES* NIL)

(RPAQ DISPLAYFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/displayfonts)
                                       (CONCAT MEDLEYDIR '/lispcore/fonts/altofonts)))

(RPAQ INTERPRESSFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/ipfonts)))

(RPAQ POSTSCRIPTFONTDIRECTORIES (LIST (CONCAT MEDLEYDIR '/lispcore/fonts/postscriptfonts)))
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(KEYACTION 'LOCK '(LOCKTOGGLE . IGNORE))


(LOCAL-INIT)

                                                             (* ; 
                                                           "(SETQ USERNAME (UNIX-GETENV %"USER%"))")
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(PUTPROPS LOCAL-INIT COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2974 3799 (INTERLISPMODE 2984 . 3797)) (4258 7810 (LOCAL-INIT 4268 . 4879) (LoadPatches
 4881 . 6829) (COLLECT-PATCH-FILES 6831 . 7808)))))
STOP
\ No newline at end of file
diff --git a/obsolete/greetfiles/LOCAL-INIT.LCOM b/obsolete/greetfiles/LOCAL-INIT.LCOM
deleted file mode 100644
index 154e2567..00000000
Binary files a/obsolete/greetfiles/LOCAL-INIT.LCOM and /dev/null differ
diff --git a/obsolete/greetfiles/PARC-INIT b/obsolete/greetfiles/PARC-INIT
deleted file mode 100644
index 34c1961e..00000000
--- a/obsolete/greetfiles/PARC-INIT
+++ /dev/null
@@ -1,433 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 3-Mar-2002 22:47:25" {DSK}<project>medley3.5>current>PARC-INIT.;21 42271  

      changes to%:  (FNS ParcInit)

      previous date%: "14-Feb-2002 09:12:08" {DSK}<project>medley3.5>current>PARC-INIT.;20)


(* ; "
Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2002 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT PARC-INITCOMS)

(RPAQQ PARC-INITCOMS
       [
        (* ;; "PARC/SSL, and IRL  system greeting file")

        (DECLARE%: FIRST (P                                  (* ; "Patch for SOLARIS at DDS??")
                            (CL:INTERN "*YP-DOMAIN*" "YP")))
        (FNS PARC-INIT FindSite FindInitHost ParcInit SetDirectories LoadPatches COLLECT-PATCH-FILES
             INTERLISPMODE FILE-SERVER-UP-P HostPrefix)
        (FNS SUNOSNAME)
        (FUNCTIONS WITHOUT.PAGEHOLD)
        
        (* ;; 
      "Initially set LOCALPATCHDIRECTORY to NIL to avoid loading patches if no servers are up.")

        (VARS (LOCALPATCHDIRECTORY NIL))
        (VARS (*USEOLDFONTDIRECTORIES* NIL))
        (INITVARS (UNIXMAIL.DOMAIN.NAME "parc.com"))
        (INITVARS (INIT-NOGREET-FLAG NIL))
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (PARC-INIT)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA])



(* ;; "PARC/SSL, and IRL  system greeting file")

(DECLARE%: FIRST 

                                                             (* ; "Patch for SOLARIS at DDS??")

(CL:INTERN "*YP-DOMAIN*" "YP")
)
(DEFINEQ

(PARC-INIT
-  [LAMBDA NIL
-    (DECLARE (GLOBALVARS \INIT.HostName MAKESYSNAME LOCALPATCHDIRECTORY MAKESYSDATE 
-                        AUTHENTICATION.NET.HINT CH.NET.HINT NSMAIL.NET.HINT))
-                                                             (* ; "Edited 11-Mar-99 17:46 by rmk:")
-                                                             (* ; 
-                                                           "Edited  7-Mar-99 01:56 by kaplan")
-                                                             (* ; "Edited 30-Jan-92 16:26 by bbb")
-
-    (* ;; "This is what gets called when PARC-INIT is loaded.")
-
-    (IF (EQ 'MAIKO (MACHINETYPE))
-        THEN (SETQ INIT-NOGREET-FLAG (UNIX-GETENV "NOGREET")))
-    (LOGIN NIL 'QUIET)
-    (BKSYSBUF " ")
-    (AND (GETD 'MEDLEYVERSION)
-         (SELECTQ (MEDLEYVERSION)
-             (|2.0|                                          (* ; 
-       "Make sure that the compile extensions are set right, in case they reverted to LCOM, DFASL.")
-                    (SETQ COMPILE.EXT 'MCOM)
-                    (SETQ FASL.EXT 'MFASL)
-                    (SETQ *COMPILED-EXTENSIONS* '(MCOM MFASL)))
-             NIL))
-
-    (* ;; "do the real work")
-
-    (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT))
-           (FindSite)
-           (SETQ YP:*YP-DOMAIN* (IF (EQ \INIT.Location 'ADOC)
-                                    THEN "ADOC"
-                                  ELSE "PARC"))
-
-           (* ;; "1st floor = 132 204#")
-
-           (* ;; "2nd floor = 89 131#")
-
-           (* ;; "3rd floor = 98  142#")
-
-           (* ;; "Bldg 34 = 106 152#")
-
-           (* ;; "The clearinghouses in Building 35 are on net 132 (two of them), 89 and 98")
-
-           (* ;; "In Building 34 on net 152 and net 146 in building 32")
-
-(* ;;; " hmmm this is strange.. I don't see net 146... I took 146 out")
-
-           (SAVESET 'AUTHENTICATION.NET.HINT (SAVESET 'CH.NET.HINT
-                                                    (SELECTQ \INIT.Location
-                                                        (ENVOS-MTNVIEW (LIST 138))
-                                                        (IRL-HANOVER (LIST 132 89 98 152))
-                                                        (BLDG34-10MB (LIST 106 132 89 98))
-                                                        (BLDG35-1STFLOOR 
-                                                             (LIST 132 89 98 106))
-                                                        (BLDG35-2NDFLOOR 
-                                                             (LIST 89 132 98 106))
-                                                        (BLDG35-3RDFLOOR 
-                                                             (LIST 98 132 89 106))
-                                                        (ADOC (LIST 132 89 98 106))
-                                                        (LIST 132 89 98 106))
-                                                    T)
-                  T)
-
-           (* ;; " there are mail servers in Building 35 are on nets 89, 98 and 132")
-
-           (SAVESET 'NSMAIL.NET.HINT (SELECTQ \INIT.Location
-                                         ((IRL-HANOVER BLDG34-10MB) 
-                                              (LIST 89))
-                                         AUTHENTICATION.NET.HINT)
-                  T)
-           (FindInitHost)
-           (ParcInit)
-           (CL:WHEN INIT-NOGREET-FLAG
-               (SAVESET 'USERGREETFILES NIL T))
-           (CL:WHEN LOCALPATCHDIRECTORY
-               (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))])

(FindSite
-  [LAMBDA NIL                                            (* ; "Edited 14-Oct-97 18:38 by rmk:")
-                                                           (* ; "Edited  8-Dec-89 19:46 by Burwell")
-    (DECLARE (GLOBALVARS \INIT.Location \MY.NSADDRESS \LOCALPUPNETHOST))
-
-(* ;;; "Determine location, for use by other init we have to handle nets 6 and 64 specially since they cover 2 floors.  We also have to use etherhostnumbers rather than names, since the name service doesn't appear to work reliably on Dorados (nhb ' 5-Dec-85 11:36:13') Still seeing wrong location occasionally, keep the etherhostnumber for later diagnosis.  (nhb '13-Jan-86 20:23:47') problem seems to be that system returns hostnumber with 0 net number, we'll dismiss until it's greater than 255 (nhb '16-Jan-86 10:57:46') Added net 273## for Sunnyvale (nhb ' 9-Feb-88 15:54:17') Edited to reflect move of XAIS to Envos in Mtn.  View, and IRL to the Garage (bbb 1-sep-88)")
-
-(* ;;; "")
-
-(* ;;; "27-Mar-89 bbb added home dialin lines")
-
-(* ;;; "13-Sep-89 bvm changed to look at XNS net instead of Pup")
-
-    (SAVESET '\INIT.Location
-           (SELECTQ (CL:WHEN (STREQUAL "1" (UNIX-GETENV "LDELISPXNS"))
-                        (FOR Delay IN '(20 55 148 403 1096)
-                           DO (IF (AND \MY.NSADDRESS (> (SETQ $$VAL (\GETBASEFIXP 
-                                                                                   \MY.NSADDRESS 0))
-                                                                0))
-                                      THEN               (* ; "Find my XNS net number")
-                                            (RETURN $$VAL))
-                                 (DISMISS Delay) FINALLY (PRINTOUT T 
-                                                "* Warning: Init could not determine your net number"
-                                                                    T 
-                                                   "           assuming location is Bldg35-2nd floor"
-                                                                    T)
-                                                       (RETURN 6)))
-               (98 'BLDG35-3RDFLOOR)
-               (89 'BLDG35-2NDFLOOR)
-               (3 'PARC-NET3)
-               (17778 'ADOC)
-               ((52 6 132) 
-                    'BLDG35-1STFLOOR)
-               (106 'BLDG34-10MB)
-               ((7 138) 
-                    'ENVOS-MTNVIEW)
-               ((146 21) 
-                    'IRL-HANOVER)
-               ((159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175) 
-                    'HOME-DIALIN)
-               (* ; "Home DIAL-IN 237Q through 257Q")
-               (OR (MKATOM (UNIX-GETENV "LDESITE"))
-                   'BLDG35-2NDFLOOR])

(FindInitHost
-  [LAMBDA NIL
-    (DECLARE (GLOBALVARS \INIT.HostName \INIT.AlternateHostNames \INIT.Location))
-                                                             (* ; "Edited 27-Oct-93 14:56 by rmk:")
-
-(* ;;; "Lyric PARC people who have NS id's will have all their directories set to IE:PARC:Xerox")
-
-(* ;;; "")
-
-(* ;;; "July 28, 1989")
-
-(* ;;; "Medley is on Phylum, ie and Erinyes.  PARC people with NS ids will randomly get assigned to either Pooh or ie:parc:xerox.  IRL people will point to ie:parc:xerox")
-
-(* ;;; "We need to set the default domain and organization before we do a clearinghouse lookup")
-
-(* ;;; "")
-
-(* ;;; "October 6, 1989")
-
-(* ;;; 
-" PARC people will have their directories set only to pooh (not randomly on ie:parc:xerox or pooh)")
-
-(* ;;; "")
-
-(* ;;; "October 3, 1990")
-
-(* ;;; "Take out all references to Phylum")
-
-(* ;;; "")
-
-(* ;;; "January 30, 1992")
-
-(* ;;; " Replace references to {pooh/n}<pooh>lisp> with {dsk}/import/lisp")
-
-(* ;;; "")
-
-    (SAVESET 'CH.DEFAULT.DOMAIN "PARC" T)
-    (SAVESET 'CH.DEFAULT.ORGANIZATION "Xerox" T)
-    (SAVESET 'YP:*YP-DOMAIN* (IF (EQ \INIT.Location 'ADOC)
-                                 THEN "ADOC"
-                               ELSE "PARC")
-           T)
-    (LET (HasNSID? MsgWindowMenu MsgWindow)
-         (SELECTQ (MKATOM (U-CASE (MKSTRING MAKESYSNAME)))
-             (MEDLEY2.0 [PROGN (SELECTQ \INIT.Location
-                                   ((IRL-HANOVER) 
-                                                  (* ;; "IRL and home dial-in can't talk tcp/ip ")
-
-                                        (SAVESET '\INIT.HostName "IE:PARC:XEROX")
-                                        (SAVESET '\INIT.AlternateHostNames NIL))
-                                   (PROGN (SAVESET '\INIT.HostName "{dsk}<import>medley2.0>")
-                                          (SAVESET '\INIT.AlternateHostNames '("IE:PARC:Xerox"])
-             (MEDLEY [PROGN (SELECTQ \INIT.Location
-                                ((IRL-HANOVER) 
-                                               (* ;; "IRL and home dial-in can't talk tcp/ip ")
-
-                                     (SAVESET '\INIT.HostName "IE:PARC:XEROX")
-                                     (SAVESET '\INIT.AlternateHostNames '("Erinyes")))
-                                (PROGN (SAVESET '\INIT.HostName "{dsk}<import>")
-                                       (SAVESET '\INIT.AlternateHostNames '("IE:PARC:Xerox"])
-             (PROGN (SAVESET '\INIT.HostName "{dsk}<import>")
-                    (SAVESET '\INIT.AlternateHostNames '("IE:PARC:Xerox"])

(ParcInit
  [LAMBDA NIL                                                (* ; 
                                                           "Edited  4-Jan-2002 17:45 by kaplan")
                                                             (* ; 
                                                           "Edited  4-Jan-2002 17:45 by kaplan")
                                                             (* ; 
                                                           "Edited  3-Mar-2002 22:47 by rmk:")
                                                             (* "N.H.Briggs" " 2-Nov-87 12:39")
                                                             (* bbb "29-Oct-87 17:17")
    (DECLARE (GLOBALVARS \INIT.Location \INIT.HostName \INIT.AlternateHostNames MAKESYSNAME 
                        POSTGREETFORMS DEFAULTREGISTRY CH.DEFAULT.ORGANIZATION CH.DEFAULT.DOMAIN 
                        YP:*YP-DOMAIN* AUTHENTICATION.NET.HINT CH.NET.HINT PRINTSERVICE 
                        DEFAULTPRINTINGHOST DEFAULTFAXHOST FAXADDRESSES NETWORKLOGINFO LISPSUPPORT 
                        LAFITESUPPORT TEDITSUPPORT NETWORKOSTYPES LAFITESPECIALFORMS LAFITEFORMSMENU
                        LAFITEFORMDIRECTORIES LAFITEMODEDEFAULT PHONELISTFILES BackgroundMenu 
                        BackgroundMenuCommands USERGREETFILES COPYRIGHTFLG COPYRIGHTOWNERS 
                        DEFAULTCOPYRIGHTOWNER COPYRIGHTRESERVED SYSOUTFETCHDATE \CURRENTDISPLAYLINE 
                        IMAGESTREAMTYPES RECLAIMWAIT LOCALPATCHDIRECTORY CHAT.HOSTINFO EMPRESS#SIDES
                        \INIT.MachineType NFS:*USE-VOLUME-MAP*)
           (SPECVARS LDFLG))
    (PROG (LispusersUpdateHostName FontHostName ReleaseName)
          (IF (NOT (BOUNDP 'SYSOUTFETCHDATE))
              THEN (SETQ SYSOUTFETCHDATE (DATE)))
          [SETQ ReleaseName (MKATOM (U-CASE (MKSTRING MAKESYSNAME]

(* ;;; "Prevent a pagehold from happening")

          (SETQ \CURRENTDISPLAYLINE -10000)

(* ;;; "Do not put any patch-type code before this point.  This code will get executed once before the init file realizes that it needs to be updated.  Once it updates the init file it will execute the code again up to this point.")

          (SETQ \INIT.MachineType (MACHINETYPE))
          (ADDTOVAR GREETDATES (" 8-MAR" . "It's International Women's Day")
                                   ("18-MAY" . "It's Victoria Day")
                                   (" 5-NOV" . "<boom> it's Guy Fawkes day")
                                   (" 1-JUL" . "It's Canada Day")
                                   ("12-OCT" . "It's Canada's Thanksgiving Day"))
          (SAVESET 'USERGREETFILES (LET [[NFSFiles '(({dsk}<tilde> USER >LISP>INIT. COM)
                                                     ({dsk}<tilde> USER >LISP>INIT)
                                                     ({dsk}<tilde> USER >INIT. COM)
                                                     ({dsk}<tilde> USER >INIT.LISP]
                                         (LocalFiles '(({DSK}INIT- USER %. COM)
                                                       ({DSK}INIT- USER]
                                        (APPEND NFSFiles LocalFiles))
                 T)

     (* ;; "things to do with the copyright notices in files")

          (SAVESET 'COPYRIGHTFLG 'DEFAULT T)
          (SAVESET 'COPYRIGHTOWNERS '((PARC "Palo Alto Research Center Incorporated")
                                      (XEROX "Xerox Corporation")
                                      (VENUE "Venue Corporation"))
                 T)
          (COND
             ((FMEMB \INIT.Location '(ENVOS-MTNVIEW))
              (SAVESET 'DEFAULTCOPYRIGHTOWNER 'VENUE T))
             (T (SAVESET 'DEFAULTCOPYRIGHTOWNER 'PARC T)))
          (SAVESET 'COPYRIGHTRESERVED T T)

     (* ;; "the interpress printers at PARC are all running print services 9.0 or higher now.")

          (SAVESET 'PRINTSERVICE 10.0 T)

     (* ;; "Setup docuprint printers at PARC")

          (SELECTQ \INIT.Location
              ((BLDG35-3RDFLOOR BLDG35-1STFLOOR BLDG35-2NDFLOOR PARC-NET3) 
                   (SETQ EMPRESS#SIDES 2)
                   (FOR P IN '(|Waterman:PARC:xerox| |Mont Blanc:PARC:xerox| 
                                             |Perfector:PARC:Xerox| |Ansel:PARC:xerox| 
                                             |Kanji:PARC:xerox| |Squeeze-Box:PARC:xerox| 
                                             |Papaya:Parc:Xerox|) DO (PUT P 'PRINTERTYPE
                                                                              'DOCUPRINT)))
              NIL)

     (* ;; "Select an appropriate set of printers based on the location.")

          (SAVESET 'DEFAULTPRINTINGHOST
                 (COPY (SELECTQ \INIT.Location
                           (BLDG35-1STFLOOR 
                                '(|Mont Blanc:PARC:xerox| londondailymail |Marker:PARC:Xerox|))
                           (BLDG35-2NDFLOOR 
                                (APPEND '(comicnews)
                                       [FOR X
                                          IN '(|Waterman:PARC:xerox| |Mont Blanc:PARC:xerox| 
                                                         |Perfector:PARC:Xerox| |Ansel:PARC:xerox| 
                                                         |Kanji:PARC:xerox| |Squeeze-Box:PARC:xerox|
                                                         |Papaya:Parc:Xerox|)
                                          JOIN `((DOCUPRINT ,X INTERPRESS)
                                                     (DOCUPRINT ,X POSTSCRIPT]
                                       (FOR X IN '(|Marker:PARC:Xerox|) COLLECT X)
                                       '(londondailymail)))
                           (BLDG35-3RDFLOOR 
                                '(|Papermate:Parc:Xerox|))
                           (BLDG34-10MB '(|Cross:parc:Xerox| |Kanji:PARC:Xerox|))
                           (PARC-NET3 '(|Scripto:PARC:Xerox| |Perfector:PARC:Xerox|))
                           NIL))
                 T)

     (* ;; "set things related to the Interpress to FAX service")

          (SAVESET 'DEFAULTFAXHOST "VPFax:Parc:XEROX" T)
          (ADDTOVAR FAXADDRESSES (NLTT/FAX 94154944374)
                                     (POD26/FAX 94154944380)
                                     (EUROPARC/FAX 901144223341510)
                                     (MICROLYTICS/FAX 97162483868))
          (SETQ LispusersUpdateHostName NIL)
          (SETQ FontHostName (SELECTQ ReleaseName
                                 ((MEDLEY2.0 MEDLEY2.1) 
                                      "{dsk}<import>")
                                 \INIT.HostName))
          (IF \INIT.HostName
              THEN (SetDirectories \INIT.HostName LispusersUpdateHostName NIL FontHostName 
                              NIL T))

     (* ;; "fix up the Unix login method to deal with brain damaged ParcVax")

          [AND (LISTP (GETTOPVAL 'NETWORKLOGINFO))
               (/RPLACD (ASSOC 'LOGIN (CDR (ASSOC 'UNIX NETWORKLOGINFO)))
                      '(WAIT LF WAIT USERNAME LF WAIT PASSWORD LF))
               (/RPLACD (ASSOC 'LOGIN (CDR (ASSOC 'NS NETWORKLOGINFO)))
                      '("Logon" CR USERNAME CR PASSWORD CR]

(* ;;; "use to have (ADDTOVAR LAFITESUPPORT ...) but that produced the wrong result for already initialized variables")

          (SELECTQ ReleaseName
              ((MEDLEY MEDLEY2.0 MEDLEY2.1) 
                   [SETQ LISPSUPPORT '((NS 
                                        "AISupport:MV:Envos, Burwell:PARC:Xerox, vanMelle:PARC:Xerox"
                                           ]
                   [SETQ LAFITESUPPORT '((NS "LafiteSupport:PARC:Xerox"]
                   (SETQ TEDITSUPPORT LISPSUPPORT))
              NIL)

     (* ;; "make sure we know about some of the local machine types")

          (ADDTOVAR NETWORKLOGINFO (INFOVAX (LOGIN "User" CR)))
          (ADDTOVAR NETWORKOSTYPES (XSVAX . VMS)
                                       (MADVAX . VMS)
                                       (INFOVAX%: . INFOVAX)
                                       (|INFOVAX:PARC:XEROX| . INFOVAX)
                                       (FLO . UNIX)
                                       (POOH . UNIX)
                                       (PIGLET . UNIX)
                                       (PALAIN . UNIX)
                                       (KANGA . UNIX)
                                       (ROO . UNIX)
                                       (ROO%: . UNIX)
                                       (|ROO:PARC:XEROX| . UNIX)
                                       (FREDDYK . UNIX))

     (* ;; "Set up the hint to Lafite for finding form files for the PARC archiving")

          (SELECTQ \INIT.Location
              ((BLDG35-1STFLOOR BLDG35-2NDFLOOR BLDG35-3RDFLOOR) 
                   (SETQ LAFITEFORMSMENU NIL))
              ((IRL-HANOVER) 
                   (SETQ LAFITEFORMSMENU NIL))
              NIL)
          (SETQ LAFITEMODEDEFAULT 'NS)

     (* ;; "pointer to the PARC phone list file")

          (ADDTOVAR PHONELISTFILES {dsk}<import>doc>parcphonelist.txt 
                                             {dsk}<import>doc>ssutelephonelist.txt)

     (* ;; "Set the default IDLE options for PARC, a friendly place")

          (IDLE.SET.OPTION 'FORGET NIL)
          (/PUTPROP 'NSMAINTAIN 'FILEDEF 'NSMAINTAIN)
          (IF [AND (NOT (ASSOC 'Set% Directories BackgroundMenuCommands))
                       (MEMB ReleaseName '(MEDLEY MEDLEY2.0 MEDLEY2.1]
              THEN (/NCONC1 BackgroundMenuCommands
                              (LIST 'Set% Directories '(SetDirectories)
                                    "Set search path and font directories to default"
                                    (SELECTQ ReleaseName
                                        ((MEDLEY MEDLEY2.0 MEDLEY2.1) 
                                             '(SUBITEMS (NFS '(SetDirectories "{dsk}<import>" NIL
                                                                     NIL NIL NIL T)
                                                             
                                                    "Set search patch and font directories to Import"
                                                             )))
                                        NIL)))
                    (SETQ BackgroundMenu NIL))
          [COND
             ((FMEMB \INIT.Location '(ENVOS-MTNVIEW))
              (IF (MEMB ReleaseName '(MEDLEY MEDLEY2.0 MEDLEY2.1))
                  THEN (SAVESET 'XCL:*SHORT-SITE-NAME* 'Venue T)
                        (SAVESET 'XCL:*LONG-SITE-NAME* "Venue Corporation, San Carlos" T)))
             (T (IF (MEMB ReleaseName '(MEDLEY MEDLEY2.0 MEDLEY2.1))
                    THEN (SAVESET 'XCL:*SHORT-SITE-NAME* "PARC" T)
                          (SAVESET 'XCL:*LONG-SITE-NAME* "Xerox Palo Alto Research Center" T]

(* ;;; "We are decommissioning the volume map so tell Lisp not to use it")

          (SAVESET 'NFS:*USE-VOLUME-MAP* NIL)
          (FOR VAR
             IN '(AUTHENTICATION.NET.HINT BackgroundMenu BackgroundMenuCommands CH.DEFAULT.DOMAIN
                            YP:*YP-DOMAIN* CH.DEFAULT.ORGANIZATION CH.NET.HINT NSMAIL.NET.HINT 
                            COPYRIGHTFLG COPYRIGHTOWNERS COPYRIGHTRESERVED DEFAULTCOPYRIGHTOWNER 
                            DEFAULTFAXHOST DEFAULTPRINTINGHOST DEFAULTREGISTRY FAXADDRESSES 
                            GREETDATES LAFITEFORMDIRECTORIES LAFITEFORMSMENU LAFITESPECIALFORMS 
                            LAFITESUPPORT LISPSUPPORT NETWORKLOGINFO NETWORKOSTYPES PHONELISTFILES 
                            PRINTSERVICE TEDITSUPPORT USERGREETFILES LOCALPATCHDIRECTORY 
                            CHAT.HOSTINFO EMPRESS#SIDES NFS:*USE-VOLUME-MAP*)
             DO (UNMARKASCHANGED VAR 'VARS])

(SetDirectories
-  [LAMBDA (ReleaseHostName LispusersUpdatesHostName LibraryUpdatesHostName FontHostName ReleaseName 
-                 Reset)                                  (* ; "Edited 11-Nov-98 21:57 by rmk:")
-                                                             (* ; 
-                                                           "Edited 20-Feb-98 12:00 by kaplan")
-                                                             (* ; 
-                                                           "Edited 12-Feb-93 08:35 by kaplan")
-                                                             (* "N.H.Briggs" " 2-Nov-87 12:14")
-                                                             (* bbb "29-Oct-87 17:15")
-                                                             (* edited%: "11-Jun-87 12:32")
-    (DECLARE (GLOBALVARS \INIT.Location \INIT.CurrentReleaseName \INIT.PendingReleaseName 
-                        DIRECTORIES LISPUSERSDIRECTORIES MAKESYSNAME IRM.HOST&DIR 
-                        LOOPSUSERSDIRECTORIES FONTDIRECTORIES DISPLAYFONTDIRECTORIES 
-                        DISPLAYFONTEXTENSIONS INTERPRESSFONTDIRECTORIES WHEREIS.HASH 
-                        XCL::*WHERE-IS-CASH-FILES* LOCALPATCHDIRECTORY))
-    (PROG (NewLispUsersDirectories NewDirectories (Medley1.1VersionNumber 39424))
-
-     (* ;; "determine the release name, we take the hint from the system when it's present.")
-
-          (SETQ ReleaseName (L-CASE (OR ReleaseName MAKESYSNAME)
-                                   T))
-          (SETQ ReleaseHostName (L-CASE ReleaseHostName))
-          (SETQ LispusersUpdatesHostName (L-CASE (OR LispusersUpdatesHostName ReleaseHostName)))
-          (SETQ LibraryUpdatesHostName (L-CASE (OR LibraryUpdatesHostName ReleaseHostName)))
-          (SETQ FontHostName (L-CASE (OR FontHostName ReleaseHostName)))
-
-     (* ;; "set up the pointer to the Interlisp reference manual for use by HELPSYS and DINFO. This depends on the release name.")
-
-          (SAVESET 'IRM.HOST&DIR (SELECTQ ReleaseName
-                                     ((Medley Medley2.0 Medley2.1 Medley3.5) 
-                                          (CONCAT (HostPrefix ReleaseHostName)
-                                                 "Lisp>Lyric>LispUsers>IRM>"))
-                                     NIL)
-                 T)
-
-     (* ;; 
-   "setup pointer to whereis hash files, these differ by version and no pattern has emerged yet")
-
-          (SAVESET 'WHEREIS.HASH (SELECTQ ReleaseName
-                                     (Medley NIL)
-                                     (Medley2.0 NIL)
-                                     (Medley2.1 NIL)
-                                     (Medley3.5 NIL)
-                                     NIL)
-                 T)
-
-     (* ;; "This is really messy, the general intent is as follows: if the user is running the current release he wants release>library>new, release>library, lispusers, release>lispusers. If running a LispCore or forked LispCore release, put those directories first, then take the pending release <the one that LispCore is newer than...> If running neither of the above, (could be older or newer than current) try release>library>new, release>library>, release>lispusers, lispusers. This all relies on the theory that <lispusers> has only the new packages for the current release. Currently, sources are only maintained on Eris, so the release>sources is always pointed there. This may change sometime. ")
-
-     (* ;; "")
-
-     (* ;; "8603 Things seemed to have settled down, we have the <lispusers>releasename> directories created and the procedures worked out. It is now not necessary to know if the user is running the %"current%" release in order to get the directories correct.")
-
-     (* ;; "added Lispcore>Internal>Library per request from Masinter")
-
-     (* ;; "")
-
-          [SELECTQ ReleaseName
-              (Medley2.0 (PUSH NewLispUsersDirectories "{dsk}/project/medley2.0/library/" 
-                                "{dsk}/project/medley2.0/lispusers/"))
-              (Medley2.1 (PUSH NewLispUsersDirectories "{dsk}/project/medley2.1/library/" 
-                                "{dsk}/project/medley2.1/lispusers/" 
-                                "{dsk}/project/medley2.1/sources/"))
-              (Medley3.5 (PUSH NewLispUsersDirectories "{dsk}/project/medley3.5/library/" 
-                                "{dsk}/project/medley3.5/lispusers/" 
-                                "{dsk}/project/medley3.5/sources/"))
-              (PROGN (PUSH NewLispUsersDirectories (CONCAT (HostPrefix ReleaseHostName)
-                                                              "Lisp>" ReleaseName ">Library>")
-                            (CONCAT (HostPrefix ReleaseHostName)
-                                   "Lisp>" ReleaseName ">Internal>Library>")
-                            (CONCAT (HostPrefix LispusersUpdatesHostName)
-                                   "LispUsers>" ReleaseName ">")
-                            (CONCAT (HostPrefix ReleaseHostName)
-                                   "Lisp>" ReleaseName ">LispUsers>"))
-
-                     (* ;; "Changed to <LispLibrary> from <Lisp>Library>New>")
-
-                     (PUSH NewLispUsersDirectories (CONCAT (HostPrefix LibraryUpdatesHostName
-                                                                      )
-                                                              "LispLibrary>" ReleaseName ">"]
-          [SETQ NewDirectories (APPEND NewDirectories (LDIFFERENCE NewLispUsersDirectories 
-                                                             NewDirectories)
-                                      (LIST (CONCAT (HostPrefix ReleaseHostName)
-                                                   "Lisp>" ReleaseName ">Sources>"]
-          (SAVESET 'LISPUSERSDIRECTORIES (APPEND NewLispUsersDirectories (AND (NOT Reset)
-                                                                              (LDIFFERENCE 
-                                                                                 LISPUSERSDIRECTORIES
-                                                                                     
-                                                                              NewLispUsersDirectories
-                                                                                     )))
-                 T)
-          (SAVESET 'LOCALPATCHDIRECTORY (CONCAT (SELECTQ ReleaseName
-                                                    (Medley (CONCAT (HostPrefix ReleaseHostName)
-                                                                   "Lisp>" ReleaseName
-                                                                   (IF (EQ (LISPVERSION)
-                                                                               Medley1.1VersionNumber
-                                                                               )
-                                                                       THEN ""
-                                                                     ELSE "1.15")))
-                                                    (Medley2.0 "{dsk}<import>medley2.0")
-                                                    (Medley2.1 "{dsk}<import>medley2.1")
-                                                    (Medley3.5 "{dsk}<import>medley3.5")
-                                                    (HELP))
-                                               ">Patches>")
-                 T)
-          (SAVESET 'DIRECTORIES (APPEND NewDirectories (AND (NOT Reset)
-                                                            (LDIFFERENCE DIRECTORIES NewDirectories))
-                                       )
-                 T)
-          (IF (MEMB ReleaseName '(Medley Medley2.0 Medley2.1 Medley3.5))
-              THEN (SAVESET 'XCL::*WHERE-IS-CASH-FILES* (MKLIST (FINDFILE 'SYSTEM.HASH T 
-                                                                           DIRECTORIES))
-                              T))
-          (SAVESET 'LOOPSUSERSDIRECTORIES (LIST (PACKFILENAME 'HOST "{NB:PARC:Xerox}" 'BODY
-                                                       (CONCAT "<Loops>" ReleaseName ">Users>")))
-                 T)
-
-     (* ;; "")
-
-     (* ;; "the font directories depend on the release. We also check here whether the user is in bldg 35, in which case we add the Alto fonts. The press font widths must be on a random access device, and are sometimes kept on the local disk. If they aren't randaccessp then we put them on {dsk} if there's room, {core} if not.")
-
-     (* ;; "")
-
-          (SELECTQ ReleaseName
-              ((Medley Medley2.0 Medley2.1 Medley3.5) 
-                   (PROGN (SAVESET 'DISPLAYFONTDIRECTORIES (LIST (CONCAT (HostPrefix FontHostName
-                                                                                )
-                                                                        "Lisp>DisplayFonts>")
-                                                                 (CONCAT (HostPrefix FontHostName
-                                                                                )
-                                                                        "AltoFonts>"))
-                                 T)
-                          (SAVESET 'DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE)
-                                 T)
-                          (SAVESET 'INTERPRESSFONTDIRECTORIES (LIST (CONCAT (HostPrefix 
-                                                                                   FontHostName)
-                                                                           "Lisp>IPFonts>"))
-                                 T)))
-              (PROGN (SAVESET 'DISPLAYFONTDIRECTORIES (UNION (LIST (CONCAT (HostPrefix 
-                                                                                  FontHostName)
-                                                                          "Lisp>Fonts>"))
-                                                             (LIST (CONCAT (HostPrefix 
-                                                                                  FontHostName)
-                                                                          "AltoFonts>")
-                                                                   (CONCAT (HostPrefix 
-                                                                                  FontHostName)
-                                                                          "AltoFonts>Original>")))
-                            T)
-                     (SAVESET 'DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE)
-                            T)
-                     (SAVESET 'INTERPRESSFONTDIRECTORIES (LIST (CONCAT (HostPrefix FontHostName)
-                                                                      "Lisp>Fonts>"))
-                            T)))
-          (FOR var IN '(DIRECTORIES LISPUSERSDIRECTORIES IRM.HOST&DIR LOOPSUSERSDIRECTORIES 
-                                      FONTDIRECTORIES DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS 
-                                      INTERPRESSFONTDIRECTORIES WHEREIS.HASH LOCALPATCHDIRECTORY 
-                                      XCL::*WHERE-IS-CASH-FILES*) DO (UNMARKASCHANGED
-                                                                          var
-                                                                          'VARS])

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

(INTERLISPMODE
-  [LAMBDA (OLD?)                                         (* N.H.Briggs " 2-Feb-88 14:26")
-    (PROCESSPROP 'EXEC 'PROFILE (XCL:COPY-PROFILE (if OLD?
-                                                      then "OLD-INTERLISP-T"
-                                                    else "INTERLISP")))
-    (XCL:SET-DEFAULT-EXEC-TYPE (if OLD?
-                                   then "OLD-INTERLISP-T"
-                                 else "INTERLISP"))
-    (SETQ *DEFAULT-MAKEFILE-ENVIRONMENT* (LIST :READTABLE (if OLD?
-                                                              then "OLD-INTERLISP-FILE"
-                                                            else "INTERLISP")
-                                               :PACKAGE "INTERLISP"])

(FILE-SERVER-UP-P
-  [LAMBDA (FILE-SERVER-NAME)                           (* ; "Edited 12-Oct-89 22:24 by Burwell")
-    (PROG ([SERVER-TYPE (COND
-                           ((STRPOS ":" (L-CASE FILE-SERVER-NAME))
-                            'XNS)
-                           ((STRPOS "/n" (L-CASE FILE-SERVER-NAME))
-                            'NFS)
-                           (T 'IFS]
-           (PROCESS-RESULT (CONS))
-           (PROCESS-HANDLE))
-          (if (NULL FILE-SERVER-NAME)
-              then (RETURN NIL))
-          (SETQ PROCESS-HANDLE (ADD.PROCESS `(COND
-                                                ((DIRECTORYNAMEP ,(SELECTQ SERVER-TYPE
-                                                                      (XNS "DESKTOPS")
-                                                                      (IFS "SYSTEM")
-                                                                      (NFS (CONCAT "{" 
-                                                                                  FILE-SERVER-NAME 
-                                                                                  "}"))
-                                                                      NIL)
-                                                        ,FILE-SERVER-NAME)
-                                                 (RPLACA ,(KWOTE PROCESS-RESULT)
-                                                        T)))
-                                      'NAME "file-server-up-p"))
-          (DISMISS 500)
-          (forDuration 60 timerUnits 'SECONDS until (CAR PROCESS-RESULT)
-             do (DISMISS 500) finally (DEL.PROCESS PROCESS-HANDLE))
-          (RETURN (CAR PROCESS-RESULT])

(HostPrefix
-  [LAMBDA (HostName)                                     (* ; "Edited 30-Jan-92 16:25 by bbb")
-    (if (STRPOS "/n" (L-CASE HostName))
-        then (CONCAT "{" HostName "}<" (SUBSTRING HostName 1 (DIFFERENCE (NCHARS HostName)
-                                                                        2))
-                        ">")
-      elseif (OR (STRPOS "nfs}" (L-CASE HostName))
-                     (STRPOS "dsk}" (L-CASE HostName)))
-        then (CONCAT HostName)
-      else (CONCAT "{" HostName "}<"])
)
(DEFINEQ

(SUNOSNAME
-  [LAMBDA NIL                                            (* ; "Edited  7-Dec-94 13:44 by rmk:")
-
-    (* ;; "Returns name of curren SunOS version")
-
-    (SELCHARQ (CHCON1 (UNIX-GETENV "OSVERSION"))
-         (4 'SUNOS)
-         (5 'SOLARIS)
-         (HELP "UNKNOWN SUN OSVERSION" (UNIX-GETENV "OSVERFSION"])
)

(DEFMACRO WITHOUT.PAGEHOLD (WINDOW &BODY FORMS)
   `(RESETLST
        (LET* ((TTYWINDOW ,WINDOW)
               (ORIGINAL.PAGEFULLFN (WINDOWPROP TTYWINDOW 'PAGEFULLFN))
               (NEW.PAGEFULLFN (FUNCTION NILL)))
              (RESETSAVE (WINDOWPROP TTYWINDOW 'PAGEFULLFN NEW.PAGEFULLFN)
                     (LIST [FUNCTION (LAMBDA (TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)
                                       (COND
                                          ((EQ (WINDOWPROP TTYWINDOW 'PAGEFULLFN)
                                               NEW.PAGEFULLFN)
                                           (WINDOWPROP TTYWINDOW 'PAGEFULLFN ORIGINAL.PAGEFULLFN]
                           TTYWINDOW NEW.PAGEFULLFN ORIGINAL.PAGEFULLFN)))
        ,@FORMS))



(* ;; "Initially set LOCALPATCHDIRECTORY to NIL to avoid loading patches if no servers are up.")


(RPAQQ LOCALPATCHDIRECTORY NIL)

(RPAQQ *USEOLDFONTDIRECTORIES* NIL)

(RPAQ? UNIXMAIL.DOMAIN.NAME "parc.com")

(RPAQ? INIT-NOGREET-FLAG NIL)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(PARC-INIT)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(PUTPROPS PARC-INIT COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 
1996 1997 1998 1999 2002))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1800 40555 (PARC-INIT 1810 . 5479) (FindSite 5481 . 8296) (FindInitHost 8298 . 10968) (
ParcInit 10970 . 22993) (SetDirectories 22995 . 34548) (LoadPatches 34550 . 36498) (
COLLECT-PATCH-FILES 36500 . 37477) (INTERLISPMODE 37479 . 38292) (FILE-SERVER-UP-P 38294 . 40000) (
HostPrefix 40002 . 40553)) (40556 40900 (SUNOSNAME 40566 . 40898)))))
STOP
\ No newline at end of file
diff --git a/obsolete/greetfiles/PARC-INIT.LCOM b/obsolete/greetfiles/PARC-INIT.LCOM
deleted file mode 100644
index 5dbae95a..00000000
Binary files a/obsolete/greetfiles/PARC-INIT.LCOM and /dev/null differ
diff --git a/obsolete/internal/ABC b/obsolete/internal/ABC
deleted file mode 100644
index 69ad77ab..00000000
--- a/obsolete/internal/ABC
+++ /dev/null
@@ -1,62 +0,0 @@
-(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
diff --git a/obsolete/internal/ABC.LCOM b/obsolete/internal/ABC.LCOM
deleted file mode 100644
index 8f8e8f0f..00000000
--- a/obsolete/internal/ABC.LCOM
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Feb-98 09:30:41" ("compiled on " 
{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>internal>library>ABC.;1) "31-Jan-98 19:10:48" bcompl'd in 
"Medley 31-Jan-98 ..." dated "31-Jan-98 19:12:50")
(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)
(PRETTYCOMPRINT ABCCOMS)
(RPAQQ ABCCOMS ((VARS (MSRECORDTRANFLG T) (DWIMIFYCOMPFLG) (MSMACROPROPS COMPILERMACROPROPS) (
CLEANUPOPTIONS (QUOTE (RC F))) (CROSSCOMPILING T) (ASKEDITHIST T) (RECOMPILEDEFAULT (QUOTE CHANGES)) (
CROSSCOMPILING (QUOTE ASK))) (FILES (SOURCE) FILESETS) (P (MOVD? (QUOTE APPLY*) (QUOTE SPREADAPPLY*)) 
(RESETVARS ((CROSSCOMPILING T)) (FILESLOAD EXPORTS.ALL) (AND (EQ (ASKUSER DWIMWAIT (QUOTE N) 
"Check imports? " NIL T) (QUOTE 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? (QUOTE APPLY*) (QUOTE SPREADAPPLY*))
(RESETVARS ((CROSSCOMPILING T)) (FILESLOAD EXPORTS.ALL) (AND (EQ (ASKUSER DWIMWAIT (QUOTE N) 
"Check imports? " NIL T) (QUOTE 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))
NIL
\ No newline at end of file
diff --git a/obsolete/internal/library/DICOLOR b/obsolete/internal/library/DICOLOR
deleted file mode 100644
index a96ec3f0..00000000
--- a/obsolete/internal/library/DICOLOR
+++ /dev/null
@@ -1,466 +0,0 @@
-(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
diff --git a/obsolete/internal/library/DICOLOR.LCOM b/obsolete/internal/library/DICOLOR.LCOM
deleted file mode 100644
index 21bd1038..00000000
Binary files a/obsolete/internal/library/DICOLOR.LCOM and /dev/null differ
diff --git a/obsolete/library/CHARS b/obsolete/library/CHARS
deleted file mode 100644
index 6a37c907..00000000
--- a/obsolete/library/CHARS
+++ /dev/null
@@ -1,17 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED " 1-Aug-2020 21:16:25" {DSK}<Users>kaplan>Local>medley3.5>lispcore>library>CHARS.;1 517    
-)
-
-
-(PRETTYCOMPRINT CHARSCOMS)
-
-(RPAQQ CHARSCOMS ((ALISTS (CHARACTERNAMES RSQ LSQ LDQ RDQ NEQ))))
-
-(ADDTOVAR CHARACTERNAMES (RSQ "0,271")
-                             (LSQ "0,251")
-                             (LDQ "0,252")
-                             (RDQ "0,272")
-                             (NEQ "041,142"))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
diff --git a/obsolete/library/FX-80DRIVER b/obsolete/library/FX-80DRIVER
deleted file mode 100644
index 39183cc9..00000000
--- a/obsolete/library/FX-80DRIVER
+++ /dev/null
@@ -1,4346 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
-(FILECREATED "15-Jul-2025 22:01:24" 
-{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>FX-80DRIVER.;2 231869 
-
-      :EDIT-BY rmk
-
-      :CHANGES-TO (VARS FX-80.HIGH-QUALITY-DRIVERCOMS)
-                  (FNS \HQFX80.CHANGEFONT)
-
-      :PREVIOUS-DATE "11-Jun-90 15:57:59" 
-{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>FX-80DRIVER.;1)
-
-
-(PRETTYCOMPRINT FX-80DRIVERCOMS)
-
-(RPAQQ FX-80DRIVERCOMS
-       (
-
-(* ;;; "FX-80 driver")
-
-        (COMS * FX-80.FAST-DRIVERCOMS                        (* ; "the fast driver"))
-        (COMS * FX-80.HIGH-QUALITY-DRIVERCOMS                (* ; "the  higher quality driver"))
-        (COMS * FX80-PRINTCOMS                               (* ; "FXPrinter emulation"))
-        (COMS                                                (* ; "common routines")
-              (FUNCTIONS                                     (* ; "abort window stuff")
-                     WITH-ABORT-WINDOW \FX80.CREATE-SEND-ABORT-WINDOW)
-              (FUNCTIONS                                     (* ; "font profile hacking")
-                     \ADD-TO-FONTPROFILE \GET-FROM-FONTPROFILE))
-        
-
-(* ;;; "initialization")
-
-        [COMS (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\HQFX80.INIT)
-                                                 (\FASTFX80.INIT]
-        (PROP FILETYPE FX-80DRIVER)))
-
-
-
-(* ;;; "FX-80 driver")
-
-
-(RPAQQ FX-80.FAST-DRIVERCOMS
-       [
-        (* ;; "Fast driver")
-
-        
-        (* ;; "")
-
-        (STRUCTURES FASTFX80DATA)
-        (FNS \FASTFX80.INIT)
-        
-        (* ;; "Imagestream methods")
-
-        (COMS 
-              (* ;; "opening/closing imagestream")
-
-              (COMS (FNS OPENFASTFX80STREAM)
-                    (FUNCTIONS \FASTFX80.PREAMBLE \FASTFX80.RESET-PRINTER \FASTFX80.OUTPUT-SIGNATURE)
-                    )
-              (FNS \FASTFX80.CLOSE))
-        (COMS 
-              (* ;; "methods that hack fonts")
-
-              (FNS \FASTFX80.CHANGEFONT \FASTFX80.FONTCREATE \FASTFX80.CREATECHARSET)
-              (FUNCTIONS \FASTFX80.INIT-FONT-PROFILE))
-        (COMS 
-              (* ;; "methods for measuring")
-
-              (FNS \FASTFX80.STRINGWIDTH \FASTFX80.CHARWIDTH \FASTFX80.SUBCHARWIDTH)
-              (FUNCTIONS \FASTFX80.SPACEFACTOR))
-        (COMS 
-              (* ;; "methods that affect the current position/size of drawing surface")
-
-              (FNS \FASTFX80.CLIPPINGREGION \FASTFX80.MOVETO \FASTFX80.XPOSITION \FASTFX80.YPOSITION
-                   \FASTFX80.BACKUP.PAPER \FASTFX80.ADVANCE.PAPER \FASTFX80.NEWPAGE \FASTFX80.OUTCHAR
-                   \FASTFX80.NEWLINE \FASTFX80.LINEFEED \FASTFX80.DRAWLINE)
-              (FUNCTIONS \FASTFX80.STARTPAGE \FASTFX80.SMART-XPOSITION \FASTFX80.TOPMARGIN 
-                     \FASTFX80.BOTTOMMARGIN \FASTFX80.LEFTMARGIN \FASTFX80.RIGHTMARGIN 
-                     \FASTFX80.CUR-POS-VISIBLE? \FASTFX80.HORIZONTAL))
-        (COMS 
-              (* ;; "printer code")
-
-              (FUNCTIONS \FASTFX80.SEND MAKE-FASTFX80 FASTFX80FILEP \FASTFX80.CANNOT-PRINT-BITMAPS)
-              (FNS \FASTFX80.CONVERT-TEDIT))
-        (COMS 
-              (* ;; "Character transmission method")
-
-              (FNS \FASTFX80.BOUT))
-        
-        (* ;; "Miscellany")
-
-        (FUNCTIONS \FASTFX80.TRANSLATE-CHAR WITH-FASTFX80-DATA)
-        (CONSTANTS (\FASTFX80.DOTSPERINCH 72)
-               (\FASTFX80.LINESPERINCH 6)
-               (\FASTFX80.LINEHEIGHT 12)
-                                                             (* ; "in dots")
-               (\FASTFX80.FILE-SIGNATURE "FastFX-80/Xerox/1.0 "))
-        (INITVARS (FASTFX80-DEFAULT-DESTINATION "{TTY}")
-               (\FASTFX80.INCHES-PER-PAGE 11)
-               (\FASTFX80.INCHES-PER-LINE 8.5))
-        (COMS 
-              (* ;; "need to load these exports")
-
-              (DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
-                                                                ADISPLAY])
-
-
-
-(* ;; "Fast driver")
-
-
-
-
-(* ;; "")
-
-
-(CL:DEFSTRUCT FASTFX80DATA
-
-   (* ;; "the imagedata vector for a fastfx80 imagestream")
-
-   (VIRTUAL-XPOS 0)
-   (VIRTUAL-YPOS 0)
-   (REAL-XPOS 0)
-   (REAL-YPOS 0)
-   CLIPPINGREGION BACKINGSTREAM (LEFTMARGIN 72)
-   RIGHTMARGIN TOPMARGIN (BOTTOMMARGIN 0)
-   FONT PAPER-WIDTH PAPER-HEIGHT (SPACEFACTOR 1.0))
-(DEFINEQ
-
-(\FASTFX80.INIT
-  [LAMBDA NIL                                            (* ; "Edited 16-Dec-86 12:03 by hdj")
-
-    (DECLARE (GLOBALVARS DEFAULTPRINTINGHOST IMAGESTREAMTYPES PRINTERTYPES PRINTFILETYPES 
-                        \FASTFX80.IMAGEOPS \FASTFX80.FDEV))
-    (SETQ \FASTFX80.FDEV (create FDEV
-                                DEVICENAME _ (LIST 'FASTFX80 'PRINTER)
-                                CLOSEFILE _ (FUNCTION NILL)
-                                BOUT _ (FUNCTION \FASTFX80.BOUT)))
-    (SETQ \FASTFX80.IMAGEOPS (create IMAGEOPS
-                                    IMAGETYPE _ 'FASTFX80
-                                    IMFONT _ (FUNCTION \FASTFX80.CHANGEFONT)
-                                    IMLEFTMARGIN _ (FUNCTION \FASTFX80.LEFTMARGIN)
-                                    IMRIGHTMARGIN _ (FUNCTION \FASTFX80.RIGHTMARGIN)
-                                    IMTOPMARGIN _ (FUNCTION \FASTFX80.TOPMARGIN)
-                                    IMBOTTOMMARGIN _ (FUNCTION \FASTFX80.BOTTOMMARGIN)
-                                    IMLINEFEED _ (FUNCTION NILL)
-                                    IMTERPRI _ (FUNCTION \FASTFX80.NEWLINE)
-                                    IMXPOSITION _ (FUNCTION \FASTFX80.XPOSITION)
-                                    IMYPOSITION _ (FUNCTION \FASTFX80.YPOSITION)
-                                    IMCLOSEFN _ (FUNCTION \FASTFX80.CLOSE)
-                                    IMMOVETO _ (FUNCTION \FASTFX80.MOVETO)
-                                    IMDRAWCURVE _ (FUNCTION NILL)
-                                    IMFILLCIRCLE _ (FUNCTION NILL)
-                                    IMDRAWLINE _ (FUNCTION NILL)
-                                    IMDRAWELLIPSE _ (FUNCTION NILL)
-                                    IMDRAWCIRCLE _ (FUNCTION NILL)
-                                    IMBITBLT _ (FUNCTION NILL)
-                                    IMBLTSHADE _ (FUNCTION NILL)
-                                    IMNEWPAGE _ (FUNCTION \FASTFX80.NEWPAGE)
-                                    IMSCALE _ [FUNCTION (LAMBDA NIL 1]
-                                    IMSPACEFACTOR _ (FUNCTION NILL)
-                                    IMFONTCREATE _ 'FASTFX80
-                                    IMCOLOR _ (FUNCTION NILL)
-                                    IMBACKCOLOR _ (FUNCTION NILL)
-                                    IMOPERATION _ (FUNCTION NILL)
-                                    IMSTRINGWIDTH _ (FUNCTION \FASTFX80.STRINGWIDTH)
-                                    IMCHARWIDTH _ (FUNCTION \FASTFX80.CHARWIDTH)
-                                    IMCLIPPINGREGION _ (FUNCTION \FASTFX80.CLIPPINGREGION)
-                                    IMRESET _ (FUNCTION NILL)
-                                    IMDRAWPOLYGON _ (FUNCTION NILL)
-                                    IMFILLPOLYGON _ (FUNCTION NILL)
-                                    IMSCALEDBITBLT _ (FUNCTION NILL)))
-    [push IMAGESTREAMTYPES (COPYALL '(FASTFX80 (OPENSTREAM OPENFASTFX80STREAM)
-                                                (FONTCREATE \FASTFX80.FONTCREATE)
-                                                (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)
-                                                (CREATECHARSET \FASTFX80.CREATECHARSET]
-    [push PRINTERTYPES (COPYALL '((FASTFX80)
-                                      (CANPRINT (FASTFX80))
-                                      (STATUS TRUE)
-                                      (SEND \FASTFX80.SEND)
-                                      (BITMAPSCALE NIL)
-                                      (BITMAPFILE (\FASTFX80.CANNOT-PRINT-BITMAPS FILE BITMAP 
-                                                         SCALEFACTOR REGION ROTATION TITLE))
-                                      (PROPERTIES NILL]
-    [push PRINTFILETYPES (COPYALL '(FASTFX80 (TEST FASTFX80FILEP)
-                                              (EXTENSION (FASTFX80))
-                                              (CONVERSION (TEXT MAKE-FASTFX80 TEDIT 
-                                                                \FASTFX80.CONVERT-TEDIT]
-    (push DEFAULTPRINTINGHOST (LIST 'FASTFX80 'FASTFX80))
-    (PUTPROP 'FASTFX80 'PRINTERTYPE 'FASTFX80)
-    (\FASTFX80.INIT-FONT-PROFILE)
-    T])
-)
-
-
-
-(* ;; "Imagestream methods")
-
-
-
-
-(* ;; "opening/closing imagestream")
-
-(DEFINEQ
-
-(OPENFASTFX80STREAM
-  [LAMBDA (FILENAME OPTIONS)                             (* ; "Edited 20-Jan-88 11:22 by jds")
-          
-          (* ;; "open a fastfx80 imagestream")
-
-    (LET* [[BACKING (OPENSTREAM FILENAME 'OUTPUT NIL '((SEQUENTIAL T)
-                                                       (TYPE FASTFX80]
-           (PAPER-WIDTH (FIX (TIMES \FASTFX80.INCHES-PER-LINE \FASTFX80.DOTSPERINCH)))
-           (PAPER-HEIGHT (FIX (TIMES \FASTFX80.INCHES-PER-PAGE \FASTFX80.DOTSPERINCH)))
-           (FASTFX80STREAM (create STREAM
-                                  FULLFILENAME _ (FULLNAME BACKING)
-                                  DEVICE _ \FASTFX80.FDEV
-                                  ACCESS _ 'OUTPUT
-                                  OUTCHARFN _ (FUNCTION \FASTFX80.OUTCHAR)
-                                  IMAGEOPS _ \FASTFX80.IMAGEOPS
-                                  IMAGEDATA _ (MAKE-FASTFX80DATA :BACKINGSTREAM BACKING 
-                                                     :CLIPPINGREGION (CREATEREGION 0 0 PAPER-WIDTH 
-                                                                            PAPER-HEIGHT)
-                                                     :RIGHTMARGIN
-                                                     (- PAPER-WIDTH \FASTFX80.DOTSPERINCH)
-                                                     :TOPMARGIN
-                                                     (- PAPER-HEIGHT (TIMES 3 \FASTFX80.LINEHEIGHT))
-                                                     :BOTTOMMARGIN
-                                                     (TIMES 3 \FASTFX80.LINEHEIGHT)
-                                                     :PAPER-WIDTH PAPER-WIDTH :PAPER-HEIGHT 
-                                                     PAPER-HEIGHT]
-          (replace (STREAM USERVISIBLE) of BACKING with NIL)
-          (\FASTFX80.PREAMBLE FASTFX80STREAM)
-          FASTFX80STREAM])
-)
-
-(CL:DEFUN \FASTFX80.PREAMBLE (FASTFX80STREAM)
-
-   (* ;; "start a FASTFX80 master")
-
-(* ;;; "must change FASTFX80FILEP when this changes")
-
-   (DECLARE (GLOBALVARS \FASTFX80.INCHES-PER-PAGE))
-   (\FASTFX80.RESET-PRINTER FASTFX80STREAM \FASTFX80.INCHES-PER-PAGE)
-   (\FASTFX80.OUTPUT-SIGNATURE FASTFX80STREAM)
-   (\FASTFX80.CHANGEFONT FASTFX80STREAM (DEFAULTFONT 'FASTFX80))
-   (\FASTFX80.STARTPAGE FASTFX80STREAM))
-
-(CL:DEFUN \FASTFX80.RESET-PRINTER (FASTFX80STREAM INCHES-PER-PAGE)
-
-   (* ;; "send a reset sequence to the fx-80")
-
-   (IF (AND (<= 1 INCHES-PER-PAGE)
-            (<= INCHES-PER-PAGE 21))
-       THEN 
-            (* ;; "send a reset sequence to the fx-80...")
-
-            (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE ESC))
-            (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE @)) 
-
-            (* ;; "...and set the form length")
-
-            (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE ESC))
-            (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE C))
-            (\FASTFX80.BOUT FASTFX80STREAM (FIXR (TIMES INCHES-PER-PAGE \FASTFX80.LINESPERINCH)))
-     ELSE (ERROR "Illegal page length value" INCHES-PER-PAGE)))
-
-(CL:DEFUN \FASTFX80.OUTPUT-SIGNATURE (FASTFX80STREAM)
-
-   (* ;; "start the file with an identifying signature.  Ensure it is not printed by following it with an equal number of ASCII 127's.")
-
-   (* ;; "This will not work if SIGNATURE contains line-ending characters.")
-
-   (LET ((DEL-BYTE 127))
-        (FOR BYTE INSTRING \FASTFX80.FILE-SIGNATURE DO (\FASTFX80.BOUT FASTFX80STREAM BYTE))
-        (FOR BYTE INSTRING \FASTFX80.FILE-SIGNATURE DO (\FASTFX80.BOUT FASTFX80STREAM DEL-BYTE))))
-(DEFINEQ
-
-(\FASTFX80.CLOSE
-  [LAMBDA (FASTFX80STREAM)                               (* ; "Edited  2-Jun-87 19:11 by Snow")
-          
-          (* ;; "close a fast fx80 stream ")
-
-    (WITH-FASTFX80-DATA (DATA FASTFX80STREAM)
-           (\FASTFX80.OUTCHAR FASTFX80STREAM (CHARCODE CR))
-          
-          (* ;; 
-   "do a bout here because an outchar will cause a new-page which then adds 4 lines to the output.")
-
-           (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE FF))
-           (\CLOSEFILE (FASTFX80DATA-BACKINGSTREAM DATA))
-           (fetch (STREAM FULLFILENAME) of FASTFX80STREAM])
-)
-
-
-
-(* ;; "methods that hack fonts")
-
-(DEFINEQ
-
-(\FASTFX80.CHANGEFONT
-  [LAMBDA (STREAM FONT)                                  (* ; "Edited 14-Aug-87 14:40 by Snow")
-          
-          (* ;; "font-change method for the fast fx-80 device")
-
-    (WITH-FASTFX80-DATA (DATA STREAM)
-           (PROG1 (FASTFX80DATA-FONT DATA)
-                  (COND
-                     (FONT (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'FASTFX80))
-                           (COND
-                              ((NEQ FONT (FASTFX80DATA-FONT DATA))
-                               [LET [[ITALICP (FMEMB 'ITALIC (FONTPROP FONT 'FACE]
-                                     [BOLDP (FMEMB 'BOLD (FONTPROP FONT 'FACE]
-                                     (UNDERLINE-NESS 128)
-                                     (ITALIC-NESS 64)
-                                     (EXPANDED-NESS 32)
-                                     (DOUBLE-STRIKE-NESS 16)
-                                     (EMPHASIZED-NESS 8)
-                                     (COMPRESSED-NESS 4)
-                                     (ELITE-NESS 1)
-                                     (PICA-NESS 0)
-                                     (SIZE (FONTPROP FONT 'SIZE]
-          
-          (* ;; "Send master select code and inform printer of boldness, italicism, and new font size: pica for regular sized fonts, emphasized pica for large fonts.")
-
-                                    (\FASTFX80.BOUT STREAM (CHARCODE ESC))
-                                    (\FASTFX80.BOUT STREAM (CHARCODE !))
-                                    [\FASTFX80.BOUT STREAM (LOGOR (COND
-                                                                         (ITALICP ITALIC-NESS)
-                                                                         (T PICA-NESS))
-                                                                      (COND
-                                                                         (BOLDP EMPHASIZED-NESS)
-                                                                         (T PICA-NESS))
-                                                                      (COND
-                                                                         ((> SIZE 12)
-                                                                          EXPANDED-NESS)
-                                                                         ((<= SIZE 8)
-                                                                          COMPRESSED-NESS)
-                                                                         (T PICA-NESS]
-          
-          (* ;; "Set italicness, since FX-80 doesn't support the ITALIC bit in master reset.")
-
-                                    (\FASTFX80.BOUT STREAM (CHARCODE ESC))
-                                    (COND
-                                       (ITALICP              (* ; "turn it on")
-
-                                              (\FASTFX80.BOUT STREAM (CHARCODE 4)))
-                                       (T                    (* ; "turn it off")
-
-                                          (\FASTFX80.BOUT STREAM (CHARCODE 5]
-                               (CL:SETF (FASTFX80DATA-FONT DATA)
-                                      FONT])
-
-(\FASTFX80.FONTCREATE
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)     (* hdj "27-Oct-86 14:59")
-          
-          (* ;; " create and return a fontdescriptor for a fastfx80 font")
-
-    (LET ((FONTDESC (create FONTDESCRIPTOR
-                           FONTDEVICE _ 'FASTFX80
-                           FONTFAMILY _ FAMILY
-                           FONTSIZE _ SIZE
-                           FONTFACE _ FACE
-                           ROTATION _ ROTATION
-                           FONTSCALE _ 1
-                           \SFHeight _ 9
-                           \SFAscent _ 7
-                           \SFDescent _ 2)))
-         (if (\GETCHARSETINFO CHARSET FONTDESC T)
-             then FONTDESC
-           else NIL])
-
-(\FASTFX80.CREATECHARSET
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC)
-                                                             (* hdj "27-Oct-86 14:57")
-          
-          (* ;; "Create a character set for the fast fx-80.  Really only works for char set 0; returns the same info for all sets.")
-          
-          (* * (if (NEQ 0 CHARSET) then (ERROR "FX-80 does not support NS characters.")))
-
-    (LET ((WIDTHS (\CREATECSINFOELEMENT)))
-         (for C from 32 to 254 do (\FSETWIDTH WIDTHS C (\FASTFX80.SUBCHARWIDTH
-                                                                        C SIZE)))
-         (create CHARSETINFO
-                WIDTHS _ WIDTHS
-                IMAGEWIDTHS _ WIDTHS
-                YWIDTHS _ (\CREATECSINFOELEMENT)
-                CHARSETASCENT _ (ffetch \SFAscent of FONTDESC)
-                CHARSETDESCENT _ (ffetch \SFDescent of FONTDESC])
-)
-
-(CL:DEFUN \FASTFX80.INIT-FONT-PROFILE ()
-
-   (* ;; "set up the fonts for the FASTFX80, based on the DISPLAY font profile entries")
-
-   [FOR FONT-CLASS IN '(DEFAULTFONT ITALICFONT BOLDFONT LITTLEFONT TINYFONT BIGFONT COMMENTFONT 
-                              TEXTFONT) DO (\ADD-TO-FONTPROFILE FONTPROFILE FONT-CLASS 'FASTFX80
-                                                  (\GET-FROM-FONTPROFILE FONTPROFILE FONT-CLASS
-                                                         'DISPLAY]
-   (FONTPROFILE FONTPROFILE)
-   T)
-
-
-
-(* ;; "methods for measuring")
-
-(DEFINEQ
-
-(\FASTFX80.STRINGWIDTH
-  [LAMBDA (FASTFX80STREAM STRING RDTBL)                  (* hdj " 6-Nov-86 15:15")
-          
-          (* ;; 
-        " returns STRING's width, relative to STREAM's current font and the readtable RDTBL")
-
-    (if RDTBL
-        then (bind (FIRSTFLG _ T)
-                        (SA _ (fetch READSA of RDTBL))
-                        (ESCAPE-CHAR-WIDTH _ (\FASTFX80.CHARWIDTH FASTFX80STREAM
-                                                    (fetch (READTABLEP ESCAPECHAR) of RDTBL))
-                               )
-                        (SYN _ NIL) for CHARCODE instring STRING
-                    sum (PROG1 (+ (\FASTFX80.CHARWIDTH FASTFX80STREAM CHARCODE)
-                                      (IF (AND (fetch (READCODE ESCQUOTE)
-                                                      of (SETQ SYN (\SYNCODE SA CHARCODE)))
-                                                   (OR FIRSTFLG (fetch (READCODE INNERESCQUOTE)
-                                                                   of SYN)))
-                                          THEN ESCAPE-CHAR-WIDTH
-                                        ELSE 0))
-                                   (SETQ FIRSTFLG NIL)))
-      else (for CHAR instring STRING sum (\FASTFX80.CHARWIDTH FASTFX80STREAM CHAR
-                                                                ])
-
-(\FASTFX80.CHARWIDTH
-  [LAMBDA (STREAM CHARCODE)                              (* ; "Edited  4-Feb-87 15:52 by hdj")
-          
-          (* ;; " returns the width of CHARCODE, relative to STREAM's current font")
-
-    (WITH-FASTFX80-DATA (DATA STREAM)
-           (LET [(WIDTH (\FASTFX80.SUBCHARWIDTH (\FASTFX80.TRANSLATE-CHAR CHARCODE)
-                               (FONTPROP (FASTFX80DATA-FONT DATA)
-                                      'SIZE]
-                (IF (EQ CHARCODE (CHARCODE SPACE))
-                    THEN (FIXR (TIMES WIDTH (FASTFX80DATA-SPACEFACTOR DATA)))
-                  ELSE WIDTH])
-
-(\FASTFX80.SUBCHARWIDTH
-  [LAMBDA (CHARCODE SIZE)                                (* ; "Edited 21-Jan-88 12:10 by jds")
-          
-          (* ;; "Computes the size for a single character in Fast-FX80 mode.")
-
-    (COND
-       ((IGEQ CHARCODE 31)                                   (* ; 
-                                                     "Only non-control characters have real widths")
-
-        (COND
-           ((GREATERP SIZE 12)                               (* ; 
-                                                       "Fonts bigger than 12 are printed EXPANDED.")
-
-            14)
-           ((<= SIZE 8)                                      (* ; 
-                            "Sizes 8 & under are printed compressed, 17.16 pitch, or 4.19 dots per")
-
-            4)
-           (T                                                (* ; 
-                                                    "Should really be 7.2 dots, but this is close.")
-
-              7)))
-       (T 0])
-)
-
-(CL:DEFUN \FASTFX80.SPACEFACTOR (FASTFX80STREAM FACTOR)
-
-   (* ;; "returns/sets the width of the space character (32 ASCII) for FASTFX80STREAM")
-
-   [WITH-FASTFX80-DATA (DATA FASTFX80STREAM)
-          (PROG1 (FASTFX80DATA-SPACEFACTOR DATA)
-              (AND FACTOR (IF (NUMBERP FACTOR)
-                              THEN (CL:SETF (FASTFX80DATA-SPACEFACTOR DATA)
-                                          FACTOR)
-                            ELSE (\ILLEGAL.ARG FACTOR))))])
-
-
-
-(* ;; "methods that affect the current position/size of drawing surface")
-
-(DEFINEQ
-
-(\FASTFX80.CLIPPINGREGION
-  [LAMBDA (STREAM REGION)                                (* ; "Edited  8-Dec-86 15:16 by hdj")
-          
-          (* ;; 
-     "Returns old clipping region and sets new one.  will never set onelarger than the paper size.")
-
-    (DECLARE (GLOBALVARS \FASTFX80.PAGESIZE))
-    (WITH-FASTFX80-DATA (DATA STREAM)
-           (PROG1 (COPY (FASTFX80DATA-CLIPPINGREGION DATA))
-                  (AND REGION (CL:SETF (FASTFX80DATA-CLIPPINGREGION DATA)
-                                     (INTERSECTREGIONS REGION (CREATEREGION 0 0 (
-                                                                             FASTFX80DATA-PAPER-WIDTH
-                                                                                 DATA)
-                                                                     (FASTFX80DATA-PAPER-HEIGHT
-                                                                      DATA])
-
-(\FASTFX80.MOVETO
-  [LAMBDA (STREAM X Y)                                   (* hdj "27-Oct-86 11:40")
-          
-          (* ;; " move to (X,Y) on STREAM's drawing surface")
-
-    (\FASTFX80.XPOSITION STREAM X)
-    (\FASTFX80.YPOSITION STREAM Y])
-
-(\FASTFX80.XPOSITION
-  [LAMBDA (FASTFX80STREAM XPOS)                          (* hdj "20-Nov-86 17:50")
-          
-          (* ;; "Return old x-position, optionally move to new one.  If new position would lie outside the clipping region, set the virtual x position, but don't change the real x position or move the printer's print head.")
-
-    (WITH-FASTFX80-DATA
-     (DATA FASTFX80STREAM)
-     (LET ((OLD-REAL-XPOS (FASTFX80DATA-REAL-XPOS DATA))
-           (OLD-VIRTUAL-XPOS (FASTFX80DATA-VIRTUAL-XPOS DATA))
-           (CLIPPINGREGION (FASTFX80DATA-CLIPPINGREGION DATA)))
-          (PROG1 OLD-VIRTUAL-XPOS
-                 (if XPOS
-                     then 
-          
-          (* ;; "Space or backspace till new x-pos approximates desired position")
-
-                           (LET ((LEFT-BORDER (fetch (REGION LEFT) of CLIPPINGREGION))
-                                 (RIGHT-BORDER (fetch (REGION RIGHT) of CLIPPINGREGION)))
-                                (if (AND (LEQ LEFT-BORDER XPOS)
-                                             (LEQ XPOS RIGHT-BORDER))
-                                    then (if (AND (EQP (FASTFX80DATA-LEFTMARGIN DATA)
-                                                               0)
-                                                          (EQP XPOS 0))
-                                                 then    (* ; "if we can, just send a CR")
-
-                                                       (\FASTFX80.BOUT FASTFX80STREAM
-                                                              (CHARCODE CR))
-                                               else      (* ; "otherwise do the full schmeer")
-
-                                                     (\FASTFX80.SMART-XPOSITION OLD-REAL-XPOS XPOS 
-                                                            FASTFX80STREAM))
-                                          (CL:SETF (FASTFX80DATA-REAL-XPOS DATA)
-                                                 XPOS)))
-                           (CL:SETF (FASTFX80DATA-VIRTUAL-XPOS DATA)
-                                  XPOS])
-
-(\FASTFX80.YPOSITION
-  [LAMBDA (STREAM YPOS)                                  (* ; "Edited  9-Dec-86 22:43 by hdj")
-          
-          (* ;; "Return old y position, optionally move to new one.  If new position would lie outside the clipping region, set the virtual Y position, but don't change the real Y position or move the printer's print head.")
-
-    (WITH-FASTFX80-DATA
-     (DATA STREAM)
-     (LET ((OLD-REAL-YPOS (FASTFX80DATA-REAL-YPOS DATA))
-           (OLD-VIRTUAL-YPOS (FASTFX80DATA-VIRTUAL-YPOS DATA))
-           (CLIPPINGREGION (FASTFX80DATA-CLIPPINGREGION DATA)))
-          (PROG1 OLD-VIRTUAL-YPOS
-                 (if YPOS
-                     then [if (NOT (EQP YPOS OLD-REAL-YPOS))
-                                  then (LET ((TOP-BORDER (fetch (REGION TOP) of 
-                                                                                       CLIPPINGREGION
-                                                                    ))
-                                                 (BOTTOM-BORDER (fetch (REGION BOTTOM)
-                                                                   of CLIPPINGREGION)))
-                                                (if (NOT (EQP YPOS OLD-REAL-YPOS))
-                                                    then (LET [(DOTS-TO-MOVE (FIX (- YPOS 
-                                                                                        OLD-REAL-YPOS
-                                                                                         ]
-                                                                  (if (MINUSP DOTS-TO-MOVE)
-                                                                      then (
-                                                                            \FASTFX80.ADVANCE.PAPER
-                                                                                STREAM DOTS-TO-MOVE)
-                                                                    else (
-                                                                            \FASTFX80.BACKUP.PAPER
-                                                                              STREAM DOTS-TO-MOVE)))
-                                                          (CL:SETF (FASTFX80DATA-REAL-YPOS DATA)
-                                                                 YPOS]
-                           (CL:SETF (FASTFX80DATA-VIRTUAL-YPOS DATA)
-                                  YPOS])
-
-(\FASTFX80.BACKUP.PAPER
-  [LAMBDA (STREAM DOTS)                                  (* hdj "28-Oct-86 12:59")
-          
-          (* ;; "backup the page DOTS raster lines")
-
-    (SETQ DOTS (TIMES 3 (ABS DOTS)))
-    (while (GREATERP DOTS 0) do (\FASTFX80.BOUT STREAM (CHARCODE ESC))
-                                       (\FASTFX80.BOUT STREAM (CHARCODE j))
-                                       (\FASTFX80.BOUT STREAM (LET ((MAXBACKUP (MIN DOTS 255)))
-                                                                       (add DOTS (MINUS MAXBACKUP
-                                                                                            ))
-                                                                       MAXBACKUP])
-
-(\FASTFX80.ADVANCE.PAPER
-  [LAMBDA (STREAM DOTS)                                  (* hdj "28-Oct-86 12:58")
-          
-          (* ;; "advance the page DOTS raster lines")
-
-    (SETQ DOTS (TIMES 3 (ABS DOTS)))
-    (while (GREATERP DOTS 0) do (\FASTFX80.BOUT STREAM (CHARCODE ESC))
-                                       (\FASTFX80.BOUT STREAM (CHARCODE J))
-                                       (\FASTFX80.BOUT STREAM (LET ((MAXADVANCE (MIN DOTS 255)))
-                                                                       (add DOTS (MINUS 
-                                                                                           MAXADVANCE
-                                                                                            ))
-                                                                       MAXADVANCE])
-
-(\FASTFX80.NEWPAGE
-  [LAMBDA (FASTFX80STREAM)                               (* ; "Edited 17-Dec-86 10:32 by hdj")
-          
-          (* ;; "End the old page, start a new one")
-          
-          (* ;; "Just send a form-feed")
-
-    (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE FF))
-    (\FASTFX80.STARTPAGE FASTFX80STREAM])
-
-(\FASTFX80.OUTCHAR
-  [LAMBDA (FASTFX80STREAM CHARCODE)                      (* ; "Edited 12-Feb-87 09:08 by jds")
-          
-          (* ;; "outcharfn for fastfx80 imagestreams")
-
-    (LET ((TRANSLATED-CHAR (\FASTFX80.TRANSLATE-CHAR CHARCODE)))
-         (WITH-FASTFX80-DATA (DATA FASTFX80STREAM)
-                (SELCHARQ CHARCODE
-                     (^L (\FASTFX80.NEWPAGE FASTFX80STREAM))
-                     ((CR EOL) 
-                          (\FASTFX80.NEWLINE FASTFX80STREAM))
-                     (LF (\FASTFX80.LINEFEED FASTFX80STREAM))
-                     (SPACE [\FASTFX80.XPOSITION FASTFX80STREAM (+ (\FASTFX80.XPOSITION
-                                                                        FASTFX80STREAM)
-                                                                       (\FASTFX80.CHARWIDTH
-                                                                        FASTFX80STREAM
-                                                                        (CHARCODE SPACE]
-                            (COND
-                               ((> (FASTFX80DATA-VIRTUAL-XPOS DATA)
-                                   (FASTFX80DATA-RIGHTMARGIN DATA))
-                                (\FASTFX80.NEWLINE FASTFX80STREAM))))
-                     (COND
-                        ((GREATERP CHARCODE 32)
-          
-          (* ;; "only print graphic characters")
-
-                         (LET ((CHARWIDTH (\FASTFX80.CHARWIDTH FASTFX80STREAM TRANSLATED-CHAR)))
-          
-          (* ;; "if character will be visible, output it")
-
-                              (COND
-                                 ((\FASTFX80.CUR-POS-VISIBLE? DATA)
-                                  (\FASTFX80.BOUT FASTFX80STREAM TRANSLATED-CHAR)))
-                              (CL:INCF (FASTFX80DATA-REAL-XPOS DATA)
-                                     CHARWIDTH)
-                              (CL:INCF (FASTFX80DATA-VIRTUAL-XPOS DATA)
-                                     CHARWIDTH)
-          
-          (* ;; "if we've passed the margin, DING!, do a newline")
-
-                              (COND
-                                 ((> (FASTFX80DATA-VIRTUAL-XPOS DATA)
-                                     (FASTFX80DATA-RIGHTMARGIN DATA))
-                                  (\FASTFX80.NEWLINE FASTFX80STREAM])
-
-(\FASTFX80.NEWLINE
-  [LAMBDA (FASTFX80STREAM)                               (* hdj "11-Nov-86 14:02")
-          
-          (* ;; 
-"perform a newline on a fastfx80 imagestream.  if we go below the bottom margin, start a new page.")
-
-    (DECLARE (GLOBALVARS \FASTFX80.LINEHEIGHT))
-    (WITH-FASTFX80-DATA (DATA FASTFX80STREAM)
-           (LET ((NEW-Y (- (FASTFX80DATA-VIRTUAL-YPOS DATA)
-                           \FASTFX80.LINEHEIGHT)))
-                (if (< NEW-Y (FASTFX80DATA-BOTTOMMARGIN DATA))
-                    then (\FASTFX80.NEWPAGE FASTFX80STREAM)
-                  else                                   (* ; "move to the left margin")
-
-                        (\FASTFX80.XPOSITION FASTFX80STREAM (FASTFX80DATA-LEFTMARGIN DATA))
-                        (FREPLACE (STREAM CHARPOSITION) OF FASTFX80STREAM WITH 0) 
-                                                             (* ; "then move down or newpage")
-
-                        (\FASTFX80.YPOSITION FASTFX80STREAM NEW-Y])
-
-(\FASTFX80.LINEFEED
-  [LAMBDA (FASTFX80STREAM)                               (* hdj " 6-Nov-86 15:38")
-          
-          (* ;; "move down 1 line, leaving the x-position alone")
-
-    (DECLARE (GLOBALVARS \FASTFX80.LINEHEIGHT))
-    (WITH-FASTFX80-DATA (DATA FASTFX80STREAM)
-           (LET ((NEW-YPOS (- (FASTFX80DATA-VIRTUAL-YPOS DATA)
-                              \FASTFX80.LINEHEIGHT))
-                 (OLD-XPOS (FASTFX80DATA-VIRTUAL-XPOS DATA)))
-                (if (< NEW-YPOS (FASTFX80DATA-BOTTOMMARGIN DATA))
-                    then                                 (* ; "move to a new page")
-
-                          (\FASTFX80.NEWPAGE FASTFX80STREAM) 
-                                                             (* ; "restore the old x position")
-
-                          (\FASTFX80.XPOSITION FASTFX80STREAM OLD-XPOS)
-                  else                                   (* ; "move down")
-
-                        (\FASTFX80.YPOSITION FASTFX80STREAM NEW-YPOS])
-
-(\FASTFX80.DRAWLINE
-  [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING)
-                                                             (* hdj "31-Oct-86 14:09")
-          
-          (* ;; "dummy drawline for the fast fx80 device")
-
-    (MOVETO X2 Y2 STREAM])
-)
-
-(CL:DEFUN \FASTFX80.STARTPAGE (FASTFX80STREAM)
-   (WITH-FASTFX80-DATA (DATA FASTFX80STREAM)
-          (LET [(ASCENT (FONTPROP (DSPFONT NIL FASTFX80STREAM)
-                               'ASCENT]
-
-               (* ;; "set the %"actual%" position of printhead on paper after a newpage, then let the driver figure out how to get to (leftmargin, topmargin).")
-
-               (CL:SETF (FASTFX80DATA-VIRTUAL-XPOS DATA)
-                      0)
-               (CL:SETF (FASTFX80DATA-REAL-XPOS DATA)
-                      0)
-               (CL:SETF (FASTFX80DATA-VIRTUAL-YPOS DATA)
-                      (FASTFX80DATA-PAPER-HEIGHT DATA))
-               (CL:SETF (FASTFX80DATA-REAL-YPOS DATA)
-                      (FASTFX80DATA-PAPER-HEIGHT DATA))
-
-               (* ;; "move the paper")
-
-               (MOVETO (FASTFX80DATA-LEFTMARGIN DATA)
-                      (- (FASTFX80DATA-TOPMARGIN DATA)
-                         ASCENT)
-                      FASTFX80STREAM)
-               FASTFX80STREAM)))
-
-(CL:DEFUN \FASTFX80.SMART-XPOSITION (CURRENT-XPOS DESIRED-XPOS FASTFX80STREAM)
-
-   (* ;; "if it would create less output to space from the left margin, rather than to backspace from the current position, do so")
-
-   (LET* ((SPACEWIDTH (\FASTFX80.CHARWIDTH FASTFX80STREAM (CHARCODE SP)))
-          (CURRENT-XPOS-IN-SPACES (IQUOTIENT CURRENT-XPOS SPACEWIDTH))
-          (DESIRED-XPOS-IN-SPACES (IQUOTIENT DESIRED-XPOS SPACEWIDTH))
-          (NUM-BACKSPACES-NEEDED (- CURRENT-XPOS-IN-SPACES DESIRED-XPOS-IN-SPACES)))
-         (IF (< NUM-BACKSPACES-NEEDED DESIRED-XPOS-IN-SPACES)
-             THEN 
-                  (* ;; "if backspacing's cheaper, backspace away")
-
-                  (\FASTFX80.HORIZONTAL (- NUM-BACKSPACES-NEEDED)
-                         FASTFX80STREAM)
-           ELSE 
-                (* ;; "otherwise, go to the left margin...  ")
-
-                (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE CR)) 
-
-                (* ;; "... and then space to the right spot")
-
-                (\FASTFX80.HORIZONTAL DESIRED-XPOS-IN-SPACES FASTFX80STREAM))))
-
-(CL:DEFUN \FASTFX80.TOPMARGIN (STREAM &OPTIONAL YPOSITION)
-   [WITH-FASTFX80-DATA (DATA STREAM)
-          (PROG1 (FASTFX80DATA-TOPMARGIN DATA)
-              (AND YPOSITION (IF (SMALLP YPOSITION)
-                                 THEN (CL:SETF (FASTFX80DATA-TOPMARGIN DATA)
-                                             YPOSITION)
-                               ELSE (\ILLEGAL.ARG YPOSITION))))])
-
-(CL:DEFUN \FASTFX80.BOTTOMMARGIN (STREAM &OPTIONAL YPOSITION)
-   [WITH-FASTFX80-DATA (DATA STREAM)
-          (PROG1 (FASTFX80DATA-BOTTOMMARGIN DATA)
-              (AND YPOSITION (IF (SMALLP YPOSITION)
-                                 THEN (CL:SETF (FASTFX80DATA-BOTTOMMARGIN DATA)
-                                             YPOSITION)
-                               ELSE (\ILLEGAL.ARG YPOSITION))))])
-
-(CL:DEFUN \FASTFX80.LEFTMARGIN (STREAM &OPTIONAL XPOSITION)
-   [WITH-FASTFX80-DATA (DATA STREAM)
-          (PROG1 (FASTFX80DATA-LEFTMARGIN DATA)
-              (AND XPOSITION (IF (SMALLP XPOSITION)
-                                 THEN (CL:SETF (FASTFX80DATA-LEFTMARGIN DATA)
-                                             XPOSITION)
-                               ELSE (\ILLEGAL.ARG XPOSITION))))])
-
-(CL:DEFUN \FASTFX80.RIGHTMARGIN (STREAM &OPTIONAL XPOSITION)
-   [WITH-FASTFX80-DATA (DATA STREAM)
-          (PROG1 (FASTFX80DATA-RIGHTMARGIN DATA)
-              (AND XPOSITION (IF (SMALLP XPOSITION)
-                                 THEN (CL:SETF (FASTFX80DATA-RIGHTMARGIN DATA)
-                                             XPOSITION)
-                               ELSE (\ILLEGAL.ARG XPOSITION))))])
-
-(DEFMACRO \FASTFX80.CUR-POS-VISIBLE? (FASTFX80DATA)
-   `(INSIDEP (FASTFX80DATA-CLIPPINGREGION ,FASTFX80DATA)
-           (FASTFX80DATA-REAL-XPOS ,FASTFX80DATA)
-           (FASTFX80DATA-REAL-YPOS ,FASTFX80DATA)))
-
-(CL:DEFUN \FASTFX80.HORIZONTAL (SPACES FASTFX80STREAM)
-
-   (* ;; "print SPACES space characters if SPACES > 0, print SPACES backspaces if < 0, and do nothing if SPACES=0.")
-
-   [if (MINUSP SPACES)
-       then (for SPACE from 1 to (ABS SPACES) by 1 do (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE BS)))
-     else (for SPACE from 1 to SPACES by 1 do (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE SP])
-
-
-
-(* ;; "printer code")
-
-
-(CL:DEFUN \FASTFX80.SEND (PRINTER FILENAME &OPTIONAL OPTIONS)
-
-   (* ;; "send the file designated by FILENAME to PRINTER, obeying OPTIONS.  Since we only have one fx-80 per machine, ignore PRINTER and send to FASTFX80-DEFAULT-DESTINATION")
-
-   (DECLARE (GLOBALVARS FASTFX80-DEFAULT-DESTINATION))
-   [LET [(COPIES (LISTGET OPTIONS '%#COPIES]
-        (FOR COPY FROM 1 TO COPIES DO 
-                                      (* ;; "allow the user to abort it while running")
-
-                                      (WITH-ABORT-WINDOW ((THIS.PROCESS)
-                                                          FILENAME PRINTER COPY)
-                                             (COPYFILE FILENAME FASTFX80-DEFAULT-DESTINATION
-                                                    '((TYPE FASTFX80])
-
-(CL:DEFUN MAKE-FASTFX80 (FILE FASTFX80FILE &OPTIONAL FONTS HEADING TABS OPTIONS)
-
-   (* ;; "turn FILE into a FASTFX80 master")
-
-   (TEXTTOIMAGEFILE FILE FASTFX80FILE 'FASTFX80 FONTS HEADING TABS OPTIONS))
-
-(CL:DEFUN FASTFX80FILEP (FASTFX80FILE?)
-
-   (* ;; "is FILE (a filename or stream) a fastfx80 file?")
-
-   [LET [(FILE-TYPE (GETFILEINFO FASTFX80FILE? 'TYPE]
-        (IF (EQ FILE-TYPE 'FASTFX80)
-            THEN                                             (* ; 
-                                                      "if file has a type, and type=FASTFX80, we win")
-                 T
-          ELSE                                               (* ; 
-                                             "no filetype or filetype not FASTFX80, so read the file")
-               (LET [(STREAM (OPENSTREAM (INTERLISP-NAMESTRING FASTFX80FILE?)
-                                    'INPUT
-                                    'OLD
-                                    '(SEQUENTIAL]
-
-                    (* ;; "file looks like ESC@ESCCn<signature>...")
-
-                    (PROG1 [AND (> (GETFILEINFO STREAM 'LENGTH)
-                                   (+ 5 (NCHARS \FASTFX80.FILE-SIGNATURE)))
-
-                                (* ;; "yuck...")
-
-                                (EQ (CHARCODE ESC)
-                                    (BIN STREAM))
-                                (EQ (CHARCODE @)
-                                    (BIN STREAM))
-                                (EQ (CHARCODE ESC)
-                                    (BIN STREAM))
-                                (EQ (CHARCODE C)
-                                    (BIN STREAM))
-                                (BIN STREAM)
-                                (FOR CH INSTRING \FASTFX80.FILE-SIGNATURE
-                                   ALWAYS (EQ CH (BIN STREAM]
-                           (CLOSEF STREAM])
-
-(CL:DEFUN \FASTFX80.CANNOT-PRINT-BITMAPS (&OPTIONAL FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)
-   (PRINTOUT PROMPTWINDOW "Sorry, FASTFX80 cannot render graphics." T "Use HQFX80 instead."))
-(DEFINEQ
-
-(\FASTFX80.CONVERT-TEDIT
-  [LAMBDA (TEDIT-FILE IMAGESTREAM)                       (* ; "Edited 11-Dec-86 17:29 by hdj")
-          
-          (* ;; "Send the text to the printer.")
-
-    (SETQ TEDIT-FILE (OPENTEXTSTREAM TEDIT-FILE))
-    (TEDIT.FORMAT.HARDCOPY TEDIT-FILE IMAGESTREAM T NIL NIL NIL 'FASTFX80)
-    (CLOSEF? IMAGESTREAM)
-    IMAGESTREAM])
-)
-
-
-
-(* ;; "Character transmission method")
-
-(DEFINEQ
-
-(\FASTFX80.BOUT
-  [LAMBDA (FASTFX80STREAM BYTE)                          (* hdj "27-Oct-86 11:51")
-          
-          (* ;; "send a byte to the fx80")
-
-    (WITH-FASTFX80-DATA (DATA FASTFX80STREAM)
-           (BOUT (FASTFX80DATA-BACKINGSTREAM DATA)
-                 BYTE])
-)
-
-
-
-(* ;; "Miscellany")
-
-
-(DEFMACRO \FASTFX80.TRANSLATE-CHAR (CHARCODE)
-   `(SELCHARQ ,CHARCODE
-         (357,146                                            (* ; "bullet")
-                  (CHARCODE *))
-         (357,45                                             (* ; "em-dash")
-                 95)
-         (357,44                                             (* ; "en-dash")
-                 45)
-         (\CHAR8CODE ,CHARCODE)))
-
-(DEFMACRO WITH-FASTFX80-DATA ((VAR-NAME STREAM)
-                              &BODY
-                              (BODY DECLS ENV))
-   `(LET [(,VAR-NAME (FETCH (STREAM IMAGEDATA) OF ,STREAM]
-         ,@DECLS
-         ,@BODY))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \FASTFX80.DOTSPERINCH 72)
-
-(RPAQQ \FASTFX80.LINESPERINCH 6)
-
-(RPAQQ \FASTFX80.LINEHEIGHT 12)
-
-(RPAQ \FASTFX80.FILE-SIGNATURE "FastFX-80/Xerox/1.0 ")
-
-
-(CONSTANTS (\FASTFX80.DOTSPERINCH 72)
-       (\FASTFX80.LINESPERINCH 6)
-       (\FASTFX80.LINEHEIGHT 12)
-       (\FASTFX80.FILE-SIGNATURE "FastFX-80/Xerox/1.0 "))
-)
-
-(RPAQ? FASTFX80-DEFAULT-DESTINATION "{TTY}")
-
-(RPAQ? \FASTFX80.INCHES-PER-PAGE 11)
-
-(RPAQ? \FASTFX80.INCHES-PER-LINE 8.5)
-
-
-
-(* ;; "need to load these exports")
-
-(DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY 
-
-(FILESLOAD (LOADCOMP)
-       ADISPLAY)
-)
-
-(RPAQQ FX-80.HIGH-QUALITY-DRIVERCOMS
-       [
-        (* ;; "High-quality driver")
-
-        
-        (* ;; "")
-
-        (STRUCTURES HQFX80DATA)
-        (FNS \HQFX80.INIT)
-        (COMS 
-              (* ;; "imagestream methods")
-
-              (COMS 
-                    (* ;; "opening/closing imagestream")
-
-                    (COMS (FNS OPENHQFX80STREAM)
-                          (FUNCTIONS \HQFX80.PREAMBLE \HQFX80.RESET-PRINTER \HQFX80.OUTPUT-SIGNATURE)
-                          )
-                    (FNS \HQFX80.CLOSE))
-              (COMS 
-                    (* ;; "methods that hack fonts")
-
-                    (FNS \HQFX80.FONTCREATE \HQFX80.CHANGEFONT \HQFX80.CREATECHARSET 
-                         \HQFX80.CHANGE-CHARSET \HQFX80.READ-FONT-FILE \HQFX80.SEARCH-FONTS)
-                    (FUNCTIONS \HQFX80.INIT-FONT-PROFILE))
-              (COMS 
-                    (* ;; "methods for measuring")
-
-                    (FNS \HQFX80.CHARWIDTH \HQFX80.STRINGWIDTH)
-                    (FUNCTIONS \HQFX80.SPACEFACTOR))
-              (COMS 
-                    (* ;; "methods that affect the current position/size of drawing surface")
-
-                    (FNS \HQFX80.CLIPPINGREGION \HQFX80.LEFTMARGIN \HQFX80.RIGHTMARGIN 
-                         \HQFX80.TOPMARGIN \HQFX80.BOTTOMMARGIN \HQFX80.XPOSITION \HQFX80.YPOSITION 
-                         \HQFX80.NEWLINE \HQFX80.NEWPAGE \HQFX80.LINEFEED \HQFX80.RESET 
-                         \HQFX80.STARTPAGE)
-                    (FUNCTIONS \HQFX80.CUR-POS-VISIBLE?))
-              (COMS 
-                    (* ;; "graphical operations")
-
-                    (RESOURCES \HQFX80.BRUSHBBT)
-                    (FNS \HQFX80.BITBLT \HQFX80.BLTSHADE \HQFX80.DRAWELLIPSE \HQFX80.OPERATION 
-                         \HQFX80.DRAWPOINT)
-                    (FNS \HQFX80.DRAWLINE \HQFX80.CLIP-AND-DRAW-LINE \HQFX80.CLIP-AND-DRAW-LINE1)
-                    (COMS (FNS \HQFX80.DRAWCIRCLE \HQFX80.CREATE-BRUSH-BBT)
-                          (FUNCTIONS \HQFX80.DRAW-4-CIRCLE-POINTS))
-                    (COMS (FNS \HQFX80.FILLCIRCLE \HQFX80.DRAWARC)
-                          (FUNCTIONS \HQFX80.FILL-CIRCLE-BLT))
-                    (COMS 
-                          (* ;; "curve-drawing")
-
-                          (FNS \HQFX80.DRAWCURVE \HQFX80.DRAWCURVE2 \HQFX80.DRAWCURVE3 
-                               \HQFX80.LINEWITHBRUSH)
-                          (FNS \HQFX80.BBTCURVEPT)
-                          (MACROS \HQFX80.CURVEPT)
-                          (FUNCTIONS \HQFX80.SMOOTH-CURVE .SETUP.FOR.\HQFX80.BBTCURVEPT.)))
-              (COMS 
-                    (* ;; "character printing methods")
-
-                    (FNS \HQFX80.OUTCHAR \HQFX80.BLT-CHAR))
-              (COMS 
-                    (* ;; "printer code")
-
-                    (FNS \HQFX80.DUMP-PAGE-BUFFER \HQFX80.ADVANCE-8-LINES)
-                    (FUNCTIONS \HQFX80.EIGHT-LINES-BLANK? \HQFX80.BITMAP-LDB \HQFX80.CLEAR-SCANLINE 
-                           \HQFX80.CLEAR-WORD-BOX)
-                    (FUNCTIONS \HQFX80.SEND MAKE-HQFX80 HQFX80FILEP))
-              (COMS 
-                    (* ;; "window hardcopy")
-
-                    (FNS \HQFX80.BITMAP-FILE \HQFX80.CONVERT-TEDIT))
-              (COMS 
-                    (* ;; "character transmission method")
-
-                    (FNS \HQFX80.BOUT))
-              (COMS 
-                    (* ;; "handling font-information caching")
-
-                    (FNS \HQFX80.FIX-LINE-LENGTH \HQFX80.FIX-FONT \HQFX80.FIX-Y)
-                    (FUNCTIONS \HQFX80.INVALIDATE-CACHE \HQFX80.INVALIDATE-FONT-CACHE 
-                           \HQFX80.GET-CACHED-CHAR-WIDTH \HQFX80.GET-CHARACTER-OFFSET))
-              (COMS 
-                    (* ;; "auxiliary functions")
-
-                    (FUNCTIONS \HQFX80.GRAPHICS-MODE)
-                    (FNS \HQFX80.PRINTER-MODE)
-                    (FUNCTIONS WITH-HQFX80-DATA))
-              
-              (* ;; "and miscellany")
-
-              (CONSTANTS (\HQFX80.FILE-SIGNATURE "HQFX-80/Xerox/1.0 ")
-                     (\HQFX80.1-TO-1-MODE-DPI 72)
-                     (\HQFX80.LOW-SPEED-DOUBLE-MODE-DPI 120))
-              (INITVARS (\HQFX80.INCHES-PER-PAGE 11)
-                     (\HQFX80.INCHES-PER-LINE 8.5)
-                     (HQFX80-DEFAULT-DESTINATION "{TTY}")
-                     (HQFX80-FONT-EXTENSIONS DISPLAYFONTEXTENSIONS)
-                     (HQFX80-FONT-DIRECTORIES DISPLAYFONTDIRECTORIES)
-                     (HQFX80-FONT-COERCIONS DISPLAYFONTCOERCIONS)
-                     (HQFX80-MISSING-FONT-COERCIONS DISPLAYFONTCOERCIONS])
-
-
-
-(* ;; "High-quality driver")
-
-
-
-
-(* ;; "")
-
-
-(CL:DEFSTRUCT HQFX80DATA
-
-   (* ;; "the imagedata vector for an HQFX80 imagestream")
-
-   BACKINGBITMAP
-   BACKINGSTREAM
-   (XPOS 0)
-   (YPOS 0)
-   (CLIPPINGREGION (create REGION))
-   LINEFEED RIGHTMARGIN (LEFTMARGIN 0)
-   TOPMARGIN
-   (BOTTOMMARGIN 0)
-   OPERATION SOURCETYPE (PILOTBBT (create PILOTBBT
-                                         PBTDISJOINT _ T))
-   (TEXTURE WHITESHADE)
-   FONT
-   (CHARSET-ASCENT-CACHE MAX.SMALLP)
-   WIDTHS-CACHE OFFSETS-CACHE IMAGE-WIDTHS-CACHE (CHARSET-CACHE MAX.SMALLP)
-   CHARSET-DESCENT-CACHE CHARHEIGHTDELTA (SPACEWIDTH 1.0)    (* ; 
-                                     "a misnomer -- this is actually the space factor, not its width")
-   [SERIALIZING-BOX (fetch (ARRAYP BASE) of (ARRAY 1 'BYTE]
-   SERIALIZING-PILOTBBT SCRATCH-SCANLINE SCRATCH-SCANLINE-PILOTBBT [EIGHT-LINES-BLANK
-                                                                    (fetch (ARRAYP BASE)
-                                                                       of (ARRAY 1 'WORD]
-   EIGHT-LINES-BLANK-PILOTBBT COMPRESSED?)
-(DEFINEQ
-
-(\HQFX80.INIT
-  [LAMBDA NIL                                                (* ; "Edited  3-Feb-87 17:23 by hdj")
-          
-          (* ;; "Initializes global variables for the FX80")
-
-    (DECLARE (GLOBALVARS DEFAULTPRINTINGHOST IMAGESTREAMTYPES PRINTERTYPES PRINTFILETYPES 
-                    \HQFX80.IMAGEOPS \HQFX80.FDEV))
-    (SETQ \HQFX80.FDEV (create FDEV
-                              DEVICENAME _ (LIST 'HQFX80 'PRINTER)
-                              CLOSEFILE _ (FUNCTION NILL)
-                              BOUT _ (FUNCTION \HQFX80.OUTCHAR)))
-    (SETQ \HQFX80.IMAGEOPS (create IMAGEOPS
-                                  IMAGETYPE _ 'HQFX80
-                                  IMFONT _ (FUNCTION \HQFX80.CHANGEFONT)
-                                  IMLEFTMARGIN _ (FUNCTION \HQFX80.LEFTMARGIN)
-                                  IMRIGHTMARGIN _ (FUNCTION \HQFX80.RIGHTMARGIN)
-                                  IMTOPMARGIN _ (FUNCTION \HQFX80.TOPMARGIN)
-                                  IMBOTTOMMARGIN _ (FUNCTION \HQFX80.BOTTOMMARGIN)
-                                  IMLINEFEED _ (FUNCTION \HQFX80.LINEFEED)
-                                  IMXPOSITION _ (FUNCTION \HQFX80.XPOSITION)
-                                  IMYPOSITION _ (FUNCTION \HQFX80.YPOSITION)
-                                  IMCLOSEFN _ (FUNCTION \HQFX80.CLOSE)
-                                  IMDRAWCURVE _ (FUNCTION \HQFX80.DRAWCURVE)
-                                  IMFILLCIRCLE _ (FUNCTION \HQFX80.FILLCIRCLE)
-                                  IMDRAWLINE _ (FUNCTION \HQFX80.DRAWLINE)
-                                  IMDRAWELLIPSE _ (FUNCTION \HQFX80.DRAWELLIPSE)
-                                  IMDRAWCIRCLE _ (FUNCTION \HQFX80.DRAWCIRCLE)
-                                  IMBITBLT _ (FUNCTION \HQFX80.BITBLT)
-                                  IMBLTSHADE _ (FUNCTION \HQFX80.BLTSHADE)
-                                  IMNEWPAGE _ (FUNCTION \HQFX80.NEWPAGE)
-                                  IMSCALE _ [FUNCTION (LAMBDA NIL 1]
-                                  IMSPACEFACTOR _ (FUNCTION \HQFX80.SPACEFACTOR)
-                                  IMFONTCREATE _ 'HQFX80
-                                  IMCOLOR _ (FUNCTION NILL)
-                                  IMBACKCOLOR _ (FUNCTION NILL)
-                                  IMOPERATION _ (FUNCTION \HQFX80.OPERATION)
-                                  IMSTRINGWIDTH _ (FUNCTION \HQFX80.STRINGWIDTH)
-                                  IMCHARWIDTH _ (FUNCTION \HQFX80.CHARWIDTH)
-                                  IMCLIPPINGREGION _ (FUNCTION \HQFX80.CLIPPINGREGION)
-                                  IMRESET _ (FUNCTION \HQFX80.RESET)
-                                  IMDRAWPOINT _ (FUNCTION \HQFX80.DRAWPOINT)
-                                  IMDRAWARC _ (FUNCTION \HQFX80.DRAWARC)
-                                  IMFILLPOLYGON _ (FUNCTION POLYSHADE.BLT)))
-    [push IMAGESTREAMTYPES (COPYALL '(HQFX80 (OPENSTREAM OPENHQFX80STREAM)
-                                            (FONTCREATE \HQFX80.FONTCREATE)
-                                            (CREATECHARSET \HQFX80.CREATECHARSET)
-                                            (FONTSAVAILABLE \HQFX80.SEARCH-FONTS]
-    [push PRINTERTYPES (COPYALL '((HQFX80)
-                                  (CANPRINT (HQFX80))
-                                  (STATUS TRUE)
-                                  (PROPERTIES NILL)
-                                  (SEND \HQFX80.SEND)
-                                  (BITMAPSCALE NIL)
-                                  (BITMAPFILE (\HQFX80.BITMAP-FILE FILE BITMAP SCALEFACTOR REGION 
-                                                     ROTATION TITLE]
-    [push PRINTFILETYPES (COPYALL '(HQFX80 (TEST HQFX80FILEP)
-                                          (EXTENSION (HQFX80))
-                                          (CONVERSION (TEXT MAKE-HQFX80 TEDIT \HQFX80.CONVERT-TEDIT]
-    (push DEFAULTPRINTINGHOST (LIST 'HQFX80 'HQFX80))
-    (PUTPROP 'HQFX80 'PRINTERTYPE 'HQFX80)
-    (\HQFX80.INIT-FONT-PROFILE)
-    T])
-)
-
-
-
-(* ;; "imagestream methods")
-
-
-
-
-(* ;; "opening/closing imagestream")
-
-(DEFINEQ
-
-(OPENHQFX80STREAM
-  [LAMBDA (FILENAME OPTIONS)                                 (* ; "Edited 29-May-87 19:30 by Snow")
-          
-          (* ;; "Opens an imagestream on a high-quality FX80")
-
-    (LET* ([BACKING (OPENSTREAM FILENAME 'OUTPUT NIL '((SEQUENTIAL T)
-                                                       (TYPE HQFX80]
-           (COMPRESSED? (LISTGET OPTIONS 'COMPRESSED))
-           [DOTS-PER-LINE (FIX (TIMES \HQFX80.INCHES-PER-LINE (if COMPRESSED?
-                                                                  then 
-                                                                    \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI
-                                                                else \HQFX80.1-TO-1-MODE-DPI]
-           (DOTS-PER-PAGE (ITIMES 8 (CL:CEILING (FIX (TIMES \HQFX80.INCHES-PER-PAGE
-                                                            (if COMPRESSED?
-                                                                then 
-                                                                    \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI
-                                                              else \HQFX80.1-TO-1-MODE-DPI)))
-                                           8)))
-           (BACKING-BITMAP (BITMAPCREATE DOTS-PER-LINE DOTS-PER-PAGE))
-           (BACKING-BITMAP-WORD-WIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BACKING-BITMAP))
-           (DATA (MAKE-HQFX80DATA :BACKINGSTREAM BACKING :CLIPPINGREGION (CREATEREGION 0 0 
-                                                                                DOTS-PER-LINE 
-                                                                                DOTS-PER-PAGE)
-                        :BACKINGBITMAP BACKING-BITMAP :RIGHTMARGIN DOTS-PER-LINE :TOPMARGIN
-                        (- DOTS-PER-PAGE 15)
-                        :BOTTOMMARGIN 30 :PILOTBBT (create PILOTBBT
-                                                          PBTDISJOINT _ T
-                                                          PBTDESTBPL _ (UNFOLD 
-                                                                            BACKING-BITMAP-WORD-WIDTH 
-                                                                              BITSPERWORD))
-                        :SCRATCH-SCANLINE
-                        (fetch (BITMAP BITMAPBASE) of (BITMAPCREATE DOTS-PER-LINE 1))
-                        :OPERATION
-                        'REPLACE :SOURCETYPE 'INPUT :COMPRESSED? COMPRESSED?))
-           (HQFX80STREAM (create STREAM
-                                FULLFILENAME _ (FULLNAME BACKING)
-                                DEVICE _ \HQFX80.FDEV
-                                ACCESS _ 'OUTPUT
-                                OUTCHARFN _ (FUNCTION \HQFX80.OUTCHAR)
-                                STRMBOUTFN _ (FUNCTION \HQFX80.OUTCHAR)
-                                IMAGEOPS _ \HQFX80.IMAGEOPS
-                                USERCLOSEABLE _ T
-                                USERVISIBLE _ T
-                                IMAGEDATA _ DATA)))
-          
-          (* ;; 
-   "set up the BitBLT table that transforms 8-bit columns of bitmap data into single BOUT-able bytes")
-
-          (CL:SETF (HQFX80DATA-SERIALIZING-PILOTBBT DATA)
-                 (create PILOTBBT
-                        PBTDISJOINT _ T
-                        PBTDEST _ (HQFX80DATA-SERIALIZING-BOX DATA)
-                        PBTWIDTH _ 1
-                        PBTHEIGHT _ 8
-                        PBTSOURCEBPL _ (UNFOLD BACKING-BITMAP-WORD-WIDTH BITSPERWORD)
-                        PBTDESTBPL _ 1))
-          
-          (* ;; "set up the BitBLT table that ORs together eight sequential scanlines (for blank-line group detection) into one scanline")
-
-          (CL:SETF (HQFX80DATA-SCRATCH-SCANLINE-PILOTBBT DATA)
-                 (create PILOTBBT
-                        PBTDISJOINT _ T
-                        PBTDEST _ (HQFX80DATA-SCRATCH-SCANLINE DATA)
-                        PBTWIDTH _ (UNFOLD BACKING-BITMAP-WORD-WIDTH BITSPERWORD)
-                        PBTHEIGHT _ 8
-                        PBTSOURCEBPL _ (UNFOLD BACKING-BITMAP-WORD-WIDTH BITSPERWORD)
-                        PBTDESTBPL _ 0
-                        PBTSOURCEBIT _ 0
-                        PBTDESTBIT _ 0
-                        PBTOPERATION _ 2))
-          
-          (* ;; "set up the BitBLT table that ORs one scanline into one 16-bit word")
-
-          (CL:SETF (HQFX80DATA-EIGHT-LINES-BLANK-PILOTBBT DATA)
-                 (create PILOTBBT
-                        PBTDISJOINT _ T
-                        PBTSOURCE _ (HQFX80DATA-SCRATCH-SCANLINE DATA)
-                        PBTDEST _ (HQFX80DATA-EIGHT-LINES-BLANK DATA)
-                        PBTWIDTH _ BITSPERWORD
-                        PBTHEIGHT _ (FOLDHI DOTS-PER-LINE BITSPERWORD)
-                        PBTSOURCEBPL _ BITSPERWORD
-                        PBTDESTBPL _ 0
-                        PBTSOURCEBIT _ 0
-                        PBTDESTBIT _ 0
-                        PBTOPERATION _ 2))
-          
-          (* ;; "make the backing file invisible")
-
-          (replace (STREAM USERVISIBLE) of BACKING with NIL)
-          
-          (* ;; "put the preamble on the master")
-
-          (\HQFX80.PREAMBLE HQFX80STREAM)
-          HQFX80STREAM])
-)
-
-(CL:DEFUN \HQFX80.PREAMBLE (HQFX80STREAM)
-
-   (* ;; "start an HQFX80 master")
-
-   (DECLARE (GLOBALVARS \HQFX80.INCHES-PER-PAGE))
-   (\HQFX80.RESET-PRINTER HQFX80STREAM \HQFX80.INCHES-PER-PAGE)
-   (\HQFX80.OUTPUT-SIGNATURE HQFX80STREAM)
-   (DSPFONT (DEFAULTFONT 'HQFX80)
-          HQFX80STREAM)
-   (\HQFX80.STARTPAGE HQFX80STREAM))
-
-(CL:DEFUN \HQFX80.RESET-PRINTER (HQFX80STREAM INCHES-PER-PAGE)
-
-   (* ;; "send a reset sequence to the fx-80")
-
-   (IF (AND (<= 1 INCHES-PER-PAGE)
-            (<= INCHES-PER-PAGE 22))
-       THEN 
-            (* ;; "send a reset sequence to the fx-80...")
-
-            (\HQFX80.BOUT HQFX80STREAM (CHARCODE ESC))
-            (\HQFX80.BOUT HQFX80STREAM (CHARCODE @)) 
-
-            (* ;; "...and set the form length")
-
-            (\HQFX80.BOUT HQFX80STREAM (CHARCODE ESC))
-            (\HQFX80.BOUT HQFX80STREAM (CHARCODE C))
-            (\HQFX80.BOUT HQFX80STREAM (FIXR (TIMES 6 INCHES-PER-PAGE)))
-     ELSE (ERROR "Illegal page length value" INCHES-PER-PAGE)))
-
-(CL:DEFUN \HQFX80.OUTPUT-SIGNATURE (HQFX80TREAM)
-
-   (* ;; "start the file with an identifying signature.  Ensure it is not printed by following it with an equal number of ASCII 127's.")
-
-   (* ;; "This will not work if SIGNATURE contains line-ending characters.")
-
-   (LET ((DEL-BYTE 127))
-        (FOR BYTE INSTRING \HQFX80.FILE-SIGNATURE DO (\HQFX80.BOUT HQFX80TREAM BYTE))
-        (FOR BYTE INSTRING \HQFX80.FILE-SIGNATURE DO (\HQFX80.BOUT HQFX80TREAM DEL-BYTE))))
-(DEFINEQ
-
-(\HQFX80.CLOSE
-  [LAMBDA (HQFX80STREAM)                                 (* ; "Edited 21-Jan-88 12:20 by jds")
-          
-          (* ;; "do the cleanup prefatory to closing the HQFX80STREAM")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)                    (* ; "")
-
-           (LET ((BACKING-STREAM (HQFX80DATA-BACKINGSTREAM DATA)))
-                (\HQFX80.DUMP-PAGE-BUFFER (HQFX80DATA-BACKINGBITMAP DATA)
-                       HQFX80STREAM)
-                (\BOUT BACKING-STREAM (CHARCODE ESCAPE))
-                (\BOUT BACKING-STREAM (CHARCODE !))
-                (\BOUT BACKING-STREAM 0)
-                (\BOUT BACKING-STREAM (CHARCODE ESCAPE))
-                (\BOUT BACKING-STREAM (CHARCODE 5))
-                (\CLOSEFILE BACKING-STREAM)
-                (fetch (STREAM FULLFILENAME) of HQFX80STREAM])
-)
-
-
-
-(* ;; "methods that hack fonts")
-
-(DEFINEQ
-
-(\HQFX80.FONTCREATE
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)         (* hdj "10-Nov-86 11:30")
-          
-          (* ;; "create a font for the hqfx80")
-
-    (LET [(FONTDESC (create FONTDESCRIPTOR
-                           FONTDEVICE _ DEVICE
-                           FONTFAMILY _ FAMILY
-                           FONTSIZE _ SIZE
-                           FONTFACE _ FACE
-                           \SFAscent _ 0
-                           \SFDescent _ 0
-                           \SFHeight _ 0
-                           ROTATION _ ROTATION
-                           FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE]
-         (AND (\GETCHARSETINFO CHARSET FONTDESC T)
-              FONTDESC])
-
-(\HQFX80.CHANGEFONT
-  [LAMBDA (HQFX80STREAM FONT)                                (* ; "Edited 15-Jul-2025 22:01 by rmk")
-                                                             (* ; "Edited  4-Feb-87 11:48 by hdj")
-
-    (* ;; "sets/returns the font of an HQFX80 imagestream")
-
-    (WITH-HQFX80-DATA
-     (HQFX80DATA HQFX80STREAM)
-     (LET ((OLD-FONT (HQFX80DATA-FONT HQFX80DATA)))
-
-          (* ;; "save old value to return, smash new value and update the record.")
-
-          (PROG1 OLD-FONT
-              [if FONT
-                  then (LET [(NEW-FONT (OR (FONTCREATE FONT NIL NIL NIL HQFX80STREAM T)
-                                           (FONTCOPY (HQFX80DATA-FONT HQFX80DATA)
-                                                  FONT]
-
-                            (* ;; 
-    "updating font information is fairly expensive operation.  Don't bother unless font has changed.")
-
-                            (OR (EQ OLD-FONT NEW-FONT)
-                                (UNINTERRUPTABLY
-                                    (CL:SETF (HQFX80DATA-FONT HQFX80DATA)
-                                           NEW-FONT)
-                                    (CL:SETF (HQFX80DATA-LINEFEED HQFX80DATA)
-                                           (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of NEW-FONT)))
-                                    (\HQFX80.FIX-FONT HQFX80STREAM HQFX80DATA))])])
-
-(\HQFX80.CREATECHARSET
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
-                                                             (* ; "Edited  1-Jun-87 13:08 by Snow")
-
-(* ;;; "Tries to build the csinfo required for CHARSET.  Does the necessary coercions.")
-
-(* ;;; 
-"NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL.")
-
-    (DECLARE (GLOBALVARS HQFX80-FONT-COERCIONS HQFX80-MISSING-FONT-COERCIONS))
-          
-          (* ;; "HQFX80-FONT-COERCIONS is a list of font coercions, in the form ((user-font real-font) (user-font real-font) ...).  Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, (e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a similar list.")
-
-    (PROG (XCSINFO)
-          [SETQ XCSINFO (COND
-                           [(PROGN 
-          
-          (* ;; "Just recursively call ourselves to handle entries in HQFX80-FONT-COERCIONS")
-
-                                   (for TRANSL in HQFX80-FONT-COERCIONS bind NEWCSINFO USRFONT 
-                                                                             REALFONT
-                                      when (AND (SETQ USRFONT (CAR TRANSL))
-                                                (EQ FAMILY (CAR USRFONT))
-                                                (OR (NOT (CADR USRFONT))
-                                                    (EQ SIZE (CADR USRFONT)))
-                                                (OR (NOT (CADDR USRFONT))
-                                                    (EQ CHARSET (CADDR USRFONT)))
-                                                (SETQ REALFONT (CADR TRANSL))
-                                                (SETQ NEWCSINFO (\HQFX80.CREATECHARSET
-                                                                 (OR (CAR REALFONT)
-                                                                     FAMILY)
-                                                                 (OR (CADR REALFONT)
-                                                                     SIZE)
-                                                                 FACE ROTATION DEVICE
-                                                                 (OR (CADDR REALFONT)
-                                                                     CHARSET)
-                                                                 FONTDESC NOSLUG?)))
-                                      do (RETURN NEWCSINFO]
-                           ((AND (EQ ROTATION 0)
-          
-          (* ;; 
-   "If it is available, this will force the appropriate file to be read to fill in the charset entry")
-
-                                 (\HQFX80.READ-FONT-FILE FAMILY SIZE FACE ROTATION 'HQFX80 CHARSET)))
-                           (T 
-          
-          (* ;; "if we get here, the font is not directly available, either it needs to be rotated, boldified, or italicised 'by hand'")
-
-                              (PROG (NEWFONT XFONT XLATEDFAM CSINFO)
-                                    (RETURN (COND
-                                               [(NEQ ROTATION 0)
-          
-          (* ;; "to make a rotated font (even if it is bold or whatnot), recursively call fontcreate to get the unrotated font (maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.")
-
-                                                (OR (MEMB ROTATION '(90 270))
-                                                    (ERROR 
-                                                      "only implemented rotations are 0, 90 and 270." 
-                                                           ROTATION))
-                                                (COND
-                                                   ((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0
-                                                                       'HQFX80 T CHARSET))
-          
-          (* ;; "actually call FONTCREATE here, rather than a device-specific method, so that the vanilla font that is built in this process will be cached and not repeated.")
-
-                                                    (COND
-                                                       ((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T
-                                                                            ))
-                                                        (\SFROTATECSINFO CSINFO ROTATION))
-                                                       (T NIL]
-                                               ((AND (EQ (fetch (FONTFACE WEIGHT) of FACE)
-                                                         'BOLD)
-                                                     (SETQ XFONT
-                                                      (FONTCREATE FAMILY SIZE
-                                                             (create FONTFACE using FACE WEIGHT _
-                                                                                    'MEDIUM)
-                                                             0
-                                                             'HQFX80 T CHARSET)))
-          
-          (* ;; "if we want a bold font, and the medium weight font is available, build the medium weight version then call \SFMAKEBOLD on the csinfo")
-
-                                                (COND
-                                                   ((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
-                                                    (\SFMAKEBOLD CSINFO))
-                                                   (T NIL)))
-                                               ((AND (EQ (fetch (FONTFACE SLOPE) of FACE)
-                                                         'ITALIC)
-                                                     (SETQ XFONT
-                                                      (FONTCREATE FAMILY SIZE
-                                                             (create FONTFACE using FACE SLOPE _
-                                                                                    'REGULAR)
-                                                             0
-                                                             'HQFX80 T CHARSET)))
-                                                (COND
-                                                   ((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
-                                                    (\SFMAKEITALIC CSINFO))
-                                                   (T NIL)))
-                                               ((for TRANSL in HQFX80-MISSING-FONT-COERCIONS
-                                                   bind NEWCSINFO USRFONT REALFONT
-                                                   when (AND (SETQ USRFONT (CAR TRANSL))
-                                                             (EQ FAMILY (CAR USRFONT))
-                                                             (OR (NOT (CADR USRFONT))
-                                                                 (EQ SIZE (CADR USRFONT)))
-                                                             (OR (NOT (CADDR USRFONT))
-                                                                 (EQ CHARSET (CADDR USRFONT)))
-                                                             (SETQ REALFONT (CADR TRANSL))
-                                                             (SETQ NEWCSINFO
-                                                              (\HQFX80.CREATECHARSET
-                                                               (OR (CAR REALFONT)
-                                                                   FAMILY)
-                                                               (OR (CADR REALFONT)
-                                                                   SIZE)
-                                                               FACE ROTATION DEVICE
-                                                               (OR (CADDR REALFONT)
-                                                                   CHARSET)
-                                                               FONTDESC NOSLUG?)))
-                                                   do (RETURN NEWCSINFO)))
-                                               ((NOT NOSLUG?)
-                                                (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR 
-                                                                                FONTAVGCHARWIDTH)
-                                                                     of FONTDESC)
-                                                       (FONTPROP FONTDESC 'ASCENT)
-                                                       (FONTPROP FONTDESC 'DESCENT)
-                                                       (FONTPROP FONTDESC 'DEVICE]
-          (RETURN XCSINFO])
-
-(\HQFX80.CHANGE-CHARSET
-  [LAMBDA (HQFX80DATA CHARSET)                               (* hdj "10-Nov-86 16:00")
-          
-          (* ;; 
-    "Called when the character set information cached in hqfx80 stream doesn't correspond to CHARSET")
-
-    (LET* ((PBT (HQFX80DATA-PILOTBBT HQFX80DATA))
-           (CSINFO (\GETCHARSETINFO CHARSET (HQFX80DATA-FONT HQFX80DATA)))
-           (CHARACTER-BITMAP (ffetch CHARSETBITMAP of CSINFO)))
-          
-          (* ;; "Since we called \GETCHARSETINFO without the NOSLUG?  flag, we presume we will get back a CSINFO , even if it is a slug csinfo")
-
-          (UNINTERRUPTABLY
-              (CL:SETF (HQFX80DATA-WIDTHS-CACHE HQFX80DATA)
-                     (ffetch (CHARSETINFO WIDTHS) of CSINFO))
-              (CL:SETF (HQFX80DATA-OFFSETS-CACHE HQFX80DATA)
-                     (ffetch (CHARSETINFO OFFSETS) of CSINFO))
-              (CL:SETF (HQFX80DATA-IMAGE-WIDTHS-CACHE HQFX80DATA)
-                     (ffetch (CHARSETINFO IMAGEWIDTHS) of CSINFO))
-              (CL:SETF (HQFX80DATA-CHARSET-CACHE HQFX80DATA)
-                     CHARSET)
-              (freplace PBTSOURCEBPL of PBT with (UNFOLD (ffetch (BITMAP BITMAPRASTERWIDTH)
-                                                            of CHARACTER-BITMAP)
-                                                        BITSPERWORD))
-              [IF (OR (NEQ (HQFX80DATA-CHARSET-ASCENT-CACHE HQFX80DATA)
-                           (ffetch CHARSETASCENT of CSINFO))
-                      (NEQ (HQFX80DATA-CHARSET-DESCENT-CACHE HQFX80DATA)
-                           (ffetch CHARSETDESCENT of CSINFO)))
-                  THEN (\HQFX80.FIX-Y HQFX80DATA CSINFO)
-                ELSE (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch (BITMAP BITMAPBASE)
-                                                                  of CHARACTER-BITMAP)
-                                                            (ITIMES (ffetch (BITMAP BITMAPRASTERWIDTH
-                                                                                   ) of 
-                                                                                     CHARACTER-BITMAP
-                                                                           )
-                                                                   (HQFX80DATA-CHARHEIGHTDELTA 
-                                                                          HQFX80DATA])])
-
-(\HQFX80.READ-FONT-FILE
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)         (* ; "Edited  6-Jan-87 17:52 by hdj")
-          
-          (* ;; "Look for new filename convention, then old file name convention, with extensions.  Note we assume \FONTFILENAME calls \FONTFILENAME.NEW")
-
-    (DECLARE (GLOBALVARS HQFX80-FONT-EXTENSIONS HQFX80-FONT-DIRECTORIES))
-    (bind FONTFILE CSINFO STRM for EXT inside HQFX80-FONT-EXTENSIONS
-       when (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET 
-                                  HQFX80-FONT-DIRECTORIES (LIST EXT)))
-       do (SETQ STRM (OPENSTREAM FONTFILE 'INPUT))
-          [RESETLST (SETQ CSINFO (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)
-                                            (SHOULDNT)       (* ; 
-  "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.")
-
-          (RETURN CSINFO])
-
-(\HQFX80.SEARCH-FONTS
-  [LAMBDA (FAMILY SIZE FACE ROTATION)                        (* hdj "10-Nov-86 12:09")
-
-(* ;;; "returns a list of the fonts that can be read in for the hqfx80 device.  (This is the same as all fonts for the dissplay device.)  Rotation is ignored because it is assumed that all devices support 0 90 and 270")
-
-    (DECLARE (GLOBALVARS HQFX80-FONT-EXTENSIONS HQFX80-FONT-DIRECTORIES))
-    (for E FILENAMEPATTERN FONTSFOUND THISFONT THISFACE inside HQFX80-FONT-EXTENSIONS
-       do (SETQ FILENAMEPATTERN (\FONTFILENAME FAMILY SIZE FACE E))
-          [for DIR inside HQFX80-FONT-DIRECTORIES
-             do (for FONTFILE in (DIRECTORY (PACKFILENAME 'DIRECTORY DIR 'BODY FILENAMEPATTERN))
-                   do (OR (MEMBER (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE 'DISPLAY))
-                                 FONTSFOUND)
-                          (COND
-                             ((AND [OR (EQ FACE '*)
-                                       (EQUAL FACE (SETQ THISFACE (CADDR THISFONT)))
-                                       (AND (OR (EQ (CAR FACE)
-                                                    '*)
-                                                (EQ (CAR FACE)
-                                                    (CAR THISFACE)))
-                                            (OR (EQ (CADR FACE)
-                                                    '*)
-                                                (EQ (CADR FACE)
-                                                    (CADR THISFACE)))
-                                            (OR (EQ (CADR FACE)
-                                                    '*)
-                                                (EQ (CADR FACE)
-                                                    (CADR THISFACE]
-                                   (OR (EQ FAMILY '*)
-                                       (EQ FAMILY (CAR THISFONT))
-                                       (STRPOS "*" FAMILY)))
-          
-          (* ;; "make sure the face, size, and family really match.  Family name match allows anything if the family has a * in it.  This is wrong but better than what was there before which let in anything with the right beginning.")
-
-                              (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND] finally (RETURN FONTSFOUND])
-)
-
-(CL:DEFUN \HQFX80.INIT-FONT-PROFILE ()
-
-   (* ;; "set up the fonts for the HQFX80, based on the DISPLAY font profile entries")
-
-   [FOR FONT-CLASS IN '(DEFAULTFONT ITALICFONT BOLDFONT LITTLEFONT TINYFONT BIGFONT COMMENTFONT 
-                              TEXTFONT) DO (\ADD-TO-FONTPROFILE FONTPROFILE FONT-CLASS 'HQFX80
-                                                  (\GET-FROM-FONTPROFILE FONTPROFILE FONT-CLASS
-                                                         'DISPLAY]
-   (FONTPROFILE FONTPROFILE)
-   T)
-
-
-
-(* ;; "methods for measuring")
-
-(DEFINEQ
-
-(\HQFX80.CHARWIDTH
-  [LAMBDA (HQFX80STREAM CHARCODE)                            (* ; "Edited  4-Feb-87 13:20 by hdj")
-          
-          (* ;; 
-  "gets the width of the rendering of charcode on an hqfx80 image stream.  We treat space specially.")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (LET ((WIDTH (\FGETCHARWIDTH (HQFX80DATA-FONT DATA)
-                               CHARCODE)))
-                (if (EQ CHARCODE (CHARCODE SPACE))
-                    then (FIXR (TIMES WIDTH (HQFX80DATA-SPACEWIDTH DATA)))
-                  else WIDTH])
-
-(\HQFX80.STRINGWIDTH
-  [LAMBDA (HQFX80STREAM STRING RDTBL)                        (* ; "Edited  3-Feb-87 17:36 by hdj")
-          
-          (* ;; 
-          " returns STRING's width, relative to HQFX80STREAM's current font and the readtable RDTBL")
-
-    (IF RDTBL
-        THEN (BIND (FIRSTFLG _ T)
-                   (SA _ (FETCH READSA OF RDTBL))
-                   (ESCAPE-CHAR-WIDTH _ (\HQFX80.CHARWIDTH HQFX80STREAM (FETCH (READTABLEP ESCAPECHAR
-                                                                                      ) OF RDTBL)))
-                   (SYN _ NIL) FOR CHARCODE INSTRING STRING
-                SUM (PROG1 (IPLUS (COND
-                                     ((AND (FETCH (READCODE ESCQUOTE) OF (SETQ SYN (\SYNCODE SA 
-                                                                                          CHARCODE)))
-                                           (OR FIRSTFLG (FETCH (READCODE INNERESCQUOTE) OF SYN)))
-                                      ESCAPE-CHAR-WIDTH)
-                                     (T 0))
-                                  (\FASTFX80.CHARWIDTH HQFX80STREAM CHARCODE))
-                           (SETQ FIRSTFLG NIL)))
-      ELSE (FOR CHAR INSTRING STRING SUM (\HQFX80.CHARWIDTH HQFX80STREAM CHAR])
-)
-
-(CL:DEFUN \HQFX80.SPACEFACTOR (HQFX80STREAM FACTOR)
-
-   (* ;; "returns/sets the width of the space character (32 ASCII) for HQFX80STREAM")
-
-   [WITH-HQFX80-DATA (DATA HQFX80STREAM)
-          (PROG1 (HQFX80DATA-SPACEWIDTH DATA)
-              (AND FACTOR (IF (NUMBERP FACTOR)
-                              THEN (CL:SETF (HQFX80DATA-SPACEWIDTH DATA)
-                                          FACTOR)
-                            ELSE (\ILLEGAL.ARG FACTOR))))])
-
-
-
-(* ;; "methods that affect the current position/size of drawing surface")
-
-(DEFINEQ
-
-(\HQFX80.CLIPPINGREGION
-  [LAMBDA (HQFX80STREAM REGION)                              (* ; "Edited  8-Dec-86 14:04 by hdj")
-          
-          (* ;; "sets the clipping region of an HQFX80 image stream.  do not allow it to exceed the confines of the bitmap.")
-
-    (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM)
-           (PROG1 (COPY (HQFX80DATA-CLIPPINGREGION HQFX80DATA))
-                                                             (* ; 
-                                                            "copy so it can't be side-effected later")
-                  (LET ((BACKING (HQFX80DATA-BACKINGBITMAP HQFX80DATA)))
-                       (AND REGION (OR (type? REGION REGION)
-                                       (ERROR REGION " is not a REGION."))
-                            (UNINTERRUPTABLY
-                                (CL:SETF (HQFX80DATA-CLIPPINGREGION HQFX80DATA)
-                                       (INTERSECTREGIONS (CREATEREGION 0 0 (BITMAPWIDTH BACKING)
-                                                                (BITMAPHEIGHT BACKING))
-                                              REGION))
-                                (\HQFX80.INVALIDATE-FONT-CACHE HQFX80DATA))])
-
-(\HQFX80.LEFTMARGIN
-  [LAMBDA (HQFX80STREAM XPOSITION)                           (* ; "Edited  3-Feb-87 17:11 by hdj")
-          
-          (* ;; "sets/returns the position that a carriage return returns to for an hqfx80stream")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (PROG1 (HQFX80DATA-LEFTMARGIN DATA)
-                  (AND XPOSITION (if (SMALLP XPOSITION)
-                                     then (UNINTERRUPTABLY
-                                              (CL:SETF (HQFX80DATA-LEFTMARGIN DATA)
-                                                     XPOSITION)
-                                              (\HQFX80.FIX-LINE-LENGTH HQFX80STREAM))
-                                   else (\ILLEGAL.ARG XPOSITION])
-
-(\HQFX80.RIGHTMARGIN
-  [LAMBDA (HQFX80STREAM XPOSITION)                           (* ; "Edited 10-Dec-86 18:17 by hdj")
-          
-          (* ;; "Sets the right margin of an HQFX80STREAM")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (PROG1 (HQFX80DATA-RIGHTMARGIN DATA)
-                  (AND XPOSITION (IF (SMALLP XPOSITION)
-                                     THEN (UNINTERRUPTABLY
-                                              (CL:SETF (HQFX80DATA-RIGHTMARGIN DATA)
-                                                     XPOSITION)
-                                              (\HQFX80.FIX-LINE-LENGTH HQFX80STREAM))
-                                   ELSE (\ILLEGAL.ARG XPOSITION])
-
-(\HQFX80.TOPMARGIN
-  [LAMBDA (HQFX80STREAM YPOSITION)                           (* ; "Edited 10-Dec-86 18:16 by hdj")
-          
-          (* ;; "Sets the top margin of an hqfx80stream")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (PROG1 (HQFX80DATA-TOPMARGIN DATA)
-                  (AND YPOSITION (IF (SMALLP YPOSITION)
-                                     THEN (CL:SETF (HQFX80DATA-TOPMARGIN DATA)
-                                                 YPOSITION)
-                                   ELSE (\ILLEGAL.ARG YPOSITION])
-
-(\HQFX80.BOTTOMMARGIN
-  [LAMBDA (HQFX80STREAM YPOSITION)                           (* ; "Edited 10-Dec-86 18:17 by hdj")
-          
-          (* ;; "Sets the bottom margin of an HQFX80STREAM")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (PROG1 (HQFX80DATA-BOTTOMMARGIN DATA)
-                  (AND YPOSITION (IF (SMALLP YPOSITION)
-                                     THEN (CL:SETF (HQFX80DATA-BOTTOMMARGIN DATA)
-                                                 YPOSITION)
-                                   ELSE (\ILLEGAL.ARG YPOSITION])
-
-(\HQFX80.XPOSITION
-  [LAMBDA (HQFX80STREAM XPOSITION)                           (* hdj " 3-Nov-86 15:14")
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (PROG1 (HQFX80DATA-XPOS DATA)
-                  (AND XPOSITION (IF (NUMBERP XPOSITION)
-                                     THEN (CL:SETF (HQFX80DATA-XPOS DATA)
-                                                 XPOSITION)
-                                   ELSE (\ILLEGAL.ARG XPOSITION])
-
-(\HQFX80.YPOSITION
-  [LAMBDA (HQFX80STREAM YPOSITION)                           (* ; "Edited  5-Jan-87 17:25 by hdj")
-          
-          (* ;; "set the y-pos of an HQFX80STREAM")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (PROG1 (HQFX80DATA-YPOS DATA)
-                  (AND YPOSITION (if (NUMBERP YPOSITION)
-                                     then (UNINTERRUPTABLY
-                                              (CL:SETF (HQFX80DATA-YPOS DATA)
-                                                     YPOSITION)
-                                              (\HQFX80.INVALIDATE-CACHE DATA))
-                                   else (\ILLEGAL.ARG YPOSITION])
-
-(\HQFX80.NEWLINE
-  [LAMBDA (CHARCODE HQFX80STREAM)                            (* hdj "14-Nov-86 17:44")
-          
-          (* ;; 
-          "CODE is EOL, CR, or LF. Performs the appropriate printing operation on hqfx80stream.")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (LET [(NEW-Y (+ (HQFX80DATA-YPOS DATA)
-                           (HQFX80DATA-LINEFEED DATA]
-                (if (< NEW-Y (HQFX80DATA-BOTTOMMARGIN DATA))
-                    then 
-          
-          (* ;; 
-    "we're below the bottom margin, so eject the page.  If this was a LF, restore the old x-position")
-
-                         (LET ((OLD-X (HQFX80DATA-XPOS DATA)))
-                              (\HQFX80.NEWPAGE HQFX80STREAM)
-                              (if (EQ CHARCODE (CHARCODE LF))
-                                  then (\HQFX80.XPOSITION HQFX80STREAM OLD-X)))
-                  else 
-          
-          (* ;; "just decrement the y coord")
-
-                       (\HQFX80.YPOSITION HQFX80STREAM NEW-Y) 
-          
-          (* ;; "if this was a CR or EOL, set the x-position too.")
-
-                       (if (NEQ CHARCODE (CHARCODE LF))
-                           then (\HQFX80.XPOSITION HQFX80STREAM (HQFX80DATA-LEFTMARGIN DATA))
-                                (freplace (STREAM CHARPOSITION) of HQFX80STREAM with 0])
-
-(\HQFX80.NEWPAGE
-  [LAMBDA (HQFX80STREAM)                                     (* ; "Edited  8-Dec-86 15:18 by hdj")
-          
-          (* ;; "end an HQFX80 page")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (\HQFX80.DUMP-PAGE-BUFFER (HQFX80DATA-BACKINGBITMAP DATA)
-                  HQFX80STREAM)
-          
-          (* ;; "start a new page")
-
-           (\HQFX80.STARTPAGE HQFX80STREAM])
-
-(\HQFX80.LINEFEED
-  [LAMBDA (HQFX80STREAM DELTAY)                              (* hdj " 3-Nov-86 14:58")
-          
-          (* ;; "Sets the linefeed distance for an HQFX80 stream")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (PROG1 (HQFX80DATA-LINEFEED DATA)
-                  (AND DELTAY (IF (NUMBERP DELTAY)
-                                  THEN (CL:SETF (HQFX80DATA-LINEFEED DATA)
-                                              DELTAY)
-                                ELSE (\ILLEGAL.ARG DELTAY])
-
-(\HQFX80.RESET
-  [LAMBDA (HQFX80STREAM)                                     (* hdj " 4-Nov-86 15:35")
-          
-          (* ;; "resets an hqfx80 image stream to a virgin state")
-
-    (\HQFX80.STARTPAGE HQFX80STREAM])
-
-(\HQFX80.STARTPAGE
-  [LAMBDA (HQFX80STREAM)                                     (* ; "Edited 18-Dec-86 15:25 by hdj")
-          
-          (* ;; "start a new page for an HQFX80 imagestream")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (LET* ((CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA))
-                  (FONT (HQFX80DATA-FONT DATA))
-                  (FONT-ASCENT (FONTASCENT FONT)))
-          
-          (* ;; "first clear the backing bitmap...")
-
-                 (BLTSHADE (HQFX80DATA-TEXTURE DATA)
-                        (HQFX80DATA-BACKINGBITMAP DATA)
-                        NIL NIL NIL NIL 'REPLACE)
-          
-          (* ;; "... and then reset the current position")
-
-                 (\HQFX80.XPOSITION HQFX80STREAM (HQFX80DATA-LEFTMARGIN DATA))
-                 (\HQFX80.YPOSITION HQFX80STREAM (ADD1 (- (HQFX80DATA-TOPMARGIN DATA)
-                                                          FONT-ASCENT])
-)
-
-(DEFMACRO \HQFX80.CUR-POS-VISIBLE? (HQFX80DATA)
-   `(INSIDEP (HQFX80DATA-CLIPPINGREGION ,HQFX80DATA)
-           (HQFX80DATA-XPOS ,HQFX80DATA)
-           (HQFX80DATA-YPOS ,HQFX80DATA)))
-
-
-
-(* ;; "graphical operations")
-
-(DECLARE%: EVAL@COMPILE 
-
-[PUTDEF '\HQFX80.BRUSHBBT 'RESOURCES '(NEW (CREATE PILOTBBT]
-)
-(DEFINEQ
-
-(\HQFX80.BITBLT
-  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM HQFX80STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH 
-                 HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
-                 CLIPPEDSOURCEBOTTOM)                        (* ; "Edited  1-Jun-87 13:07 by Snow")
-
-(* ;;; "BITBLT onto the HQFX80 page")
-
-(* ;;; "")
-
-    (DECLARE (LOCALVARS . T))
-    (COND
-       ((NEQ 1 (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP))
-          
-          (* ;; "going from color bitmap into black and white bitmap.")
-
-        (ERROR "Cannot BitBLT a color bitmap onto the FX-80 page")))
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (PROG (SOURCE-TO-DEST-X SOURCE-TO-DEST-Y LEFT TOP BOTTOM RIGHT DESTBITMAP)
-                 (SETQ DESTBITMAP (HQFX80DATA-BACKINGBITMAP DATA))
-                 [LET ((FXCLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA)))
-          
-          (* ;; "compute limits based on clipping regions.")
-
-                      (SETQ LEFT (fetch (REGION LEFT) of FXCLIPPINGREGION))
-                      (SETQ BOTTOM (fetch (REGION BOTTOM) of FXCLIPPINGREGION))
-                      (SETQ RIGHT (fetch (REGION RIGHT) of FXCLIPPINGREGION))
-                      (SETQ TOP (fetch (REGION TOP) of FXCLIPPINGREGION))
-                      (COND
-                         (CLIPPINGREGION 
-          
-          (* ;; "hard case, two destination clipping regions: do calculations to merge them.")
-
-                                (PROG (CRLEFT CRBOTTOM)
-                                      [SETQ LEFT (IMAX LEFT (SETQ CRLEFT (fetch (REGION LEFT)
-                                                                            of CLIPPINGREGION]
-                                      [SETQ BOTTOM (IMAX BOTTOM (SETQ CRBOTTOM (fetch (REGION BOTTOM)
-                                                                                  of CLIPPINGREGION]
-                                      [SETQ RIGHT (IMIN RIGHT (IPLUS CRLEFT (fetch (REGION WIDTH)
-                                                                               of CLIPPINGREGION]
-                                      (SETQ TOP (IMIN TOP (IPLUS CRBOTTOM (fetch (REGION HEIGHT)
-                                                                             of CLIPPINGREGION]
-          
-          (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions.  Clip to region in the arguments of this call.")
-
-                 (PROGN (SETQ LEFT (IMAX DESTINATIONLEFT LEFT))
-                        (SETQ BOTTOM (IMAX DESTINATIONBOTTOM BOTTOM))
-                        (AND WIDTH (SETQ RIGHT (IMIN (IPLUS DESTINATIONLEFT WIDTH)
-                                                     RIGHT)))(* ; "WIDTH is optional")
-
-                        (AND HEIGHT (SETQ TOP (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
-                                                    TOP)))   (* ; "HEIGHT is optional")
-
-                        )                                    (* ; "Clip and translate coordinates.")
-
-                 (SETQ SOURCE-TO-DEST-X (IDIFFERENCE DESTINATIONLEFT SOURCELEFT))
-                 (SETQ SOURCE-TO-DEST-Y (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM))
-          
-          (* ;; "compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be moved with the limits of the region to be moved in the destination coordinates.")
-
-                 [PROGN                                      (* ; "compute left margin")
-
-                        (SETQ LEFT (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE LEFT SOURCE-TO-DEST-X)
-                                         0))                 (* ; "compute bottom margin")
-
-                        (SETQ BOTTOM (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE BOTTOM SOURCE-TO-DEST-Y)
-                                           0))
-                        [PROGN                               (* ; "compute right margin")
-
-                               (SETQ RIGHT (IMIN (ffetch (BITMAP BITMAPWIDTH) of SOURCEBITMAP)
-                                                 (IDIFFERENCE RIGHT SOURCE-TO-DEST-X)
-                                                 (IPLUS CLIPPEDSOURCELEFT WIDTH]
-                        (PROGN                               (* ; "compute top margin")
-
-                               (SETQ TOP (IMIN (ffetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP)
-                                               (IDIFFERENCE TOP SOURCE-TO-DEST-Y)
-                                               (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT]
-                 (COND
-                    ((OR (ILEQ RIGHT LEFT)
-                         (ILEQ TOP BOTTOM))                  (* ; "there is nothing to move.")
-
-                     (RETURN)))
-                 (OR OPERATION (SETQ OPERATION (HQFX80DATA-OPERATION DATA)))
-                 (SELECTQ SOURCETYPE
-                     (MERGE                                  (* ; "Need to use complement of TEXTURE")
-
-                            [SETQ TEXTURE (COND
-                                             ((NULL TEXTURE)
-                                              BLACKSHADE)
-                                             ((FIXP TEXTURE)
-                                              (LOGXOR (LOGAND TEXTURE BLACKSHADE)
-                                                     BLACKSHADE))
-                                             [(type? BITMAP TEXTURE)
-                                              (INVERT.TEXTURE.BITMAP TEXTURE
-                                                     (OR \BBSCRATCHTEXTURE (SETQ \BBSCRATCHTEXTURE
-                                                                            (BITMAPCREATE 16 16]
-                                             (T (\ILLEGAL.ARG TEXTURE])
-                     NIL)
-                 (UNINTERRUPTABLY
-                     [PROG ([PILOTBBT (COND
-                                         ((type? PILOTBBT \SYSPILOTBBT)
-                                          \SYSPILOTBBT)
-                                         (T (SETQ \SYSPILOTBBT (create PILOTBBT]
-                            (HEIGHT (IDIFFERENCE TOP BOTTOM))
-                            (WIDTH (IDIFFERENCE RIGHT LEFT))
-                            (DTY (\SFInvert DESTBITMAP (IPLUS TOP SOURCE-TO-DEST-Y)))
-                            (DLX (IPLUS LEFT SOURCE-TO-DEST-X))
-                            (STY (\SFInvert SOURCEBITMAP TOP))
-                            (SLX LEFT))
-                           (replace PBTWIDTH of PILOTBBT with WIDTH)
-                           (replace PBTHEIGHT of PILOTBBT with HEIGHT)
-                           (COND
-                              ((EQ SOURCETYPE 'MERGE)
-                               (\BITBLT.MERGE PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH 
-                                      HEIGHT OPERATION TEXTURE))
-                              (T (\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT 
-                                        SOURCETYPE OPERATION TEXTURE])
-                 (RETURN T])
-
-(\HQFX80.BLTSHADE
-  [LAMBDA (TEXTURE HQFX80STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION 
-                 CLIPPINGREGION)                             (* ; "Edited  1-Jun-87 13:05 by Snow")
-          
-          (* ;; "BLTSHADE to an HQFX80 imagestream")
-
-    (DECLARE (LOCALVARS . T))
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (PROG (LEFT TOP BOTTOM RIGHT DESTINATIONBITMAP)
-          
-          (* ;; "compute limits based on clipping regions.")
-
-                 (LET ((FXCLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA)))
-                      (SETQ LEFT (fetch (REGION LEFT) of FXCLIPPINGREGION))
-                      (SETQ BOTTOM (fetch (REGION BOTTOM) of FXCLIPPINGREGION))
-                      (SETQ RIGHT (fetch (REGION RIGHT) of FXCLIPPINGREGION))
-                      (SETQ TOP (fetch (REGION TOP) of FXCLIPPINGREGION)))
-                 [COND
-                    (CLIPPINGREGION 
-          
-          (* ;; "hard case, two destination clipping regions: do calculations to merge them.")
-
-                           (PROG (CRLEFT CRBOTTOM)
-                                 [SETQ LEFT (IMAX LEFT (SETQ CRLEFT (fetch (REGION LEFT) of 
-                                                                                       CLIPPINGREGION
-                                                                           ]
-                                 [SETQ BOTTOM (IMAX BOTTOM (SETQ CRBOTTOM (fetch (REGION BOTTOM)
-                                                                             of CLIPPINGREGION]
-                                 [SETQ RIGHT (IMIN RIGHT (IPLUS CRLEFT (fetch (REGION WIDTH)
-                                                                          of CLIPPINGREGION]
-                                 (SETQ TOP (IMIN TOP (IPLUS CRBOTTOM (fetch (REGION HEIGHT)
-                                                                        of CLIPPINGREGION]
-                 (SETQ DESTINATIONBITMAP (HQFX80DATA-BACKINGBITMAP DATA))
-          
-          (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions.  Clip to region in the arguments of this call.")
-
-                 (SETQ LEFT (IMAX DESTINATIONLEFT LEFT))
-                 (SETQ BOTTOM (IMAX DESTINATIONBOTTOM BOTTOM))
-                 (AND WIDTH (SETQ RIGHT (IMIN (IPLUS DESTINATIONLEFT WIDTH)
-                                              RIGHT)))       (* ; "WIDTH is optional")
-
-                 (AND HEIGHT (SETQ TOP (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
-                                             TOP)))          (* ; "HEIGHT is optional")
-
-                 (COND
-                    ((AND (IGREATERP RIGHT LEFT)
-                          (IGREATERP TOP BOTTOM)))
-                    (T                                       (* ; "there is nothing to move.")
-
-                       (RETURN NIL)))
-                 (CL:ETYPECASE TEXTURE [LITATOM              (* ; "includes NIL case")
-
-                                              (COND
-                                                 ((NULL TEXTURE)
-                                                             (* ; 
-                                                             "default texture to background texture.")
-
-                                                  (SETQ TEXTURE (HQFX80DATA-TEXTURE DATA)))
-                                                 (T (\ILLEGAL.ARG TEXTURE]
-                        (SMALLP (SETQ TEXTURE (LOGAND TEXTURE BLACKSHADE)))
-                        (FIXP (SETQ TEXTURE (LOGAND TEXTURE BLACKSHADE)))
-                        (BITMAP NIL))
-                 (UNINTERRUPTABLY
-                     (LET ([PILOTBBT (IF (type? PILOTBBT \SYSPILOTBBT)
-                                         THEN \SYSPILOTBBT
-                                       ELSE (SETQ \SYSPILOTBBT (create PILOTBBT]
-                           (HEIGHT (IDIFFERENCE TOP BOTTOM)))
-                          (replace PBTWIDTH of PILOTBBT with (IDIFFERENCE RIGHT LEFT))
-                          (replace PBTHEIGHT of PILOTBBT with HEIGHT)
-                          (\BITBLTSUB PILOTBBT NIL LEFT NIL DESTINATIONBITMAP LEFT (\SFInvert 
-                                                                                    DESTINATIONBITMAP 
-                                                                                          TOP)
-                                 HEIGHT
-                                 'TEXTURE
-                                 (OR OPERATION (HQFX80DATA-OPERATION DATA))
-                                 TEXTURE)))
-                 (RETURN T])
-
-(\HQFX80.DRAWELLIPSE
-  [LAMBDA (HQFX80STREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING)
-                                                             (* ; "Edited 12-Feb-87 14:37 by jds")
-    (DECLARE (LOCALVARS . T))
-          
-          (* ;; "Draws an ellipse.  At ORIENTATION 0, the semimajor axis is horizontal, the semiminor axis vertical.  Orientation is positive in the counterclockwise direction.  The current location in the stream is left at the center of the ellipse.")
-
-    (PROG ((CENTERX (FIXR CENTERX))
-           (CENTERY (FIXR CENTERY))
-           (SEMIMINORRADIUS (FIXR SEMIMINORRADIUS))
-           (SEMIMAJORRADIUS (FIXR SEMIMAJORRADIUS)))
-          (COND
-             ((OR (EQ 0 SEMIMINORRADIUS)
-                  (EQ 0 SEMIMAJORRADIUS))
-              (MOVETO CENTERX CENTERY HQFX80STREAM)
-              (RETURN)))
-          (COND
-             ((ILESSP SEMIMINORRADIUS 1)
-              (\ILLEGAL.ARG SEMIMINORRADIUS))
-             ((ILESSP SEMIMAJORRADIUS 1)
-              (\ILLEGAL.ARG SEMIMAJORRADIUS))
-             ((OR (NULL ORIENTATION)
-                  (EQ SEMIMINORRADIUS SEMIMAJORRADIUS))
-              (SETQ ORIENTATION 0))
-             ((NULL (NUMBERP ORIENTATION))
-              (\ILLEGAL.ARG ORIENTATION)))
-          
-          (* ;; "This function is the implementation of the algorithm given in 'Algorithm for drawing ellipses or hyperbolae with a digital plotter' by Pitteway appearing in Computer Journal 10: (3) Nov 1967. The input parameters are used to determine the ellipse equation (1/8) Ayy+ (1/8) Bxx+ (1/4) Gxy+ (1/4) Ux+ (1/4) Vy= (1/4) K which specifies a translated version of the desired ellipse.  This ellipse passes through the mesh point (0,0), the initial point of the algorithm.  The power of 2 factors reflect an implementation convenience.")
-
-          (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM)
-                 (GLOBALRESOURCE \HQFX80.BRUSHBBT
-                        (PROG (DESTINATION-BITMAP LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH 
-                                     TOPMINUSBRUSH LEFTMINUSBRUSH DESTINATIONBASE BRUSHBASE 
-                                     BRUSHHEIGHT BRUSHWIDTH RASTERWIDTH BRUSHRASTERWIDTH BRUSHBM 
-                                     OPERATION HEIGHTMINUS1 (BBT \HQFX80.BRUSHBBT)
-                                     (COS-ORIENTATION (COS ORIENTATION))
-                                     (SIN-ORIENTATION (SIN ORIENTATION))
-                                     (SEMIMINORRADIUSSQUARED (ITIMES SEMIMINORRADIUS SEMIMINORRADIUS)
-                                            )
-                                     (SEMIMAJORRADIUSSQUARED (ITIMES SEMIMAJORRADIUS SEMIMAJORRADIUS)
-                                            )
-                                     (x 0)
-                                     (y 0)
-                                     (x2 1)
-                                     x1 y1 y2 k1 k2 k3 a b d w A B G U V K CX CY yOffset CYPlusOffset 
-                                     CYMinusOffset (USERFN (AND (LITATOM BRUSH)
-                                                                BRUSH)))
-                              [COND
-                                 (USERFN                     (* ; 
-                                                       "if calling user fn, don't bother with set up")
-                                        (SETQ CX CENTERX)
-                                        (SETQ CY CENTERY))
-                                 (T (.SETUP.FOR.\HQFX80.BBTCURVEPT. HQFX80DATA)
-                                                             (* ; 
-                                                             "take into account the brush thickness.")
-                                    (SETQ CX (- CENTERX (FOLDLO BRUSHWIDTH 2)))
-                                    (SETQ CY (- CENTERY (FOLDLO BRUSHHEIGHT 2]
-                              (SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED COS-ORIENTATION 
-                                                    COS-ORIENTATION)
-                                             (FTIMES SEMIMINORRADIUSSQUARED SIN-ORIENTATION 
-                                                    SIN-ORIENTATION)))
-                              (SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED 
-                                                               COS-ORIENTATION COS-ORIENTATION)
-                                                        (FTIMES SEMIMAJORRADIUSSQUARED 
-                                                               SIN-ORIENTATION SIN-ORIENTATION)))
-                                           3))
-                              (SETQ G (FTIMES COS-ORIENTATION SIN-ORIENTATION (LSH (- 
-                                                                               SEMIMINORRADIUSSQUARED 
-                                                                               SEMIMAJORRADIUSSQUARED
-                                                                                      )
-                                                                                   1)))
-                              [SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS SEMIMAJORRADIUS)
-                                                         (SQRT A]
-                              (SETQ CYPlusOffset (+ CY yOffset))
-                              (SETQ CYMinusOffset (- CY yOffset))
-                              (SETQ U (LSH (FIXR (FTIMES A (LSH yOffset 1)))
-                                           2))
-                              (SETQ V (LSH (FIXR (FTIMES G yOffset))
-                                           2))
-                              (SETQ K (LSH [FIXR (FDIFFERENCE (ITIMES SEMIMINORRADIUSSQUARED 
-                                                                     SEMIMAJORRADIUSSQUARED)
-                                                        (FTIMES A (ITIMES yOffset yOffset]
-                                           2))
-                              (SETQ A (LSH (FIXR A)
-                                           3))
-                              (SETQ G (LSH (FIXR G)
-                                           2))
-          
-          (* ;; "The algorithm is incremental and iterates through the octants of a cartesian plane.  The octants are labeled from 1 through 8 beginning above the positive X axis and proceeding counterclockwise.  Decisions in making the incremental steps are determined according to the error term d which is updated according to the curvature terms a and b.  k1, k2, and k3 are used to correct the error and curvature terms at octant boundaries.  The initial values of these terms depends on the octant in which drawing begins.  The initial move steps (x1,y1) and (x2,y2) also depend on the starting octant.")
-
-                              [COND
-                                 [(ILESSP (ABS U)
-                                         (ABS V))
-                                  (SETQ x1 0)
-                                  (COND
-                                     [(MINUSP V)             (* ; "start in octant 2")
-                                      (SETQ y1 1)
-                                      (SETQ y2 1)
-                                      (SETQ k1 (IMINUS A))
-                                      (SETQ k2 (- k1 G))
-                                      (SETQ k3 (- k2 (+ B G)))
-                                      (SETQ b (+ U (RSH (+ A G)
-                                                        1)))
-                                      (SETQ a (IMINUS (+ b V)))
-                                      (SETQ d (+ b (RSH B 3)
-                                                 (RSH V 1)
-                                                 (IMINUS K]
-                                     (T                      (* ; "start in octant 7")
-                                        (SETQ y1 -1)
-                                        (SETQ y2 -1)
-                                        (SETQ k1 A)
-                                        (SETQ k2 (- k1 G))
-                                        (SETQ k3 (+ k2 B (IMINUS G)))
-                                        (SETQ b (+ U (RSH (- G A)
-                                                          1)))
-                                        (SETQ a (- V b))
-                                        (SETQ d (+ b K (IMINUS (+ (RSH V 1)
-                                                                  (RSH B 3]
-                                 (T (SETQ x1 1)
-                                    (SETQ y1 0)
-                                    (COND
-                                       [(MINUSP V)           (* ; "start in octant 1")
-                                        (SETQ y2 1)
-                                        (SETQ k1 B)
-                                        (SETQ k2 (+ k1 G))
-                                        (SETQ k3 (+ k2 A G))
-                                        [SETQ b (IMINUS (+ V (RSH (+ B G)
-                                                                  1]
-                                        (SETQ a (- U b))
-                                        (SETQ d (+ b K (IMINUS (+ (RSH A 3)
-                                                                  (RSH U 1]
-                                       (T                    (* ; "start in octant 8")
-                                          (SETQ y2 -1)
-                                          (SETQ k1 (IMINUS B))
-                                          (SETQ k2 (+ k1 G))
-                                          (SETQ k3 (+ k2 G (IMINUS A)))
-                                          (SETQ b (+ V (RSH (- B G)
-                                                            1)))
-                                          (SETQ a (- U b))
-                                          (SETQ d (+ b (RSH A 3)
-                                                     (IMINUS (+ K (RSH U 1]
-          
-          (* ;; "The ellipse equation describes an ellipse of the desired size and ORIENTATION centered at (0,0) and then dropped yOffset mesh points so that it will pass through (0,0).  Thus, the intended starting point is (CX, CY+yOffset) where (CX, CY) is the center of the desired ellipse.  Drawing is accomplished with point relative steps.  In each octant, the error term d is used to choose between move 1 (an axis move) and move 2 (a diagonal move).")
-
-                          MOVE
-                              [COND
-                                 ((MINUSP d)                 (* ; "move 1")
-                                  (SETQ x (+ x x1))
-                                  (SETQ y (+ y y1))
-                                  (SETQ b (- b k1))
-                                  (SETQ a (+ a k2))
-                                  (SETQ d (+ b d)))
-                                 (T                          (* ; "move 2")
-                                    (SETQ x (+ x x2))
-                                    (SETQ y (+ y y2))
-                                    (SETQ b (- b k2))
-                                    (SETQ a (+ a k3))
-                                    (SETQ d (- d a]
-                              (COND
-                                 ((MINUSP x)
-                                  (MOVETO CENTERX CENTERY HQFX80STREAM)
-                                  (RETURN NIL)))
-                              [COND
-                                 (USERFN (APPLY* USERFN (+ CX x)
-                                                (+ CYPlusOffset y)
-                                                HQFX80STREAM)
-                                        (APPLY* USERFN (- CX x)
-                                               (- CYMinusOffset y)
-                                               HQFX80STREAM))
-                                 (T (\HQFX80.CURVEPT (+ CX x)
-                                           (+ CYPlusOffset y))
-                                    (\HQFX80.CURVEPT (- CX x)
-                                           (- CYMinusOffset y]
-                              (AND (MINUSP b)
-                                   (GO SQUARE))
-                          DIAGONAL
-                              (OR (MINUSP a)
-                                  (GO MOVE))                 (* ; "diagonal octant change")
-                              (SETQ x1 (- x2 x1))
-                              (SETQ y1 (- y2 y1))
-                              (SETQ w (- (LSH k2 1)
-                                         k3))
-                              (SETQ k1 (- w k1))
-                              (SETQ k2 (- k2 k3))
-                              (SETQ k3 (IMINUS k3))
-                              [SETQ b (+ b a (IMINUS (RSH (ADD1 k2)
-                                                          1]
-                              [SETQ d (+ b (RSH (+ k3 4)
-                                                3)
-                                         (IMINUS d)
-                                         (IMINUS (RSH (ADD1 a)
-                                                      1]
-                              (SETQ a (- (RSH (ADD1 w)
-                                              1)
-                                         a))
-                              (OR (MINUSP b)
-                                  (GO MOVE))
-                          SQUARE
-                                                             (* ; "square octant change")
-                              [COND
-                                 ((EQ 0 x1)
-                                  (SETQ x2 (IMINUS x2)))
-                                 (T (SETQ y2 (IMINUS y2]
-                              (SETQ w (- k2 k1))
-                              (SETQ k1 (IMINUS k1))
-                              (SETQ k2 (+ w k1))
-                              (SETQ k3 (- (LSH w 2)
-                                          k3))
-                              (SETQ b (- (IMINUS b)
-                                         w))
-                              (SETQ d (- (- b a)
-                                         d))
-                              (SETQ a (- (- a w)
-                                         (LSH b 1)))
-                              (GO DIAGONAL])
-
-(\HQFX80.OPERATION
-  [LAMBDA (HQFX80STREAM OPERATION)                           (* hdj " 4-Nov-86 17:25")
-          
-          (* ;; "sets the operation field of an hqfx80 stream")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (PROG1 (HQFX80DATA-OPERATION DATA)
-                  (AND OPERATION (OR (FMEMB OPERATION '(PAINT REPLACE INVERT ERASE))
-                                     (\ILLEGAL.ARG OPERATION))
-                       (UNINTERRUPTABLY
-                           (CL:SETF (HQFX80DATA-OPERATION DATA)
-                                  OPERATION)                 (* ; 
-                                                      "update other fields that depend on operation.")
-                           (\SETPBTFUNCTION (HQFX80DATA-PILOTBBT DATA)
-                                  (HQFX80DATA-SOURCETYPE DATA)
-                                  OPERATION))])
-
-(\HQFX80.DRAWPOINT
-  [LAMBDA (HQFX80STREAM X Y BRUSH OPERATION)                 (* hdj "19-Nov-86 15:21")
-          
-          (* ;; "draws a brush point at position X Y on an HQFX80STREAM")
-
-    (LET ((BRUSHBM (\GETBRUSH BRUSH)))                       (* ; 
-                                         "SUB1 is to put extra bit of even brush on the top or left.")
-         (BITBLT BRUSHBM 0 0 HQFX80STREAM [IDIFFERENCE X (HALF (SUB1 (BITMAPWIDTH BRUSHBM]
-                [IDIFFERENCE Y (HALF (SUB1 (BITMAPHEIGHT BRUSHBM]
-                NIL NIL NIL OPERATION])
-)
-(DEFINEQ
-
-(\HQFX80.DRAWLINE
-  [LAMBDA (HQFX80STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING)
-                                                             (* ; "Edited  5-Jan-87 18:10 by hdj")
-          
-          (* ;; 
-   "Draws a line from (x1,y1) to (x2,y2)  on an hqfx80 imagestream, leaving the position at (x2,y2).")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (LET ((CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA)))
-          
-          (* ;; "draw the line ...")
-
-                (if DASHING
-                    then (GLOBALRESOURCE \HQFX80.BRUSHBBT (LET ((BBT \HQFX80.BRUSHBBT)
-                                                                (BRUSH (LIST 'ROUND WIDTH COLOR)))
-                                                               (\HQFX80.LINEWITHBRUSH
-                                                                (OR (FIXP X1)
-                                                                    (FIXR X1))
-                                                                (OR (FIXP Y1)
-                                                                    (FIXR Y1))
-                                                                (OR (FIXP X2)
-                                                                    (FIXR X2))
-                                                                (OR (FIXP Y2)
-                                                                    (FIXR Y2))
-                                                                BRUSH
-                                                                (\GOOD.DASHLST DASHING BRUSH)
-                                                                HQFX80STREAM BBT)))
-                  else (\HQFX80.CLIP-AND-DRAW-LINE (OR (FIXP X1)
-                                                       (FIXR X1))
-                              (OR (FIXP Y1)
-                                  (FIXR Y1))
-                              (OR (FIXP X2)
-                                  (FIXR X2))
-                              (OR (FIXP Y2)
-                                  (FIXR Y2))
-                              [COND
-                                 ((NULL WIDTH)
-                                  1)
-                                 ((OR (FIXP WIDTH)
-                                      (FIXR WIDTH]
-                              (SELECTQ OPERATION
-                                  (NIL (HQFX80DATA-OPERATION DATA))
-                                  ((REPLACE PAINT INVERT ERASE) 
-                                       OPERATION)
-                                  (\ILLEGAL.ARG OPERATION))
-                              (HQFX80DATA-BACKINGBITMAP DATA)
-                              (ffetch (REGION LEFT) of CLIPPINGREGION)
-                              (SUB1 (ffetch (REGION RIGHT) of CLIPPINGREGION))
-                              (ffetch (REGION BOTTOM) of CLIPPINGREGION)
-                              (SUB1 (ffetch (REGION TOP) of CLIPPINGREGION))
-                              HQFX80STREAM))
-          
-          (* ;; "... then move to (x2,y2)")
-
-                (\HQFX80.XPOSITION HQFX80STREAM X2)
-                (\HQFX80.YPOSITION HQFX80STREAM Y2])
-
-(\HQFX80.CLIP-AND-DRAW-LINE
-  [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION BITMAP LEFT RIGHT BOTTOM TOP HQFX80STREAM)
-                                                             (* ; "Edited  5-Jan-87 17:59 by hdj")
-          
-          (* ;; "draws a line from (X1,Y1) to (X2,Y2) clipped to region specified by LEFT RIGHT BOTTOM and TOP.  This code is a transliterated version of the BCPL routine that was in chat.")
-          
-          (* ;; "")
-          
-          (* ;; "assumes that the width is at least 1")
-
-    (PROG NIL
-          (COND
-             [(EQP X1 X2)                                    (* ; "special case of vertical line.")
-              [COND
-                 ((IGREATERP WIDTH 2)
-                  (COND
-                     ((EQP Y1 Y2)
-          
-          (* ;; "special case.  Since we don't know whether the guy is headed horizontally or vertically, put out a round brush.")
-
-                      (RETURN (\HQFX80.DRAWPOINT HQFX80STREAM X1 Y1 (LIST 'ROUND WIDTH)
-                                     OPERATION)))
-                     (T (SETQ X1 (SETQ X2 (IDIFFERENCE X1 (LRSH (SUB1 WIDTH)
-                                                                1]
-              (PROG (MIN MAX)
-                    (RETURN (COND
-                               ([OR (IGREATERP X1 RIGHT)
-                                    (IGEQ LEFT (SETQ X2 (IPLUS X1 WIDTH)))
-                                    (IGREATERP (SETQ MIN (IMIN Y1 Y2))
-                                           TOP)
-                                    (IGREATERP BOTTOM (SETQ MAX (IMAX Y1 Y2]
-                                                             (* ; "outside clippingregion.")
-                                NIL)
-                               (T (BLTSHADE BLACKSHADE BITMAP (SETQ X1 (IMAX X1 LEFT))
-                                         (SETQ MIN (IMAX MIN BOTTOM))
-                                         (IDIFFERENCE (IMIN X2 (ADD1 RIGHT))
-                                                X1)
-                                         (ADD1 (IDIFFERENCE (IMIN MAX TOP)
-                                                      MIN))
-                                         OPERATION]
-             [(EQP Y1 Y2)                                    (* ; "special case of horizontal line.")
-              [COND
-                 ((IGREATERP WIDTH 2)
-                  (SETQ Y1 (SETQ Y2 (IDIFFERENCE Y1 (LRSH (SUB1 WIDTH)
-                                                          1]
-              (PROG (MIN MAX)
-                    (RETURN (COND
-                               ([OR (IGREATERP Y1 TOP)
-                                    (IGEQ BOTTOM (SETQ Y2 (IPLUS Y1 WIDTH)))
-                                    (IGREATERP (SETQ MIN (IMIN X1 X2))
-                                           RIGHT)
-                                    (IGREATERP LEFT (SETQ MAX (IMAX X1 X2]
-                                                             (* ; "outside clippingregion.")
-                                NIL)
-                               (T (BLTSHADE BLACKSHADE BITMAP (SETQ MIN (IMAX MIN LEFT))
-                                         (SETQ Y1 (IMAX Y1 BOTTOM))
-                                         (ADD1 (IDIFFERENCE (IMIN MAX RIGHT)
-                                                      MIN))
-                                         (IDIFFERENCE (IMIN Y2 (ADD1 TOP))
-                                                Y1)
-                                         OPERATION]
-             ((EQP WIDTH 1)                                  (* ; "special case of width 1")
-              (\HQFX80.CLIP-AND-DRAW-LINE1 X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP 
-                     HQFX80STREAM))
-             ((IGREATERP (IABS (IDIFFERENCE X1 X2))
-                     (IABS (IDIFFERENCE Y1 Y2)))             (* ; 
-                           "slope is more horizontal, so make line grow in the positive y direction.")
-              [COND
-                 ((IGREATERP WIDTH 2)
-                  (PROG (HALFWIDTH)
-                        (SETQ HALFWIDTH (LRSH (SUB1 WIDTH)
-                                              1))
-                        (SETQ Y1 (IDIFFERENCE Y1 HALFWIDTH))
-                        (SETQ Y2 (IDIFFERENCE Y2 HALFWIDTH]
-              (for I from Y1 to (SUB1 (IPLUS Y1 WIDTH)) as J from Y2
-                 do (\HQFX80.CLIP-AND-DRAW-LINE1 X1 I X2 J OPERATION BITMAP LEFT RIGHT BOTTOM TOP)))
-             (T                                              (* ; 
-                             "slope is more vertical, so make line grow in the positive x direction.")
-                [COND
-                   ((IGREATERP WIDTH 2)
-                    (PROG (HALFWIDTH)
-                          (SETQ HALFWIDTH (LRSH (SUB1 WIDTH)
-                                                1))
-                          (SETQ X1 (IDIFFERENCE X1 HALFWIDTH))
-                          (SETQ X2 (IDIFFERENCE X2 HALFWIDTH]
-                (for I from X1 to (SUB1 (IPLUS X1 WIDTH)) as J from X2
-                   do (\HQFX80.CLIP-AND-DRAW-LINE1 I Y1 J Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP])
-
-(\HQFX80.CLIP-AND-DRAW-LINE1
-  [LAMBDA (X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP)
-                                                             (* hdj " 6-Nov-86 14:30")
-          
-          (* ;; "LEFT, RIGHT, BOTTOM, TOP are set to the boundaries of the clipping region")
-
-    (PROG (DX DY YMOVEUP HALFDX HALFDY (BMRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)))
-          (COND
-             ((IGREATERP X1 X2)                              (* ; 
-                                                            "switch points so DX is always positive.")
-              (SETQ HALFDX X1)
-              (SETQ X1 X2)
-              (SETQ X2 HALFDX)
-              (SETQ HALFDX Y1)
-              (SETQ Y1 Y2)
-              (SETQ Y2 HALFDX)))                             (* ; 
-                                                      "calculate differences and sign of Y movement.")
-          (SETQ HALFDX (LRSH (SETQ DX (IDIFFERENCE X2 X1))
-                             1))
-          (SETQ HALFDY (LRSH [SETQ DY (COND
-                                         ((IGREATERP Y2 Y1)
-                                          (SETQ YMOVEUP T)
-                                          (IDIFFERENCE Y2 Y1))
-                                         (T (IDIFFERENCE Y1 Y2]
-                             1))
-          (COND
-             ((AND (IGEQ X1 LEFT)
-                   (IGEQ RIGHT X2)
-                   [COND
-                      (YMOVEUP (AND (IGEQ Y1 BOTTOM)
-                                    (IGEQ TOP Y2)))
-                      (T (AND (IGEQ Y2 BOTTOM)
-                              (IGEQ TOP Y1]
-                   (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)
-                       1))                                   (* ; 
-                                                             "line is completely visible, fast case.")
-              (\DRAWLINE1 X1 (SUB1 (\SFInvert BITMAP Y1))
-                     DX DY DX DY (COND
-                                    ((IGREATERP DX DY)       (* ; "X is the fastest mover.")
-                                     HALFDX)
-                                    (T                       (* ; "y is the fastest mover.")
-                                       HALFDY))
-                     (COND
-                        (YMOVEUP                             (* ; 
-                                    "y is moving in positive direction but bits are stored inversely")
-                               (IMINUS BMRASTERWIDTH))
-                        (T BMRASTERWIDTH))
-                     OPERATION
-                     (fetch BITMAPBASE of BITMAP)
-                     BMRASTERWIDTH))
-             (T (PROG ((CX1 X1)
-                       (CY1 Y1)
-                       (CX2 X2)
-                       (CY2 Y2)
-                       (CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM))
-                       (CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM)))
-                                                             (* ; 
-                                             "save the original points for the clipping computation.")
-                                                             (* ; 
-                                                    "determine the sectors in which the points fall.")
-                  CLIPLP
-                      [COND
-                         ((NOT (EQ 0 (LOGAND CA1 CA2)))      (* ; 
-                                                            "line is entirely out of clipping region")
-                          (RETURN NIL))
-                         ((EQ 0 (IPLUS CA1 CA2))             (* ; "line is completely visible")
-          
-          (* ;; "\SFInvert has an off by one bug that everybody else in LLDISPLAY uses to save computation so SUB1 from what you would expect.")
-                                                             (* ; "reuse the variable CA1")
-                          (RETURN (\DRAWLINE1 CX1 (SUB1 (\SFInvert BITMAP CY1))
-                                         (IDIFFERENCE CX2 CX1)
-                                         (COND
-                                            (YMOVEUP (IDIFFERENCE CY2 CY1))
-                                            (T (IDIFFERENCE CY1 CY2)))
-                                         DX DY
-                                         (COND
-                                            ((IGREATERP DX DY)
-                                                             (* ; "X is the fastest mover.")
-                                             (IREMAINDER (IPLUS (ITIMES DY (IDIFFERENCE CX1 X1))
-                                                                HALFDX)
-                                                    DX))
-                                            (T               (* ; "y is the fastest mover.")
-                                               (IREMAINDER (IPLUS [ITIMES DX
-                                                                         (COND
-                                                                            (YMOVEUP (IDIFFERENCE
-                                                                                      CY1 Y1))
-                                                                            (T (IDIFFERENCE Y1 CY1]
-                                                                  HALFDY)
-                                                      DY)))
-                                         (COND
-                                            (YMOVEUP         (* ; 
-                                    "y is moving in positive direction but bits are stored inversely")
-                                                   (IMINUS BMRASTERWIDTH))
-                                            (T BMRASTERWIDTH))
-                                         OPERATION
-                                         (fetch BITMAPBASE of BITMAP)
-                                         BMRASTERWIDTH]
-                      [COND
-                         ((NEQ CA1 0)
-          
-          (* ;; "now move point CX1 CY1 so that one of the coordinates is on one of the boundaries.  Which boundary is done first was copied from BCPL.")
-
-                          (COND
-                             ((IGREATERP CA1 7)              (* ; "y1 less than bottom")
-                                                             (* ; 
-                                               "calculate the least X for which Y will be at bottom.")
-                              [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE BOTTOM Y1]
-                              (SETQ CY1 BOTTOM))
-                             ((IGREATERP CA1 3)              (* ; "y1 is greater than top")
-                              [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE Y1 TOP]
-                              (SETQ CY1 TOP))
-                             (T                              (* ; "x1 is less than left")
-                                [SETQ CY1 (COND
-                                             [YMOVEUP (IPLUS Y1 (\LEASTPTAT DY DX (IDIFFERENCE LEFT 
-                                                                                         X1]
-                                             (T (IDIFFERENCE Y1 (\LEASTPTAT DY DX (IDIFFERENCE LEFT 
-                                                                                         X1]
-                                (SETQ CX1 LEFT)))
-                          (SETQ CA1 (\CLIPCODE CX1 CY1 LEFT RIGHT TOP BOTTOM)))
-                         (T                                  (* ; 
-                  "now move point CX2 CY2 so that one of the coordinates is on one of the boundaries")
-                            (COND
-                               ((IGREATERP CA2 7)            (* ; "y2 less than bottom")
-                                [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE Y1 BOTTOM]
-                                (SETQ CY2 BOTTOM))
-                               ((IGREATERP CA2 3)            (* ; "y2 is greater than top")
-                                [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE TOP Y1]
-                                (SETQ CY2 TOP))
-                               (T                            (* ; "x2 is greater than right")
-                                  [SETQ CY2 (COND
-                                               [YMOVEUP (IPLUS Y1 (\GREATESTPTAT DY DX
-                                                                         (IDIFFERENCE RIGHT X1]
-                                               (T (IDIFFERENCE Y1 (\GREATESTPTAT DY DX
-                                                                         (IDIFFERENCE RIGHT X1]
-                                  (SETQ CX2 RIGHT)))
-                            (SETQ CA2 (\CLIPCODE CX2 CY2 LEFT RIGHT TOP BOTTOM]
-                      (GO CLIPLP])
-)
-(DEFINEQ
-
-(\HQFX80.DRAWCIRCLE
-  [LAMBDA (HQFX80STREAM CENTERX CENTERY RADIUS BRUSH DASHING)(* hdj "21-Nov-86 17:11")
-          
-          (* ;; "draw a circle on a hqfx80 stream")
-
-    (DECLARE (LOCALVARS . T))
-    (COND
-       ((OR (NOT (NUMBERP RADIUS))
-            (ILESSP (SETQ RADIUS (FIXR RADIUS))
-                   0))
-        (\ILLEGAL.ARG RADIUS))
-       ((EQ RADIUS 0)                                        (* ; "don't draw anything.")
-        NIL)
-       (T (GLOBALRESOURCE \HQFX80.BRUSHBBT
-                 (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM)
-                        (PROG ((X 0)
-                               (Y RADIUS)
-                               (D (ITIMES 2 (- 1 RADIUS)))
-                               LEFT RIGHTPLUS1 TOP BOTTOM DESTINATION-BITMAP BRUSHWIDTH BRUSHHEIGHT 
-                               LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE 
-                               BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH OPERATION HEIGHTMINUS1 CX CY
-                               (BBT \HQFX80.BRUSHBBT)
-                               (USERFN (AND (LITATOM BRUSH)
-                                            BRUSH)))
-          
-          (* ;; "many of these variables are used by the macro for \HQFX80.CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\HQFX80.BBTCURVEPT.  sets them up.")
-
-                              [COND
-                                 (USERFN                     (* ; 
-               "if calling user fn, don't bother with set up and leave points in stream coordinates.")
-                                        (SETQ CX CENTERX)
-                                        (SETQ CY CENTERY))
-                                 (T (.SETUP.FOR.\HQFX80.BBTCURVEPT. HQFX80DATA)
-                                    (SETQ CX (- CENTERX (FOLDLO BRUSHWIDTH 2)))
-                                                             (* ; 
-                                                             "take into account the brush thickness.")
-                                    (SETQ CY (- CENTERY (FOLDLO BRUSHHEIGHT 2]
-                              [COND
-                                 ((EQ RADIUS 1)              (* ; "put a single brush down.")
-                                                             (* ; 
-                                                             "draw the top and bottom most points.")
-                                  (COND
-                                     (USERFN (APPLY* USERFN CX CY HQFX80STREAM))
-                                     (T (\HQFX80.CURVEPT CX CY)))
-                                  (RETURN))
-                                 (T                          (* ; 
-                                                             "draw the top and bottom most points.")
-                                    (COND
-                                       (USERFN (APPLY* USERFN CX (+ CY RADIUS)
-                                                      HQFX80STREAM)
-                                              (APPLY* USERFN CX (- CY RADIUS)
-                                                     HQFX80STREAM))
-                                       (T (\HQFX80.CURVEPT CX (+ CY RADIUS))
-                                          (\HQFX80.CURVEPT CX (- CY RADIUS]
-                          LP                                 (* ; 
-                                                       "(UNFOLD x 2) is used instead of (ITIMES x 2)")
-                              [COND
-                                 [(IGREATERP 0 D)
-                                  (SETQ X (ADD1 X))
-                                  (COND
-                                     ((IGREATERP (UNFOLD (+ D Y)
-                                                        2)
-                                             1)
-                                      (SETQ D (+ D (UNFOLD (- X Y)
-                                                          2)
-                                                 4))
-                                      (SETQ Y (SUB1 Y)))
-                                     (T (SETQ D (+ D (UNFOLD X 2)
-                                                   1]
-                                 ((OR (EQ 0 D)
-                                      (IGREATERP X D))
-                                  (SETQ X (ADD1 X))
-                                  (SETQ D (+ D (UNFOLD (- X Y)
-                                                      2)
-                                             4))
-                                  (SETQ Y (SUB1 Y)))
-                                 (T (SETQ D (+ (- D (UNFOLD Y 2))
-                                               3))
-                                    (SETQ Y (SUB1 Y]
-                              (COND
-                                 [(EQ Y 0)
-          
-          (* ;; "left most and right most points are drawn specially so that they are not duplicated which leaves a hole in XOR mode.")
-
-                                  (COND
-                                     (USERFN (APPLY* USERFN (+ CX X)
-                                                    CY HQFX80STREAM)
-                                            (APPLY* USERFN (- CX X)
-                                                   CY HQFX80STREAM))
-                                     (T (\HQFX80.CURVEPT (+ CX X)
-                                               CY)
-                                        (\HQFX80.CURVEPT (- CX X)
-                                               CY]
-                                 (T (COND
-                                       (USERFN (APPLY* USERFN (+ CX X)
-                                                      (+ CY Y)
-                                                      HQFX80STREAM)
-                                              (APPLY* USERFN (- CX X)
-                                                     (+ CY Y)
-                                                     HQFX80STREAM)
-                                              (APPLY* USERFN (+ CX X)
-                                                     (- CY Y)
-                                                     HQFX80STREAM)
-                                              (APPLY* USERFN (- CX X)
-                                                     (- CY Y)
-                                                     HQFX80STREAM))
-                                       (T (\HQFX80.DRAW-4-CIRCLE-POINTS CX CY X Y)))
-                                    (GO LP)))
-                              (MOVETO CENTERX CENTERY HQFX80STREAM)
-                              (RETURN NIL])
-
-(\HQFX80.CREATE-BRUSH-BBT
-  [LAMBDA (BRUSHBM HQFX80DATA BITBLT-TABLE)                  (* hdj "18-Nov-86 17:33")
-          
-          (* ;; "Initializes BITBLT-TABLE for the BRUSHBM and an HQFX80 stream and returns BITBLT-TABLE, unless the BRUSHBM is a 1-point brush, in which case it returns NIL.")
-
-    (COND
-       ((AND (EQ (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM)
-                 1)
-             (EQ (fetch (BITMAP BITMAPWIDTH) of BRUSHBM)
-                 1)
-             (EQ (BITMAPBIT BRUSHBM 0 0)
-                 1))                                         (* ; 
-                                                          "special case of single point brush shape.")
-        NIL)
-       (T                                                    (* ; 
-                       "update as many fields in the brush bitblt table as possible from HQFX80DATA.")
-          (replace (PILOTBBT PBTDESTBPL) of BITBLT-TABLE with (UNFOLD (fetch (BITMAP 
-                                                                                    BITMAPRASTERWIDTH
-                                                                                    )
-                                                                         of (HQFX80DATA-BACKINGBITMAP
-                                                                             HQFX80DATA))
-                                                                     BITSPERWORD))
-          (replace (PILOTBBT PBTSOURCEBPL) of BITBLT-TABLE with (UNFOLD (fetch (BITMAP 
-                                                                                    BITMAPRASTERWIDTH
-                                                                                      ) of BRUSHBM)
-                                                                       BITSPERWORD))
-          (replace (PILOTBBT PBTFLAGS) of BITBLT-TABLE with 0)
-          (replace (PILOTBBT PBTDISJOINT) of BITBLT-TABLE with T)
-          (\SETPBTFUNCTION BITBLT-TABLE (HQFX80DATA-SOURCETYPE HQFX80DATA)
-                 (SELECTQ (HQFX80DATA-OPERATION HQFX80DATA)
-                     ((PAINT REPLACE) 
-                          'PAINT)
-                     ((INVERT ERASE) 
-                          'ERASE)
-                     (SHOULDNT)))
-          BITBLT-TABLE])
-)
-
-(DEFMACRO \HQFX80.DRAW-4-CIRCLE-POINTS (CENTER-X CENTER-Y EDGE-X EDGE-Y)
-
-   (* ;; "draw four points 90 degress apart on the circumference of a circle")
-
-   `[PROGN (\HQFX80.CURVEPT (+ ,CENTER-X ,EDGE-X)
-                  (+ ,CENTER-Y ,EDGE-Y))
-           (\HQFX80.CURVEPT (- ,CENTER-X ,EDGE-X)
-                  (+ ,CENTER-Y ,EDGE-Y))
-           (\HQFX80.CURVEPT (+ ,CENTER-X ,EDGE-X)
-                  (- ,CENTER-Y ,EDGE-Y))
-           (\HQFX80.CURVEPT (- ,CENTER-X ,EDGE-X)
-                  (- ,CENTER-Y ,EDGE-Y])
-(DEFINEQ
-
-(\HQFX80.FILLCIRCLE
-  [LAMBDA (HQFX80STREAM CENTERX CENTERY RADIUS TEXTURE)      (* hdj " 6-Nov-86 15:45")
-    (COND
-       ((OR (NOT (NUMBERP RADIUS))
-            (ILESSP (SETQ RADIUS (FIXR RADIUS))
-                   0))
-        (\ILLEGAL.ARG RADIUS))
-       (T (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM)
-                 (GLOBALRESOURCE \HQFX80.BRUSHBBT
-                        (LET* [(CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION HQFX80DATA))
-                               (TOP (SUB1 (fetch (REGION TOP) of CLIPPINGREGION)))
-                               (BOTTOM (fetch (REGION BOTTOM) of CLIPPINGREGION))
-                               (LEFT (fetch (REGION LEFT) of CLIPPINGREGION))
-                               (RIGHT (SUB1 (fetch (REGION RIGHT) of HQFX80DATA]
-                              (PROG (TOP BOTTOM RIGHT LEFT OPERATION DESTINATION-BITMAP (X 0)
-                                         (Y RADIUS)
-                                         (D (ITIMES 2 (- 1 RADIUS)))
-                                         DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT 
-                                         GRAYWIDTH GRAYBASE (FCBBT \HQFX80.BRUSHBBT))
-                                    (SETQ OPERATION (HQFX80DATA-OPERATION HQFX80DATA))
-                                    (SETQ DESTINATION-BITMAP (HQFX80DATA-BACKINGBITMAP HQFX80DATA))
-                                    [SETQ TEXTUREBM (COND
-                                                       ((BITMAPP TEXTURE))
-                                                       [(AND (NULL TEXTURE)
-                                                             (BITMAPP (HQFX80DATA-TEXTURE HQFX80DATA]
-                                                       ([OR (FIXP TEXTURE)
-                                                            (AND (NULL TEXTURE)
-                                                                 (SETQ TEXTURE (HQFX80DATA-TEXTURE
-                                                                                HQFX80DATA]
-                                                             (* ; 
-              "create bitmap for the texture.  Could reuse a bitmap but for now this is good enough.")
-                                                        (SETQ TEXTUREBM (BITMAPCREATE 16 4))
-                                                        (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE)
-                                                                          of TEXTUREBM))
-                                                        (\PUTBASE GRAYBASE 0
-                                                               (\SFReplicate (LOGAND (LRSH TEXTURE 12
-                                                                                           )
-                                                                                    15)))
-                                                        (\PUTBASE GRAYBASE 1
-                                                               (\SFReplicate (LOGAND (LRSH TEXTURE 8)
-                                                                                    15)))
-                                                        (\PUTBASE GRAYBASE 2
-                                                               (\SFReplicate (LOGAND (LRSH TEXTURE 4)
-                                                                                    15)))
-                                                        (\PUTBASE GRAYBASE 3 (\SFReplicate
-                                                                              (LOGAND TEXTURE 15)))
-                                                        TEXTUREBM)
-                                                       (T (\ILLEGAL.ARG TEXTURE]
-                                    (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM))
-                                    (SETQ DESTINATIONBASE (fetch (BITMAP BITMAPBASE) of 
-                                                                                   DESTINATION-BITMAP
-                                                                 ))
-                                    (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of 
-                                                                                   DESTINATION-BITMAP
-                                                             ))
-          
-          (* ;; "update as many fields in the brush bitblt table as possible from the stream.")
-
-                                    (replace PBTFLAGS of FCBBT with 0)
-                                    (replace PBTDESTBPL of FCBBT with (UNFOLD RASTERWIDTH BITSPERWORD
-                                                                             ))
-          
-          (* ;; "clear gray information.  PBTSOURCEBPL is used for gray information too.")
-
-                                    (replace PBTSOURCEBPL of FCBBT with 0)
-                                    (replace PBTUSEGRAY of FCBBT with T)
-                                    [replace PBTGRAYWIDTHLESSONE of FCBBT
-                                       with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH)
-                                                                           of TEXTUREBM)
-                                                                        16]
-                                    [replace PBTGRAYHEIGHTLESSONE of FCBBT
-                                       with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT)
-                                                                            of TEXTUREBM)
-                                                                         16]
-                                    (replace PBTDISJOINT of FCBBT with T)
-                                    (\SETPBTFUNCTION FCBBT 'TEXTURE OPERATION)
-                                    (replace PBTHEIGHT of FCBBT with 1)
-                                                             (* ; 
-                                                             "take into account the brush thickness.")
-                                    (SETQ CX (\DSPTRANSFORMX CENTERX HQFX80DATA))
-                                    (SETQ CY (\DSPTRANSFORMY CENTERY HQFX80DATA))
-                                                             (* ; 
-                                                "change Y TOP and BOTTOM to be in bitmap coordinates")
-                                    (SETQ CY (\SFInvert DESTINATION-BITMAP CY))
-                                    [SETQ BOTTOM (PROG1 (SUB1 (\SFInvert DESTINATION-BITMAP TOP))
-                                                        (SETQ TOP (SUB1 (\SFInvert DESTINATION-BITMAP 
-                                                                               BOTTOM]
-                                    (COND
-                                       ((EQ RADIUS 0)        (* ; 
-                                 "put a single point down.  Use \LINEBLT to get proper texture.  NIL")
-                                        (\LINEBLT FCBBT CX CY CX DESTINATIONBASE RASTERWIDTH LEFT 
-                                               RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE 1)
-                                        (RETURN)))
-                                LOOP
-                                                             (* ; 
-                                                       "(UNFOLD x 2) is used instead of (ITIMES x 2)")
-                                    [COND
-                                       [(IGREATERP 0 D)
-                                        (SETQ X (ADD1 X))
-                                        (COND
-                                           ((IGREATERP (UNFOLD (+ D Y)
-                                                              2)
-                                                   1)
-                                            (SETQ D (+ D (UNFOLD (- X Y)
-                                                                2)
-                                                       4)))
-                                           (T (SETQ D (+ D (UNFOLD X 2)
-                                                         1)) (* ; "don't draw unless Y changes.")
-                                              (GO LOOP]
-                                       ((OR (EQ 0 D)
-                                            (IGREATERP X D))
-                                        (SETQ X (ADD1 X))
-                                        (SETQ D (+ D (UNFOLD (- X Y)
-                                                            2)
-                                                   4)))
-                                       (T (SETQ D (+ (- D (UNFOLD Y 2))
-                                                     3]
-                                    (COND
-                                       ((EQ Y 0)             (* ; 
-                                             "draw the middle line differently to avoid duplication.")
-                                        (\LINEBLT FCBBT (- CX X)
-                                               CY
-                                               (+ CX X)
-                                               DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP 
-                                               GRAYWIDTH GRAYHEIGHT GRAYBASE 1))
-                                       (T (\HQFX80.FILL-CIRCLE-BLT CX CY X Y)
-                                          (SETQ Y (SUB1 Y))
-                                          (GO LOOP)))
-                                    (MOVETO CENTERX CENTERY HQFX80STREAM)
-                                    (RETURN NIL])
-
-(\HQFX80.DRAWARC
-  [LAMBDA (HQFX80STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING)
-                                                             (* hdj "20-Nov-86 14:27")
-          
-          (* ;; "draws an arc on an hqfx80stream")
-
-    (\DRAWARC.GENERIC HQFX80STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING])
-)
-
-(DEFMACRO \HQFX80.FILL-CIRCLE-BLT (CENTER-X CENTER-Y X Y)
-
-   (* ;; "calls bitblt twice to fill in one line of the circle.")
-
-   `(PROGN (\LINEBLT FCBBT (- ,CENTER-X ,X)
-                  (+ ,CENTER-Y ,Y)
-                  (+ ,CENTER-X ,X)
-                  DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE 1)
-           (\LINEBLT FCBBT (- ,CENTER-X ,X)
-                  (- ,CENTER-Y ,Y)
-                  (+ ,CENTER-X ,X)
-                  DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE 1)))
-
-
-
-(* ;; "curve-drawing")
-
-(DEFINEQ
-
-(\HQFX80.DRAWCURVE
-  [LAMBDA (HQFX80STREAM KNOTS CLOSED BRUSH DASHING)          (* hdj "19-Nov-86 14:42")
-          
-          (* ;; "draws a spline curve with a given brush on HQFX80STREAM")
-
-    (GLOBALRESOURCE \HQFX80.BRUSHBBT
-           (LET ([DASHLST (AND DASHING (OR (AND (LISTP DASHING)
-                                                (EVERY DASHING (FUNCTION FIXP))
-                                                DASHING)
-                                           (\ILLEGAL.ARG DASHING]
-                 (BBT \HQFX80.BRUSHBBT))
-                (SELECTQ (LENGTH KNOTS)
-                    (0 
-          
-          (* ;; "No knots => empty curve rather than error")
-
-                       NIL)
-                    (1 
-          
-          (* ;; "only one knot, put down a brush shape")
-
-                       (OR (type? POSITION (CAR KNOTS))
-                           (ERROR "bad knot" (CAR KNOTS)))
-                       (DRAWPOINT (fetch XCOORD of (CAR KNOTS))
-                              (fetch YCOORD of (CAR KNOTS))
-                              BRUSH HQFX80STREAM))
-                    (2 (OR (type? POSITION (CAR KNOTS))
-                           (ERROR "bad knot" (CAR KNOTS)))
-                       (OR (type? POSITION (CADR KNOTS))
-                           (ERROR "bad knot" (CADR KNOTS)))
-                       (\HQFX80.LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS))
-                              (fetch YCOORD of (CAR KNOTS))
-                              (fetch XCOORD of (CADR KNOTS))
-                              (fetch YCOORD of (CADR KNOTS))
-                              BRUSH DASHLST HQFX80STREAM BBT))
-                    (\HQFX80.DRAWCURVE2 (PARAMETRICSPLINE KNOTS CLOSED)
-                           BRUSH DASHLST BBT HQFX80STREAM))
-                HQFX80STREAM])
-
-(\HQFX80.DRAWCURVE2
-  [LAMBDA (SPLINE BRUSH DASHLST BBT HQFX80STREAM)            (* hdj "19-Nov-86 11:58")
-
-(* ;;; "Given a spline curve, represented as a set of derivatives for each segment, draw it on HQFX80STREAM using the brush BRUSH, and dashing it according to DASHLST.  For speed, use the bitblt table BBT.")
-
-    (DECLARE (SPECVARS . T))
-          
-          (* ;; "Should declare most of these variables local but currently have the \CURVE function between here and \CURVEBBT so can't")
-
-    (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM)
-           (PROG (BRUSHBM DESTINATION-BITMAP OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE 
-                        BRUSHRASTERWIDTH LEFT RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH 
-                        BOTTOMMINUSBRUSH TOPMINUSBRUSH RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 \CURX 
-                        \CURY \OLDX \OLDY \OLDERX \OLDERY LKNOT (DASHON T)
-                        (DASHTAIL DASHLST)
-                        (DASHCNT (CAR DASHLST))
-                        NPOINTS NSEGS POINTSPERSEG DX D2X D3X DY D2Y D3Y D1 D2 D3 X0 Y0 X1 Y1 DX DDX 
-                        DDDX DY DDY DDDY (XPOLY (create POLYNOMIAL))
-                        (X/PRIME/POLY (create POLYNOMIAL))
-                        (YPOLY (create POLYNOMIAL))
-                        (Y/PRIME/POLY (create POLYNOMIAL))
-                        (USERFN (AND (LITATOM BRUSH)
-                                     BRUSH)))
-          
-          (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\HQFX80.BBTCURVEPT.  sets them up.")
-
-                 [COND
-                    (USERFN                                  (* ; 
-               "if calling user fn, don't bother with set up and leave points in window coordinates.")
-                           (\CURVESTART (ELT (fetch (SPLINE SPLINEX) of SPLINE)
-                                             1)
-                                  (ELT (fetch (SPLINE SPLINEY) of SPLINE)
-                                       1)))
-                    (T (.SETUP.FOR.\HQFX80.BBTCURVEPT. HQFX80DATA)
-                                                             (* ; 
-                        "curve pts will be kept in screen coordinates, start smoothing values there.")
-                       (\CURVESTART (IDIFFERENCE (ELT (fetch (SPLINE SPLINEX) of SPLINE)
-                                                      1)
-                                           (LRSH (SUB1 BRUSHWIDTH)
-                                                 1))
-                              (IDIFFERENCE (ELT (fetch (SPLINE SPLINEY) of SPLINE)
-                                                1)
-                                     (LRSH (SUB1 BRUSHHEIGHT)
-                                           1]
-                 [bind PERSEG for KNOT from 1 to (SUB1 (fetch %#KNOTS of SPLINE))
-                    when (PROGN 
-
-(* ;;; "Loop thru the segments of the spline curve, drawing each in turn.")
-
-                                (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
-                                              KNOT))         (* ; 
-                                                 "Set up X0,Y0 -- the starting point of this segment")
-                                (SETQ Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
-                                              KNOT))
-                                (SETQ X1 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
-                                              (ADD1 KNOT)))  (* ; "And X1,Y1 -- the ending point")
-                                (SETQ Y1 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
-                                              (ADD1 KNOT)))
-                                (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of SPLINE)
-                                              KNOT))         (* ; 
-                                                             "And the initial derivatives -- first")
-                                (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of SPLINE)
-                                              KNOT))
-                                (SETQ DDX (ELT (fetch SPLINEDDX of SPLINE)
-                                               KNOT))        (* ; "Second")
-                                (SETQ DDY (ELT (fetch SPLINEDDY of SPLINE)
-                                               KNOT))
-                                (SETQ DDDX (ELT (fetch SPLINEDDDX of SPLINE)
-                                                KNOT))       (* ; "And third.")
-                                (SETQ DDDY (ELT (fetch SPLINEDDDY of SPLINE)
-                                                KNOT))
-                                (SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0))
-                                                                    (IABS (IDIFFERENCE Y1 Y0)))
-                                                             3)
-                                                     2))
-          
-          (* ;; "Establish an upper bound on the number of points we'll draw while painting this segment.  We know that 3/2 the maximum DX or DY is the right amount.")
-
-                                (NOT (ZEROP NPOINTS)))
-                    do 
-          
-          (* ;; "NPOINTS can be zero if a knot is duplicated in the spline curve to produce a discontinuity.  Skip over zero-length segments to avoid divide-by-zero trouble")
-          
-          (* ;; "To prevent round-off errors from accumulating, we'll draw this segment as runs of no more than 64 points each -- recomputing completely at the start of each run.  This is a trade off of speed and accuracy.")
-
-                       [COND
-                          ((ILEQ NPOINTS 64)                 (* ; 
-                                                   "Fewer than 64 points to draw.  Do it in one run.")
-                           (SETQ NSEGS 1)
-                           (SETQ POINTSPERSEG NPOINTS))
-                          (T                                 (* ; 
-                                                             "Figure out how many runs to do it in.")
-                             (SETQ NSEGS (FOLDLO NPOINTS 64))
-                             (SETQ POINTSPERSEG 64)
-                             (SETQ NPOINTS (UNFOLD NSEGS 64]
-                       (SETQ D1 (FQUOTIENT 1.0 NPOINTS))     (* ; 
-                                          "Set up ÿ&Eÿt, ÿ&Eÿt**2 and ÿ&Eÿt**3, for computing the next point.")
-                       (SETQ D2 (FTIMES D1 D1))
-                       (SETQ D3 (FTIMES D2 D1))
-                       (SETQ D3X (FTIMES D3 DDDX))
-                       (SETQ D3Y (FTIMES D3 DDDY))
-                       (COND
-                          [(EQ NSEGS 1)                      (* ; "Just one segment to draw.")
-                           [SETQ DX (FPLUS (FTIMES D1 DX)
-                                           (FTIMES DDX D2 0.5)
-                                           (FTIMES DDDX D3 (CONSTANT (FQUOTIENT 1.0 6.0]
-                           (SETQ D2X (FPLUS (FTIMES D2 DDX)
-                                            (FTIMES D3 DDDX)))
-                           [SETQ DY (FPLUS (FTIMES D1 DY)
-                                           (FTIMES D2 DDY 0.5)
-                                           (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0]
-                           (SETQ D2Y (FPLUS (FTIMES D2 DDY)
-                                            (FTIMES D3 DDDY)))
-                           (COND
-                              (USERFN                        (* ; 
-                                       "Draw this run of points, using the user's supplied function.")
-                                     (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS 
-                                            BRUSHBM HQFX80DATA BBT NIL USERFN HQFX80STREAM))
-                              (T                             (* ; 
-                                                          "Draw this run of points, using the brush.")
-                                 (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS 
-                                        BRUSHBM HQFX80DATA BBT NIL NIL HQFX80STREAM]
-                          (T                                 (* ; 
-                                                           "Have to do this segment in several runs.")
-                             (SETQ PERSEG (FQUOTIENT 1.0 NSEGS))
-                             (LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0)
-                             (LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0)
-                             (bind (TT _ 0.0)
-                                   (DDDX/PER/SEG _ (FTIMES DDDX PERSEG))
-                                   (DDDY/PER/SEG _ (FTIMES DDDY PERSEG))
-                                   [D3XFACTOR _ (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0]
-                                   [D3YFACTOR _ (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0]
-                                for I from 0 to (SUB1 NSEGS)
-                                do 
-
-(* ;;; "TT is the parameter, and runs from 0 to 1 as the curve segment runs from beginning to end.")
-
-                                   (SETQ TT (FPLUS TT PERSEG))
-                                   (SETQ X1 (POLYEVAL TT XPOLY 3))
-                                   (SETQ Y1 (POLYEVAL TT YPOLY 3))
-                                   (SETQ DX (FPLUS (FTIMES D1 DX)
-                                                   (FTIMES D2 DDX 0.5)
-                                                   D3XFACTOR))
-                                   (SETQ D2X (FPLUS (FTIMES D2 DDX)
-                                                    (FTIMES D3 DDDX)))
-                                   (SETQ DY (FPLUS (FTIMES D1 DY)
-                                                   (FTIMES D2 DDY 0.5)
-                                                   D3YFACTOR))
-                                   (SETQ D2Y (FPLUS (FTIMES D2 DDY)
-                                                    (FTIMES D3 DDDY)))
-                                   (COND
-                                      (USERFN (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 
-                                                     64 BRUSHBM HQFX80DATA BBT NIL USERFN 
-                                                     HQFX80STREAM))
-                                      (T (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 
-                                                BRUSHBM HQFX80DATA BBT NIL NIL HQFX80STREAM)))
-                                   (SETQ X0 X1)
-                                   (SETQ Y0 Y1)
-                                   (SETQ DDX (FPLUS DDX DDDX/PER/SEG))
-                                   (SETQ DDY (FPLUS DDY DDDY/PER/SEG))
-                                   (SETQ DX (POLYEVAL TT X/PRIME/POLY 2))
-                                   (SETQ DY (POLYEVAL TT Y/PRIME/POLY 2]
-
-(* ;;; "Draw the final point on the curve.")
-
-                 (COND
-                    (USERFN (\HQFX80.DRAWCURVE3 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM HQFX80DATA BBT T USERFN 
-                                   HQFX80STREAM))
-                    (T (\HQFX80.DRAWCURVE3 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM HQFX80DATA BBT T NIL 
-                              HQFX80STREAM])
-
-(\HQFX80.DRAWCURVE3
-  [LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM HQFX80DATA BBT ENDING USERFN HQFX80STREAM)
-                                                             (* hdj "19-Nov-86 12:18")
-    (DECLARE (LOCALVARS . T)
-           (USEDFREE BRUSHWIDTH BRUSHHEIGHT \CURX \OLDX \CURY \OLDY))
-          
-          (* ;; "Puts a spline segment down.  Since it calls BitBlt directly, it must clip to both clipping region and the size of the destination bit map.")
-
-    (PROG (OLDX X Y OLDY DELTAX DELTAY DELTA TX TY OOLDX OOLDY)
-          [COND
-             ((NEQ N 0)
-              [COND
-                 (USERFN                                     (* ; 
-                                                    "if there is a user fn, stay in his coordinates.")
-                        (SETQ OLDX X0)
-                        (SETQ OLDY Y0))
-                 (T 
-          
-          (* ;; "SUB1 on brush size is to cause the extra bit to be in the top left direction as is documented for lines.")
-
-                    (SETQ OLDX (IDIFFERENCE X0 (LRSH (SUB1 BRUSHWIDTH)
-                                                     1)))
-                    (SETQ OLDY (IDIFFERENCE Y0 (LRSH (SUB1 BRUSHHEIGHT)
-                                                     1]      (* ; "draw origin point")
-              (\HQFX80.SMOOTH-CURVE OLDX OLDY USERFN HQFX80STREAM)
-                                                             (* ; 
-                                              "convert the derivatives to fractional representation.")
-                                                             (* ; "\CONVERTTOFRACTION always returns a large number box.  This uses .49 because .5 causes rounding up.")
-              (SETQ X (\CONVERTTOFRACTION (FPLUS OLDX 0.49)))
-              (SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY 0.49)))
-              (SETQ DX (\CONVERTTOFRACTION DX))
-              (SETQ DY (\CONVERTTOFRACTION DY))
-              (SETQ DDX (\CONVERTTOFRACTION DDX))
-              (SETQ DDY (\CONVERTTOFRACTION DDY))
-              (SETQ DDDX (\CONVERTTOFRACTION DDDX))
-              (SETQ DDDY (\CONVERTTOFRACTION DDDY))
-              [for I from 1 to N do                          (* ; 
-                             "uses \BOXIPLUS to save box and also set the new value of the variable.")
-                                    (\BOXIPLUS X DX)
-                                    (\BOXIPLUS DX DDX)
-                                    (\BOXIPLUS DDX DDDX)
-                                    (\BOXIPLUS Y DY)
-                                    (\BOXIPLUS DY DDY)
-                                    (\BOXIPLUS DDY DDDY)
-                                    (SETQ OOLDX OLDX)
-                                    (SETQ OOLDY OLDY)
-                                    (SETQ DELTAX (IDIFFERENCE (SETQ OLDX (\GETINTEGERPART X))
-                                                        OOLDX))
-                                    (SETQ DELTAY (IDIFFERENCE (SETQ OLDY (\GETINTEGERPART Y))
-                                                        OOLDY))
-                                    (SETQ DELTA (IMAX (IABS DELTAX)
-                                                      (IABS DELTAY)))
-                                    (COND
-                                       ((EQ DELTA 1)
-                                        (\HQFX80.SMOOTH-CURVE OLDX OLDY USERFN HQFX80STREAM)))
-                                    (COND
-                                       ((IGREATERP DELTA 1)
-                                        (SETQ DELTAX (\CONVERTTOFRACTION (FQUOTIENT DELTAX DELTA)))
-                                        (SETQ DELTAY (\CONVERTTOFRACTION (FQUOTIENT DELTAY DELTA)))
-                                        (SETQ TX (\CONVERTTOFRACTION OOLDX))
-                                        (SETQ TY (\CONVERTTOFRACTION OOLDY))
-                                        (for I from 0 to DELTA do (\HQFX80.SMOOTH-CURVE (
-                                                                                      \GETINTEGERPART
-                                                                                         TX)
-                                                                         (\GETINTEGERPART TY)
-                                                                         USERFN HQFX80STREAM)
-                                                                  (\BOXIPLUS TX DELTAX)
-                                                                  (\BOXIPLUS TY DELTAY]
-                                                             (* ; "draw the end point")
-              (COND
-                 (USERFN (\HQFX80.SMOOTH-CURVE X1 Y1 USERFN HQFX80STREAM))
-                 (T (\HQFX80.SMOOTH-CURVE (IDIFFERENCE X1 (LRSH (SUB1 BRUSHWIDTH)
-                                                                1))
-                           (IDIFFERENCE Y1 (LRSH (SUB1 BRUSHHEIGHT)
-                                                 1))
-                           NIL HQFX80STREAM)))
-              (AND HQFX80STREAM (MOVETO (FIX X1)
-                                       (FIX Y1)
-                                       HQFX80STREAM]
-          (COND
-             (ENDING (\HQFX80.SMOOTH-CURVE (IPLUS \CURX \CURX (IMINUS \OLDX))
-                            (IPLUS \CURY \CURY (IMINUS \OLDY))
-                            USERFN HQFX80STREAM)
-                    (\HQFX80.SMOOTH-CURVE (IPLUS \CURX \CURX (IMINUS \OLDX))
-                           (IPLUS \CURY \CURY (IMINUS \OLDY))
-                           USERFN HQFX80STREAM)))
-          (RETURN NIL])
-
-(\HQFX80.LINEWITHBRUSH
-  [LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST HQFX80STREAM BBT)       (* ; "Edited  5-Jan-87 16:57 by hdj")
-          
-          (* ;; "draws a line with a brush on a HQFX80STREAM")
-
-    (DECLARE (LOCALVARS . T))
-    (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM)
-           (PROG (DESTINATION-BITMAP LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH 
-                        BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH 
-                        BRUSHRASTERWIDTH OPERATION HEIGHTMINUS1 HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY 
-                        YINC CDL (DASHON T)
-                        (DASHTAIL DASHLST)
-                        (DASHCNT (CAR DASHLST))
-                        (USERFN (AND (LITATOM BRUSH)
-                                     BRUSH)))
-          
-          (* ;; "many of these variables are used by the macro for \HQFX80.CURVEPT that passes them to \HQFX80.BBTCURVEPT and .SETUP.FOR.\\HQFX80.BBTCURVEPT.  sets them up.")
-
-                 [COND
-                    ((NOT USERFN)
-                     (.SETUP.FOR.\HQFX80.BBTCURVEPT. HQFX80DATA)
-                                                             (* ; 
-    "SUB1 is so that the extra bit goes on the top and right as it is documented as doing for lines.")
-                     [SETQ X1 (- X1 (SETQ HALFBRUSHWIDTH (FOLDLO (SUB1 BRUSHWIDTH)
-                                                                2]
-                     (SETQ X2 (- X2 HALFBRUSHWIDTH))
-                     [SETQ Y1 (- Y1 (SETQ HALFBRUSHHEIGHT (FOLDLO (SUB1 BRUSHHEIGHT)
-                                                                 2]
-                                                             (* ; 
-                                                             "take into account the brush thickness.")
-                     (SETQ Y2 (- Y2 HALFBRUSHHEIGHT]         (* ; 
-                                                             "arrange things so that dx is positive.")
-                 (COND
-                    ((> X1 X2)                               (* ; "switch points")
-                     (swap X1 X2)
-                     (swap Y1 Y2)))
-                 (SETQ DX (ADD1 (- X2 X1)))
-                 [SETQ DY (ADD1 (COND
-                                   ((> Y2 Y1)
-                                    (SETQ YINC 1)
-                                    (- Y2 Y1))
-                                   (T (SETQ YINC -1)
-                                      (- Y1 Y2]
-                 [SETQ CDL (HALF (COND
-                                    ((> DX DY)               (* ; 
-                                               "set up the bucket so that the ends will be the same.")
-                                     (IREMAINDER DX DY))
-                                    (T (IREMAINDER DY DX]
-                 [COND
-                    [USERFN                                  (* ; 
-             "if user function is being called, don't bother bringing window to top uninterruptably.")
-                           (COND
-                              ((IGEQ DX DY)                  (* ; "X is the fastest mover.")
-                               (until (> X1 X2)
-                                  do                         (* ; "main loop")
-                                     (COND
-                                        (DASHON (APPLY* USERFN X1 Y1 HQFX80STREAM)))
-                                     [COND
-                                        (DASHTAIL            (* ; "do dashing.")
-                                               (COND
-                                                  ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
-                                                   (SETQ DASHON (NOT DASHON))
-                                                   (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
-                                                                      DASHLST))
-                                                   (SETQ DASHCNT (CAR DASHTAIL]
-                                     [COND
-                                        ((NOT (> DX (add CDL DY)))
-                                         (add Y1 YINC)
-                                         (COND
-                                            ((COND
-                                                ((EQ YINC -1)
-                                                 (ILESSP Y1 Y2))
-                                                ((> Y1 Y2)))
-                                             (RETURN)))
-                                         (SETQ CDL (- CDL DX]
-                                     (add X1 1)))
-                              (T                             (* ; "Y is the fastest mover.")
-                                 (until (COND
-                                           ((EQ YINC -1)
-                                            (ILESSP Y1 Y2))
-                                           ((> Y1 Y2)))
-                                    do                       (* ; "main loop")
-                                       (COND
-                                          (DASHON (APPLY* USERFN X1 Y1 HQFX80STREAM)))
-                                       [COND
-                                          (DASHTAIL          (* ; "do dashing.")
-                                                 (COND
-                                                    ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
-                                                     (SETQ DASHON (NOT DASHON))
-                                                     (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
-                                                                        DASHLST))
-                                                     (SETQ DASHCNT (CAR DASHTAIL]
-                                       [COND
-                                          ([NOT (> DY (SETQ CDL (+ CDL DX]
-                                           (COND
-                                              ((> (SETQ X1 (ADD1 X1))
-                                                  X2)
-                                               (RETURN)))
-                                           (SETQ CDL (- CDL DY]
-                                       (add Y1 YINC]
-                    (T (COND
-                          [(IGEQ DX DY)                      (* ; "X is the fastest mover.")
-                           (until (> X1 X2) do               (* ; "main loop")
-                                               (COND
-                                                  (DASHON (\HQFX80.CURVEPT X1 Y1)))
-                                               [COND
-                                                  (DASHTAIL  (* ; "do dashing.")
-                                                         (COND
-                                                            ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
-                                                             (SETQ DASHON (NOT DASHON))
-                                                             (SETQ DASHTAIL
-                                                              (OR (LISTP (CDR DASHTAIL))
-                                                                  DASHLST))
-                                                             (SETQ DASHCNT (CAR DASHTAIL]
-                                               [COND
-                                                  ([NOT (> DX (SETQ CDL (+ CDL DY]
-                                                   (SETQ Y1 (+ Y1 YINC))
-                                                   (COND
-                                                      ((COND
-                                                          ((EQ YINC -1)
-                                                           (ILESSP Y1 Y2))
-                                                          ((> Y1 Y2)))
-                                                       (RETURN)))
-                                                   (SETQ CDL (- CDL DX]
-                                               (SETQ X1 (ADD1 X1]
-                          (T                                 (* ; "Y is the fastest mover.")
-                             (until (COND
-                                       ((EQ YINC -1)
-                                        (ILESSP Y1 Y2))
-                                       ((> Y1 Y2)))
-                                do                           (* ; "main loop")
-                                   (COND
-                                      (DASHON (\HQFX80.CURVEPT X1 Y1)))
-                                   [COND
-                                      (DASHTAIL              (* ; "do dashing.")
-                                             (COND
-                                                ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
-                                                 (SETQ DASHON (NOT DASHON))
-                                                 (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
-                                                                    DASHLST))
-                                                 (SETQ DASHCNT (CAR DASHTAIL]
-                                   [COND
-                                      ([NOT (> DY (SETQ CDL (+ CDL DX]
-                                       (COND
-                                          ((> (SETQ X1 (ADD1 X1))
-                                              X2)
-                                           (RETURN)))
-                                       (SETQ CDL (- CDL DY]
-                                   (SETQ Y1 (+ Y1 YINC]
-                 (RETURN NIL])
-)
-(DEFINEQ
-
-(\HQFX80.BBTCURVEPT
-  [LAMBDA (X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 TOPMINUSBRUSH DESTINATION-BITMAP 
-             BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH BRUSHRASTERWIDTH 
-             HQFX80DATA)                                     (* hdj " 6-Nov-86 14:36")
-          
-          (* ;; "Called by \hqfx80.CURVEPT macro.  Draws a brush point by bitblting BRUSHBM to point X,Y in DestinationBitMap.  BBT is a BitBlt table where everything is already set except the source and destination addresses, width and height.  In other words, only the easy stuff")
-                                                             (* ; "")
-                                                             (* ; "set the width fields of the bbt")
-    [PROG (CLIPPEDTOP STY)
-          [COND
-             [(ILEQ Y TOPMINUSBRUSH)                         (* ; 
-                                                             "the top part of the brush is visible")
-              (SETQ CLIPPEDTOP (IPLUS Y BRUSHHEIGHT))
-              (replace PBTSOURCE of BBT with BRUSHBASE)
-              (replace PBTHEIGHT of BBT with (IMIN BRUSHHEIGHT (IDIFFERENCE Y BOTTOMMINUSBRUSH]
-             (T                                              (* ; "only the bottom is visible")
-                (SETQ CLIPPEDTOP TOP)
-                [replace PBTSOURCE of BBT with (\ADDBASE BRUSHBASE (ITIMES BRUSHRASTERWIDTH
-                                                                          (SETQ STY (IDIFFERENCE
-                                                                                     Y TOPMINUSBRUSH]
-                (replace PBTHEIGHT of BBT with (IDIFFERENCE (IMIN BRUSHHEIGHT (IDIFFERENCE Y 
-                                                                                     BOTTOMMINUSBRUSH
-                                                                                     ))
-                                                      STY]
-          (replace PBTDEST of BBT with (\ADDBASE DESTINATIONBASE (ITIMES RASTERWIDTH (\SFInvert
-                                                                                      
-                                                                                   DESTINATION-BITMAP 
-                                                                                      CLIPPEDTOP]
-    [COND
-       [(ILESSP X LEFT)                                      (* ; 
-                                                        "only the right part of the brush is visible")
-        (replace PBTDESTBIT of BBT with LEFT)
-        (replace PBTSOURCEBIT of BBT with (IDIFFERENCE BRUSHWIDTH (replace PBTWIDTH of BBT
-                                                                     with (IDIFFERENCE X 
-                                                                                 LEFTMINUSBRUSH]
-       (T                                                    (* ; "left edge is visible")
-          (replace PBTDESTBIT of BBT with X)
-          (replace PBTSOURCEBIT of BBT with 0)               (* ; 
-                                                            "set width to the amount that is visible")
-          (replace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE RIGHTPLUS1 X]
-    (\PILOTBITBLT BBT 0])
-)
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \HQFX80.CURVEPT MACRO [OPENLAMBDA (X Y)
-
-                                 (* ;; "puts a brush shape at point X,Y.  Assumes X and Y have been corrected so that it is the lower left corner of the brush.  Does a clipping to the region defined by LEFT RIGHTPLUS1 BOTTOM and LEFTMINUSBRUSH TOPMINUSBRUSH BOTTOMMINUSBRUSH.")
-
-                                  (COND
-                                     ((OR (ILEQ X LEFTMINUSBRUSH)
-                                          (IGEQ X RIGHTPLUS1)
-                                          (ILEQ Y BOTTOMMINUSBRUSH)
-                                          (IGEQ Y TOP))      (* ; "Brush is entirely out of region")
-                                      NIL)
-                                     ((NULL BBT)             (* ; 
-                                                             "Special case of single point brush")
-                                      (\FBITMAPBIT DESTINATIONBASE X Y OPERATION HEIGHTMINUS1 
-                                             RASTERWIDTH))
-                                     (T                      (* ; 
-                                                            "Some part of the brush in in the region")
-                                        (\HQFX80.BBTCURVEPT X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH 
-                                               RIGHTPLUS1 TOPMINUSBRUSH DESTINATION-BITMAP 
-                                               BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE 
-                                               DESTINATIONBASE RASTERWIDTH BRUSHRASTERWIDTH 
-                                               HQFX80DATA])
-)
-
-(DEFMACRO \HQFX80.SMOOTH-CURVE (NEWX NEWY USERFN HQFX80STREAM)
-   `(LET [(DX (IABS (- ,NEWX \OLDX)))
-          (DY (IABS (- ,NEWY \OLDY]
-         (COND
-            ((OR (> DX 1)
-                 (> DY 1))
-             [COND
-                ((NEQ [+ (ADD1 (- \OLDX \OLDERX))
-                         (ITIMES 3 (ADD1 (- \OLDY \OLDERY]
-                      4)
-                 [COND
-                    (DASHON (COND
-                               (,USERFN (APPLY* ,USERFN \OLDX \OLDY ,HQFX80STREAM))
-                               (T (\HQFX80.CURVEPT \OLDX \OLDY]
-                 (COND
-                    (DASHTAIL (COND
-                                 ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
-                                  (SETQ DASHON (NOT DASHON))
-                                  (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
-                                                     DASHLST))
-                                  (SETQ DASHCNT (CAR DASHTAIL]
-             (SETQ \OLDERX \OLDX)
-             (SETQ \OLDERY \OLDY)
-             (SETQ \OLDX \CURX)
-             (SETQ \OLDY \CURY)))
-         (SETQ \CURX ,NEWX)
-         (SETQ \CURY ,NEWY)))
-
-(DEFMACRO .SETUP.FOR.\HQFX80.BBTCURVEPT. (HQFX80DATA)
-   `(LET [(CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION ,HQFX80DATA]
-         (SETQ BOTTOM (ffetch (REGION BOTTOM) of CLIPPINGREGION))
-         (SETQ TOP (ffetch (REGION TOP) of CLIPPINGREGION))
-         (SETQ RIGHTPLUS1 (ffetch (REGION RIGHT) of CLIPPINGREGION))
-         (SETQ LEFT (ffetch (REGION LEFT) of CLIPPINGREGION))
-         (SETQ DESTINATION-BITMAP (HQFX80DATA-BACKINGBITMAP ,HQFX80DATA))
-         (SETQ OPERATION (HQFX80DATA-OPERATION ,HQFX80DATA))
-         (SETQ BRUSHBM (\GETBRUSH BRUSH))
-         (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of DESTINATION-BITMAP))
-         (SETQ DESTINATIONBASE (fetch (BITMAP BITMAPBASE) of DESTINATION-BITMAP))
-         (SETQ BBT (\HQFX80.CREATE-BRUSH-BBT BRUSHBM ,HQFX80DATA BBT))
-         (SETQ BRUSHBASE (fetch (BITMAP BITMAPBASE) of BRUSHBM))
-
-         (* ;; "keep Brush width and raster width in number of bits units.")
-
-         (SETQ BRUSHRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BRUSHBM))
-         [COND
-            ((NULL BBT)
-
-             (* ;; "BBT is NIL if single point brush.  Set the destination bitmap base.")
-
-             (SETQ HEIGHTMINUS1 (SUB1 (fetch (BITMAP BITMAPHEIGHT) of DESTINATION-BITMAP)))
-             (COND
-                ((EQ (HQFX80DATA-OPERATION ,HQFX80DATA)
-                     'INVERT)
-
-                 (* ;; "really do invert in single brush case.")
-
-                 (SETQ OPERATION 'INVERT]
-         (SETQ BRUSHWIDTH (fetch (BITMAP BITMAPWIDTH) of BRUSHBM))
-         (SETQ BRUSHHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM))
-         (SETQ LEFTMINUSBRUSH (IDIFFERENCE LEFT BRUSHWIDTH))
-         (SETQ BOTTOMMINUSBRUSH (IDIFFERENCE BOTTOM BRUSHHEIGHT))
-         (SETQ TOPMINUSBRUSH (IDIFFERENCE TOP BRUSHHEIGHT))))
-
-
-
-(* ;; "character printing methods")
-
-(DEFINEQ
-
-(\HQFX80.OUTCHAR
-  [LAMBDA (HQFX80STREAM CHARCODE)                            (* ; "Edited  4-Feb-87 15:11 by hdj")
-          
-          (* ;; "Displays the character and increments the Xposition on the HQFX80STREAM.")
-
-    (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM)
-          
-          (* ;; "If necessary, change the charset ")
-
-           (if (NEQ (HQFX80DATA-CHARSET-CACHE HQFX80DATA)
-                    (\CHARSET CHARCODE))
-               then (\HQFX80.CHANGE-CHARSET HQFX80DATA (\CHARSET CHARCODE)))
-           (SELCHARQ CHARCODE
-                (^L                                          (* ; "form-feed")
-                    (\HQFX80.NEWPAGE HQFX80STREAM))
-                ((EOL CR LF)                                 (* ; "various line-enders")
-                     (\HQFX80.NEWLINE CHARCODE HQFX80STREAM))
-                (LET ((CHARWIDTH (\HQFX80.CHARWIDTH HQFX80STREAM CHARCODE)))
-          
-          (* ;; "if character will be at least partly visible, output it")
-
-                     (if (\HQFX80.CUR-POS-VISIBLE? HQFX80DATA)
-                         then (IF (NEQ CHARCODE (CHARCODE SPACE))
-                                  THEN 
-          
-          (* ;; 
-   "only bitblt real, printing characters -- pilotbbt won't do the right thing with amplified spaces")
-
-                                       (\HQFX80.BLT-CHAR CHARCODE CHARWIDTH HQFX80STREAM HQFX80DATA))
-                         )
-                     (CL:INCF (HQFX80DATA-XPOS HQFX80DATA)
-                            CHARWIDTH)
-          
-          (* ;; "if we've passed the margin, DING!, do a newline")
-
-                     (if (> (HQFX80DATA-XPOS HQFX80DATA)
-                            (HQFX80DATA-RIGHTMARGIN HQFX80DATA))
-                         then (\HQFX80.NEWLINE (CHARCODE EOL)
-                                     HQFX80STREAM])
-
-(\HQFX80.BLT-CHAR
-  [LAMBDA (CHARCODE CHARWIDTH HQFX80STREAM HQFX80DATA)       (* ; "Edited 12-Feb-87 14:17 by jds")
-          
-          (* ;; "puts a character on an HQFX80 stream.  Much of the information needed by the BitBlt microcode is prestored by the routines that change it.  This is kept in the BitBltTable.")
-                                                             (* (DECLARE (LOCALVARS . T)))
-    (LET* ((CURX (FIXR (HQFX80DATA-XPOS HQFX80DATA)))
-           (CHAR8CODE (\CHAR8CODE CHARCODE))
-           (RIGHT (+ CURX CHARWIDTH))
-           (LEFT NIL)
-           (CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION HQFX80DATA))
-           (RIGHT-CLIPPING-EDGE (fetch (REGION RIGHT) of CLIPPINGREGION))
-           (LEFT-CLIPPING-EDGE (fetch (REGION LEFT) of CLIPPINGREGION))
-           (PILOTBBT (HQFX80DATA-PILOTBBT HQFX80DATA)))
-
-(* ;;; "clip the bitmap to fit the stream's clipping region")
-          
-          (* ;; "does character overlap right edge of clipping region?")
-
-          (SETQ RIGHT (MIN RIGHT-CLIPPING-EDGE RIGHT))
-          
-          (* ;; "does character overlap left edge of clipping region?")
-
-          (SETQ LEFT (MAX CURX LEFT-CLIPPING-EDGE))
-          (COND
-             ((AND (< LEFT RIGHT)
-                   (NEQ (fetch (PILOTBBT PBTHEIGHT) of PILOTBBT)
-                        0))
-              (UNINTERRUPTABLY
-                  (freplace (PILOTBBT PBTDESTBIT) of PILOTBBT with LEFT)
-                  (freplace (PILOTBBT PBTWIDTH) of PILOTBBT with (- RIGHT LEFT))
-                  (freplace (PILOTBBT PBTSOURCEBIT) of PILOTBBT with (- (+ (
-                                                                         \HQFX80.GET-CHARACTER-OFFSET
-                                                                            CHAR8CODE HQFX80DATA)
-                                                                           LEFT)
-                                                                        CURX))
-                  (\PILOTBITBLT PILOTBBT 0))
-              T])
-)
-
-
-
-(* ;; "printer code")
-
-(DEFINEQ
-
-(\HQFX80.DUMP-PAGE-BUFFER
-  [LAMBDA (BITMAP HQFX80STREAM)                          (* ; "Edited 23-Sep-88 10:25 by jds")
-
-(* ;;; "send a bitmap to the FX-80")
-
-    (* ;; "how it works: we use a specially created bitblt table (HQFX80DATA-SERIALIZING-PILOTBBT) to turn eight-bit-high by one-bit-wide columns of BITMAP into eight-bit-wide by one-bit-high bytes.  This extraction is done by \HQFX80.BITMAP-LDB.")
-
-    (DECLARE (LOCALVARS . T))
-    (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM)
-           (LET* ((WIDTH (BITMAPWIDTH BITMAP))
-                  (WIDTH-MINUS-1 (SUB1 WIDTH))
-                  [HEIGHT (FIX (TIMES \HQFX80.INCHES-PER-PAGE (if (HQFX80DATA-COMPRESSED? 
-                                                                             HQFX80DATA)
-                                                                  then 
-                                                                    \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI
-                                                                else \HQFX80.1-TO-1-MODE-DPI]
-                  (HEIGHT-MINUS-1 (SUB1 HEIGHT))
-                  (BACKING-STREAM (HQFX80DATA-BACKINGSTREAM HQFX80DATA))
-                  (BITMAP-BASE (fetch (BITMAP BITMAPBASE) of BITMAP))
-                  (BITMAP-WIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP))
-                  (MAPPING-TABLE (HQFX80DATA-SERIALIZING-PILOTBBT HQFX80DATA))
-                  (BYTE-BOX (HQFX80DATA-SERIALIZING-BOX HQFX80DATA))
-                  (SCRATCH-SCANLINE-PILOTBBT (HQFX80DATA-SCRATCH-SCANLINE-PILOTBBT HQFX80DATA))
-                  (EIGHT-LINES-BLANK (HQFX80DATA-EIGHT-LINES-BLANK HQFX80DATA))
-                  (EIGHT-LINES-BLANK-PILOTBBT (HQFX80DATA-EIGHT-LINES-BLANK-PILOTBBT HQFX80DATA))
-                  (COMPRESSED? (HQFX80DATA-COMPRESSED? HQFX80DATA)))
-
-                 (* ;; "set the mode")
-
-                 (\HQFX80.PRINTER-MODE :UNIDIRECTIONAL-ON BACKING-STREAM)
-                 (\HQFX80.PRINTER-MODE :EIGHT-SPACING-ON BACKING-STREAM)
-
-                 (* ;; "pack the bitmap into FX80 format and ship it")
-
-                 [for EIGHT-SCANLINE-SWATH from 0 to HEIGHT-MINUS-1 by 8
-                    do [COND
-                              ((ILESSP (IDIFFERENCE HEIGHT-MINUS-1 EIGHT-SCANLINE-SWATH)
-                                      8)                     (* ; 
-           "There are fewer than 8 scan lines left on the page image; only advance by that amount.")
-                               (\HQFX80.PRINTER-MODE :N-SPACING-ON BACKING-STREAM
-                                      (IDIFFERENCE HEIGHT-MINUS-1 EIGHT-SCANLINE-SWATH]
-                          (COND
-                             ((\HQFX80.EIGHT-LINES-BLANK? BITMAP-BASE EIGHT-SCANLINE-SWATH 
-                                     BITMAP-WIDTH SCRATCH-SCANLINE-PILOTBBT 
-                                     EIGHT-LINES-BLANK-PILOTBBT EIGHT-LINES-BLANK)
-
-                              (* ;; "skip the next eight blank lines")
-
-                              (\HQFX80.PRINTER-MODE :EIGHT-SPACING-ON BACKING-STREAM)
-                              (\HQFX80.ADVANCE-8-LINES HQFX80STREAM))
-                             (T 
-                                (* ;; "something to print in the next eight scanlines; do so")
-
-                                (\HQFX80.PRINTER-MODE :EIGHT-SPACING-ON BACKING-STREAM)
-                                (\HQFX80.GRAPHICS-MODE WIDTH COMPRESSED? BACKING-STREAM)
-                                (for COLUMN from 0 to WIDTH-MINUS-1
-                                   do (\HQFX80.BITMAP-LDB BITMAP-BASE COLUMN EIGHT-SCANLINE-SWATH
-                                                 MAPPING-TABLE BITMAP-WIDTH)
-                                         (BOUT BACKING-STREAM (\GETBASEBYTE BYTE-BOX 0)))
-                                (BOUT BACKING-STREAM (CHARCODE CR))
-                                (BOUT BACKING-STREAM (CHARCODE LF]
-                 (\HQFX80.PRINTER-MODE :UNIDIRECTIONAL-OFF BACKING-STREAM)
-                 (\HQFX80.PRINTER-MODE :TWELVE-SPACING-ON BACKING-STREAM])
-
-(\HQFX80.ADVANCE-8-LINES
-  [LAMBDA (HQFX80STREAM)                                     (* ; "Edited 11-Feb-87 11:03 by jds")
-          
-          (* ;; "advance the printhead 8 raster lines.  since we assume that we're in the :eight-spacing-on printermode, just send an LF")
-
-    (\HQFX80.BOUT HQFX80STREAM (CHARCODE LF])
-)
-
-(DEFMACRO \HQFX80.EIGHT-LINES-BLANK? (BITMAP-BASE Y-COORD BITMAP-WIDTH-IN-WORDS EIGHT-INTO-ONE-PBBT 
-                                            SCANLINE-INTO-WORD-PBBT WORD-BOX)
-
-   (* ;; "returns T if the next 8 lines of the bitmap are all blank.  This is done by or'ing the 8 scanlines into a scratch bitmap, then or'ing the words of that scanline into a result word, and comparing that to 0.  We clear the scanline and word buffers at the end.")
-
-   `(LET ((EIGHT-INTO-ONE-PBBT ,EIGHT-INTO-ONE-PBBT)
-          (SCANLINE-INTO-WORD-PBBT ,SCANLINE-INTO-WORD-PBBT)
-          (WORD-BOX ,WORD-BOX)
-          (BITMAP-WIDTH-IN-WORDS ,BITMAP-WIDTH-IN-WORDS))
-         [FREPLACE (PILOTBBT PBTSOURCE) OF EIGHT-INTO-ONE-PBBT WITH (\ADDBASE ,BITMAP-BASE
-                                                                           (TIMES 
-                                                                                  ,
-                                                                                BITMAP-WIDTH-IN-WORDS
-                                                                                  ,Y-COORD]
-         (\PILOTBITBLT EIGHT-INTO-ONE-PBBT 0)
-         (\PILOTBITBLT SCANLINE-INTO-WORD-PBBT 0)
-         (PROG1 (EQ (\GETBASE WORD-BOX 0)
-                    0)
-             (\HQFX80.CLEAR-SCANLINE EIGHT-INTO-ONE-PBBT BITMAP-WIDTH-IN-WORDS)
-             (\HQFX80.CLEAR-WORD-BOX WORD-BOX))))
-
-(DEFMACRO \HQFX80.BITMAP-LDB (BITMAP-BASE X Y PILOTBBT BITMAP-WIDTH-IN-WORDS)
-
-   (* ;; "point the serializing bitblt table at a new column of the bitmap.  The X coord increases left to right, the Y coord increases top to bottom, and names the uppermost pixel of the column we're moving.")
-
-   `(LET ((X ,X)
-          (PILOTBBT ,PILOTBBT))
-         [FREPLACE (PILOTBBT PBTSOURCE) OF PILOTBBT WITH (\ADDBASE ,BITMAP-BASE
-                                                                (+ (TIMES ,Y ,BITMAP-WIDTH-IN-WORDS)
-                                                                   (FOLDLO X BITSPERWORD]
-         (FREPLACE (PILOTBBT PBTSOURCEBIT) OF PILOTBBT WITH (LOGAND 15 X))
-         (\PILOTBITBLT PILOTBBT 0)))
-
-(DEFMACRO \HQFX80.CLEAR-SCANLINE (SCANLINE-PILOTBBT SCANLINE-WIDTH-IN-WORDS)
-
-   (* ;; "clear out the destination of the pilotbbt the fast way - store a zero in its last word and perform an overlapping blt (which runs back to front).")
-
-   `(LET [(SCANLINE (FETCH (PILOTBBT PBTDEST) OF ,SCANLINE-PILOTBBT))
-          (LAST-WORD (SUB1 ,SCANLINE-WIDTH-IN-WORDS]
-         (\PUTBASE SCANLINE LAST-WORD 0)
-         (\BLT SCANLINE (\ADDBASE SCANLINE 1)
-               LAST-WORD)))
-
-(DEFMACRO \HQFX80.CLEAR-WORD-BOX (WORD-BOX)
-   `(\PUTBASE ,WORD-BOX 0 0))
-
-(CL:DEFUN \HQFX80.SEND (PRINTER FILENAME &OPTIONAL OPTIONS)
-
-   (* ;; "send the file designated by FILENAME to PRINTER, obeying OPTIONS.  Since we only have one fx-80 per machine, ignore PRINTER and send to HQFX80-DEFAULT-DESTINATION")
-
-   (DECLARE (GLOBALVARS HQFX80-DEFAULT-DESTINATION))
-   [LET ((COPIES (OR (LISTGET OPTIONS '%#COPIES)
-                     1)))
-        (FOR COPY FROM 1 TO COPIES DO 
-                                      (* ;; "allow the user to abort it while running")
-
-                                      (WITH-ABORT-WINDOW ((THIS.PROCESS)
-                                                          FILENAME PRINTER COPY)
-                                             (COPYFILE FILENAME HQFX80-DEFAULT-DESTINATION
-                                                    '((TYPE HQFX80])
-
-(CL:DEFUN MAKE-HQFX80 (FILE HQFX80FILE &OPTIONAL FONTS HEADING TABS OPTIONS)
-
-   (* ;; "turn FILE into an HQFX80 master")
-
-   (TEXTTOIMAGEFILE FILE HQFX80FILE 'HQFX80 FONTS HEADING TABS OPTIONS))
-
-(CL:DEFUN HQFX80FILEP (HQFX80FILE?)
-
-   (* ;; "is FILE (a filename or stream) an hqfx80 file?")
-
-   [LET [(FILE-TYPE (GETFILEINFO HQFX80FILE? 'TYPE]
-        (IF (EQ FILE-TYPE 'HQFX80)
-            THEN                                             (* ; 
-                                                        "if file has a type, and type=HQFX80, we win")
-                 T
-          ELSE                                               (* ; 
-                                               "no filetype or filetype not HQFX80, so read the file")
-               (LET [(STREAM (OPENSTREAM (INTERLISP-NAMESTRING HQFX80FILE?)
-                                    'INPUT
-                                    'OLD
-                                    '(SEQUENTIAL]
-
-                    (* ;; "file looks like ESC@<signature>...")
-
-                    (PROG1 [AND (> (GETFILEINFO STREAM 'LENGTH)
-                                   (+ 2 (NCHARS \HQFX80.FILE-SIGNATURE)))
-                                (EQ (CHARCODE ESC)
-                                    (BIN STREAM))
-                                (EQ (CHARCODE @)
-                                    (BIN STREAM))
-                                (FOR CH INSTRING \HQFX80.FILE-SIGNATURE
-                                   ALWAYS (EQ CH (BIN STREAM]
-                           (CLOSEF STREAM])
-
-
-
-(* ;; "window hardcopy")
-
-(DEFINEQ
-
-(\HQFX80.BITMAP-FILE
-  [LAMBDA (FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)    (* ; "Edited  1-Jun-87 13:10 by Snow")
-          
-          (* ;; "print a bitmap on the fx-80.  ignore SCALEFACTOR and ROTATION for now.")
-
-    (LET* ((HQFX80STREAM (OPENIMAGESTREAM FILE 'HQFX80))
-           (NEWBITMAP (COND
-                         (REGION (BITMAPCREATE (fetch (REGION WIDTH) of REGION)
-                                        (fetch (REGION HEIGHT) of REGION)))
-                         (T BITMAP)))
-           (WIDTH (BITMAPWIDTH NEWBITMAP))
-           (HEIGHT (BITMAPHEIGHT NEWBITMAP))
-           (PAGE-REGION (DSPCLIPPINGREGION NIL HQFX80STREAM))
-           (PAGE-WIDTH (fetch (REGION WIDTH) of PAGE-REGION))
-           (PAGE-HEIGHT (fetch (REGION HEIGHT) of PAGE-REGION)))
-          
-          (* ;; "clip the bitmap, if requested")
-
-          (AND REGION (BITBLT BITMAP (fetch (REGION LEFT) of REGION)
-                             (fetch (REGION BOTTOM) of REGION)
-                             NEWBITMAP))
-          (LET* ((PORTRAIT-OVERHANG (- WIDTH (fetch (REGION WIDTH) of PAGE-REGION)))
-                 (LANDSCAPE-OVERHANG (- HEIGHT (fetch (REGION WIDTH) of PAGE-REGION)))
-                 (BITS-LOST (AND (> PORTRAIT-OVERHANG 0)
-                                 (> LANDSCAPE-OVERHANG 0)))
-                 (LANDSCAPE-PRINT (> PORTRAIT-OVERHANG LANDSCAPE-OVERHANG)))
-          
-          (* ;; "print the title of the image on the top of the page")
-
-                (LET* ((IMAGE-TITLE (OR TITLE "Window Image"))
-                       (TITLE-REGION (STRINGREGION IMAGE-TITLE HQFX80STREAM)))
-                      (MOVETO (/ (- PAGE-WIDTH (fetch (REGION WIDTH) of TITLE-REGION))
-                                 2)
-                             (- (- PAGE-HEIGHT 1)
-                                (FONTPROP HQFX80STREAM 'HEIGHT))
-                             HQFX80STREAM)
-                      (PRIN1 IMAGE-TITLE HQFX80STREAM))
-          
-          (* ;; "blt the bitmap onto the page.  use replace mode so it will obscure title if need be")
-
-                [COND
-                   (BITS-LOST 
-          
-          (* ;; "apologize and blt as much as will fit")
-
-                          (PRINTOUT PROMPTWINDOW "Bitmap is larger than FX-80 page - " 
-                                 "image will be clipped" T)
-                          (BITBLT NEWBITMAP NIL NIL HQFX80STREAM 0 0 NIL NIL 'INPUT 'REPLACE))
-                   (T 
-          
-          (* ;; "center it on the page ")
-          
-          (* ;; "if there is more overhang in portrait than in landscape  - rotate it remember to swap the height and width.")
-
-                      (AND LANDSCAPE-PRINT (SETQ NEWBITMAP (ROTATE-BITMAP NEWBITMAP))
-                           (swap WIDTH HEIGHT))
-                      (BITBLT NEWBITMAP NIL NIL HQFX80STREAM (/ (- PAGE-WIDTH WIDTH)
-                                                                2)
-                             (/ (- PAGE-HEIGHT HEIGHT)
-                                2)
-                             NIL NIL 'INPUT 'REPLACE]
-                (CLOSEF HQFX80STREAM])
-
-(\HQFX80.CONVERT-TEDIT
-  [LAMBDA (TEDIT-FILE IMAGESTREAM)                           (* ; "Edited 11-Dec-86 17:24 by hdj")
-          
-          (* ;; "Send the text to the printer.")
-
-    (SETQ TEDIT-FILE (OPENTEXTSTREAM TEDIT-FILE))
-    (TEDIT.FORMAT.HARDCOPY TEDIT-FILE IMAGESTREAM T NIL NIL NIL 'HQFX80)
-    (CLOSEF? IMAGESTREAM)
-    IMAGESTREAM])
-)
-
-
-
-(* ;; "character transmission method")
-
-(DEFINEQ
-
-(\HQFX80.BOUT
-  [LAMBDA (HQFX80SSTREAM BYTE)                               (* hdj " 7-Nov-86 17:18")
-          
-          (* ;; "send a byte to the fx80")
-
-    (WITH-HQFX80-DATA (DATA HQFX80SSTREAM)
-           (BOUT (HQFX80DATA-BACKINGSTREAM DATA)
-                 BYTE])
-)
-
-
-
-(* ;; "handling font-information caching")
-
-(DEFINEQ
-
-(\HQFX80.FIX-LINE-LENGTH
-  [LAMBDA (HQFX80STREAM)                                     (* hdj "14-Nov-86 17:15")
-          
-          (* ;; "HQFX80STREAM is a stream of type hqfx80.  Called by RIGHTMARGIN LEFTMARGIN and \hqfx80.fix-font to update the LINELENGTH field in the stream.  Also called when the stream is created.")
-
-    (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-           (freplace (STREAM LINELENGTH) of HQFX80STREAM
-              with (MIN MAX.SMALLP (MAX 1 (IQUOTIENT (- (HQFX80DATA-RIGHTMARGIN DATA)
-                                                        (HQFX80DATA-LEFTMARGIN DATA))
-                                                 (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH)
-                                                    of (HQFX80DATA-FONT DATA])
-
-(\HQFX80.FIX-FONT
-  [LAMBDA (HQFX80STREAM HQFX80DATA)                          (* hdj "10-Nov-86 16:37")
-          
-          (* ;; "used to fix up those parts of the bitblt table which depend upon the FONT.")
-
-    (\HQFX80.INVALIDATE-CACHE HQFX80DATA)
-    (\HQFX80.FIX-LINE-LENGTH HQFX80STREAM])
-
-(\HQFX80.FIX-Y
-  [LAMBDA (HQFX80DATA CSINFO)                                (* ; "Edited 12-Feb-87 11:46 by jds")
-          
-          (* ;; "makes that part of the bitblt table of an HQFX80 stream which deals with the Y information consistent.  This is called from \\HQFX80.change-charset whenever a character is being printed and the charset/y-position caches are invalid")
-
-    (PROG ((PBT (HQFX80DATA-PILOTBBT HQFX80DATA))
-           (Y (HQFX80DATA-YPOS HQFX80DATA))
-           TOP CHARTOP BM)
-          [SETQ CHARTOP (FIXR (+ Y (CL:SETF (HQFX80DATA-CHARSET-ASCENT-CACHE HQFX80DATA)
-                                          (ffetch CHARSETASCENT of CSINFO]
-          [freplace PBTDEST of PBT
-             with (\ADDBASE (fetch BITMAPBASE of (SETQ BM (HQFX80DATA-BACKINGBITMAP HQFX80DATA)))
-                         (TIMES (ffetch BITMAPRASTERWIDTH of BM)
-                                (\SFInvert BM (SETQ TOP (FIXR (MAX (MIN (fetch (REGION TOP)
-                                                                           of (
-                                                                            HQFX80DATA-CLIPPINGREGION
-                                                                               HQFX80DATA))
-                                                                        CHARTOP)
-                                                                   0]
-          [freplace PBTSOURCE of PBT
-             with (\ADDBASE (ffetch BITMAPBASE of (SETQ BM (ffetch (CHARSETINFO CHARSETBITMAP)
-                                                              of CSINFO)))
-                         (TIMES (ffetch BITMAPRASTERWIDTH of BM)
-                                (CL:SETF (HQFX80DATA-CHARHEIGHTDELTA HQFX80DATA)
-                                       (FIXR (MIN (MAX (- CHARTOP TOP)
-                                                       0)
-                                                  MAX.SMALL.INTEGER]
-          (freplace PBTHEIGHT of PBT
-             with (FIXR (MAX [- TOP (MAX (- Y (CL:SETF (HQFX80DATA-CHARSET-DESCENT-CACHE HQFX80DATA)
-                                                     (ffetch CHARSETDESCENT of CSINFO)))
-                                         (fetch (REGION BOTTOM) of (HQFX80DATA-CLIPPINGREGION 
-                                                                          HQFX80DATA]
-                             0])
-)
-
-(DEFMACRO \HQFX80.INVALIDATE-CACHE (HQFX80DATA)
-
-   (* ;; 
-   "marks the stream as needing to have its cached fields recomputed.  used when font changes, etc.")
-
-   `(PROGN (CL:SETF (HQFX80DATA-CHARSET-CACHE ,HQFX80DATA)
-                  MAX.SMALLP)
-           (CL:SETF (HQFX80DATA-CHARSET-ASCENT-CACHE ,HQFX80DATA)
-                  MAX.SMALLP)))
-
-(DEFMACRO \HQFX80.INVALIDATE-FONT-CACHE (HQFX80DATA)
-   `(PROGN (CL:SETF (HQFX80DATA-CHARSET-CACHE ,HQFX80DATA)
-                  MAX.SMALLP)
-           (CL:SETF (HQFX80DATA-CHARSET-ASCENT-CACHE ,HQFX80DATA)
-                  MAX.SMALLP)))
-
-(DEFMACRO \HQFX80.GET-CACHED-CHAR-WIDTH (CHARCODE HQFX80DATA)
-
-   (* ;; "get the cached image width of CHARCODE")
-
-   `(\FGETIMAGEWIDTH (HQFX80DATA-IMAGE-WIDTHS-CACHE ,HQFX80DATA)
-           ,CHARCODE))
-
-(DEFMACRO \HQFX80.GET-CHARACTER-OFFSET (CHAR8CODE HQFX80DATA)
-   `(\GETBASE (HQFX80DATA-OFFSETS-CACHE ,HQFX80DATA)
-           ,CHAR8CODE))
-
-
-
-(* ;; "auxiliary functions")
-
-
-(CL:DEFUN \HQFX80.GRAPHICS-MODE (ROWS COMPRESSED? BACKING-STREAM)
-
-   (* ;; "put the FX-80 in some graphics mode")
-
-   (BOUT BACKING-STREAM (CHARCODE ESC))
-   (BOUT BACKING-STREAM (CHARCODE *))
-   (BOUT BACKING-STREAM                                      (* ; 
-                                                        "compressed prints at 120 dpi, regular at 72")
-         (if COMPRESSED?
-             then 1
-           else 5))
-   (BOUT BACKING-STREAM (IREMAINDER ROWS 256))
-   (BOUT BACKING-STREAM (FOLDLO ROWS 256)))
-(DEFINEQ
-
-(\HQFX80.PRINTER-MODE
-  [LAMBDA (FX80-MODE STREAM N-SPACING)                   (* ; "Edited 23-Sep-88 10:21 by jds")
-
-    (* ;; "put the FX80 printer in some mode")
-
-    (CL:FLET [(SEND-PRINTER-COMMAND (COMMAND-STRING STREAM)
-
-                     (* ;; "Send an ESC, to tell the printer there is to be a mode change, and then the specific mode change byte")
-
-                     (BOUT STREAM (CHARCODE ESC))
-                     (for CHAR instring COMMAND-STRING do (BOUT STREAM CHAR]
-           (SELECTQ FX80-MODE
-               (:BOLD-ON (SEND-PRINTER-COMMAND "E" STREAM))
-               (:BOLD-OFF (SEND-PRINTER-COMMAND "F" STREAM))
-               (:COMPRESSED-ON 
-                    (SEND-PRINTER-COMMAND (CHARACTER 15)
-                           STREAM))
-               (:COMPRESSED-OFF 
-                    (BOUT STREAM 18))
-               (:ELITE-ON (SEND-PRINTER-COMMAND "M" STREAM))
-               (:ELITE-OFF (SEND-PRINTER-COMMAND "P" STREAM))
-               (:ITALIC-ON (SEND-PRINTER-COMMAND "4" STREAM))
-               (:ITALIC-OFF (SEND-PRINTER-COMMAND "5" STREAM))
-               (:PICA-ON (SEND-PRINTER-COMMAND (CONCAT "P" (CHARACTER 18))
-                                STREAM))
-               (:SUBSCRIPT-ON (SEND-PRINTER-COMMAND "S0" STREAM))
-               (:SCRIPT-OFF (SEND-PRINTER-COMMAND "T" STREAM))
-               (:SUPERSCRIPT-ON 
-                    (SEND-PRINTER-COMMAND "S1" STREAM))
-               (:EXPAND-ON (SEND-PRINTER-COMMAND "W1" STREAM))
-               (:EXPAND-OFF (SEND-PRINTER-COMMAND "W0" STREAM))
-               (:PROPORTIONAL-ON 
-                    (SEND-PRINTER-COMMAND "p1" STREAM))
-               (:PROPORTIONAL-OFF 
-                    (SEND-PRINTER-COMMAND "p0" STREAM))
-               (:UNIDIRECTIONAL-ON 
-                    (SEND-PRINTER-COMMAND "U1" STREAM))
-               (:UNIDIRECTIONAL-OFF 
-                    (SEND-PRINTER-COMMAND "U0" STREAM))
-               (:N-SPACING-ON                                (* ; "Space n/72 of an inch on LF.")
-                              (SEND-PRINTER-COMMAND (CONCAT "A" (CHARACTER N-SPACING))
-                                     STREAM))
-               (:SEVEN-SPACING-ON 
-                    (SEND-PRINTER-COMMAND "1" STREAM))
-               (:EIGHT-SPACING-ON 
-                    (SEND-PRINTER-COMMAND (CONCAT "A" (CHARACTER 8))
-                           STREAM))
-               (:NINE-SPACING-ON                             (* ; 
-                        "Space by 9 print dots per LF.  Mostly for graphics mode used in HQ FX-80.")
-                    (SEND-PRINTER-COMMAND "0" STREAM))
-               (:TWELVE-SPACING-ON                           (* ; "Restore normal 1/6%" spacing")
-                    (SEND-PRINTER-COMMAND "2" STREAM))
-               (:NO-SKIP (SEND-PRINTER-COMMAND "O" STREAM))
-               NIL])
-)
-
-(DEFMACRO WITH-HQFX80-DATA ((VAR-NAME STREAM)
-                            &BODY
-                            (BODY DECLS ENV))
-   `(LET [(,VAR-NAME (FETCH (STREAM IMAGEDATA) OF ,STREAM]
-         ,@DECLS
-         ,@BODY))
-
-
-
-(* ;; "and miscellany")
-
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQ \HQFX80.FILE-SIGNATURE "HQFX-80/Xerox/1.0 ")
-
-(RPAQQ \HQFX80.1-TO-1-MODE-DPI 72)
-
-(RPAQQ \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI 120)
-
-
-(CONSTANTS (\HQFX80.FILE-SIGNATURE "HQFX-80/Xerox/1.0 ")
-       (\HQFX80.1-TO-1-MODE-DPI 72)
-       (\HQFX80.LOW-SPEED-DOUBLE-MODE-DPI 120))
-)
-
-(RPAQ? \HQFX80.INCHES-PER-PAGE 11)
-
-(RPAQ? \HQFX80.INCHES-PER-LINE 8.5)
-
-(RPAQ? HQFX80-DEFAULT-DESTINATION "{TTY}")
-
-(RPAQ? HQFX80-FONT-EXTENSIONS DISPLAYFONTEXTENSIONS)
-
-(RPAQ? HQFX80-FONT-DIRECTORIES DISPLAYFONTDIRECTORIES)
-
-(RPAQ? HQFX80-FONT-COERCIONS DISPLAYFONTCOERCIONS)
-
-(RPAQ? HQFX80-MISSING-FONT-COERCIONS DISPLAYFONTCOERCIONS)
-
-(RPAQQ FX80-PRINTCOMS
-       (
-        (* ;; "The FXPrinter emulator")
-
-        (COMS 
-              (* ;; "top level routine")
-
-              (FUNCTIONS FX80-PRINT))
-        (COMS 
-              (* ;; "how to print bitmaps")
-
-              (FUNCTIONS FX80-PRINT.BITMAP)
-              (FUNCTIONS FX80-PRINT.PRINT-BITMAP FX80-PRINT.PRINT-BITMAP-PORTRAIT 
-                     FX80-PRINT.PRINT-BITMAP-LANDSCAPE))
-        (COMS 
-              (* ;; "how to print files")
-
-              (FUNCTIONS FX80-PRINT.FILE))))
-
-
-
-(* ;; "The FXPrinter emulator")
-
-
-
-
-(* ;; "top level routine")
-
-
-(CL:DEFUN FX80-PRINT (THING-TO-PRINT &KEY LANDSCAPE? COMPRESS? HIGH-QUALITY?)
-   "Prints thing-to-print on the FX-80 printer"
-   (CL:ETYPECASE THING-TO-PRINT
-       ((OR WINDOW BITMAP) (FX80-PRINT.BITMAP THING-TO-PRINT LANDSCAPE? COMPRESS?))
-       ((OR CL:SYMBOL STRING PATHNAME) (FX80-PRINT.FILE THING-TO-PRINT HIGH-QUALITY?)))
-   THING-TO-PRINT)
-
-
-
-(* ;; "how to print bitmaps")
-
-
-(CL:DEFUN FX80-PRINT.BITMAP (BITMAP-OR-WINDOW LANDSCAPE? COMPRESS?)
-   "Prints a bitmap or window on the FX-80 printer"
-   (CL:ETYPECASE BITMAP-OR-WINDOW
-       (WINDOW (LET* [(WINDOW-REGION (DSPCLIPPINGREGION NIL BITMAP-OR-WINDOW))
-                      (BM (BITMAPCREATE (FETCH (REGION WIDTH) OF WINDOW-REGION)
-                                 (FETCH (REGION HEIGHT) OF WINDOW-REGION]
-                     (BITBLT BITMAP-OR-WINDOW NIL NIL BM)
-                     (FX80-PRINT.BITMAP BM LANDSCAPE? COMPRESS?)))
-       (BITMAP (FX80-PRINT.PRINT-BITMAP BITMAP-OR-WINDOW LANDSCAPE? COMPRESS?))))
-
-(CL:DEFUN FX80-PRINT.PRINT-BITMAP (BITMAP LANDSCAPE? COMPRESS?)
-   "Print a bitmap on the FX-80, either landscape or portrait"
-   (IF LANDSCAPE?
-       THEN (FX80-PRINT.PRINT-BITMAP-LANDSCAPE BITMAP COMPRESS?)
-     ELSE (FX80-PRINT.PRINT-BITMAP-PORTRAIT BITMAP COMPRESS?)))
-
-(CL:DEFUN FX80-PRINT.PRINT-BITMAP-PORTRAIT (BITMAP COMPRESS?)
-   "Prints a bitmap on the FX-80 in portrait mode"
-   [LET ((HQFX80STREAM (OPENIMAGESTREAM HQFX80-DEFAULT-DESTINATION 'HQFX80 (LIST 'COMPRESSED 
-                                                                                 COMPRESS?)))
-         (WIDTH (BITMAPWIDTH BITMAP))
-         (HEIGHT (BITMAPHEIGHT BITMAP)))
-        (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-               (LET ((PAGE-WIDTH (fetch (REGION WIDTH) of (HQFX80DATA-CLIPPINGREGION DATA)))
-                     (PAGE-HEIGHT (fetch (REGION HEIGHT) of (HQFX80DATA-CLIPPINGREGION DATA))
-                            (HQFX80DATA-CLIPPINGREGION DATA)))
-
-                    (* ;; "center it if possible")
-
-                    (BITBLT BITMAP NIL NIL HQFX80STREAM (MAX 0 (/ (- PAGE-WIDTH WIDTH)
-                                                                  2))
-                           (MAX 0 (/ (- PAGE-HEIGHT HEIGHT)
-                                     2))
-                           NIL NIL 'INPUT 'REPLACE)
-                    (CLOSEF HQFX80STREAM])
-
-(CL:DEFUN FX80-PRINT.PRINT-BITMAP-LANDSCAPE (BITMAP COMPRESS?)
-   "Prints a bitmap on the FX-80 in landscape mode"
-   [LET ((HQFX80STREAM (OPENIMAGESTREAM HQFX80-DEFAULT-DESTINATION 'HQFX80 (LIST 'COMPRESSED 
-                                                                                 COMPRESS?)))
-         (WIDTH (BITMAPHEIGHT BITMAP))
-         (HEIGHT (BITMAPWIDTH BITMAP))
-         (ROTATED-BITMAP (ROTATE-BITMAP BITMAP)))
-        (WITH-HQFX80-DATA (DATA HQFX80STREAM)
-               (LET ((PAGE-WIDTH (fetch (REGION WIDTH) of (HQFX80DATA-CLIPPINGREGION DATA)))
-                     (PAGE-HEIGHT (fetch (REGION HEIGHT) of (HQFX80DATA-CLIPPINGREGION DATA))
-                            (HQFX80DATA-CLIPPINGREGION DATA)))
-                    (BITBLT ROTATED-BITMAP NIL NIL HQFX80STREAM (MAX 0 (/ (- PAGE-WIDTH WIDTH)
-                                                                          2))
-                           (MAX 0 (/ (- PAGE-HEIGHT HEIGHT)
-                                     2))
-                           NIL NIL 'INPUT 'REPLACE)
-                    (CLOSEF HQFX80STREAM])
-
-
-
-(* ;; "how to print files")
-
-
-(CL:DEFUN FX80-PRINT.FILE (FILE-NAME HIGH-QUALITY?)
-   "Prints a file on the FX-80"
-   (SEND.FILE.TO.PRINTER (INTERLISP-NAMESTRING FILE-NAME)
-          (IF HIGH-QUALITY?
-              THEN 'HQFX80
-            ELSE 'FASTFX80)))
-
-
-
-(* ; "common routines")
-
-
-(DEFMACRO WITH-ABORT-WINDOW ((PROCESS FILE-NAME PRINTER-NAME COPY#)
-                             &BODY
-                             (FORMS DECLS))
-   "executes FORMS, allowing termination by menu selection"
-   `(LET [(WINDOW (\FX80.CREATE-SEND-ABORT-WINDOW ,PROCESS ,FILE-NAME ,PRINTER-NAME ,COPY#]
-         (CL:UNWIND-PROTECT
-             (PROGN ,@DECLS (BLOCK 3000)
-                    ,@FORMS)
-             (CLOSEW WINDOW))))
-
-(CL:DEFUN \FX80.CREATE-SEND-ABORT-WINDOW (SENDING-PROCESS FILE-OR-STREAM PRINTER-NAME COPY#)
-   (LET* [(DOCUMENT-TYPE-AND-NAME-STRING (IF (STREAMP FILE-OR-STREAM)
-                                             THEN (IF (FETCH (STREAM NAMEDP) OF FILE-OR-STREAM)
-                                                      THEN (CONCAT "the file " (FULLNAME 
-                                                                                      FILE-OR-STREAM)
-                                                                  )
-                                                    ELSE "an unnamed document")
-                                           ELSE FILE-OR-STREAM))
-          (WINDOW-WIDTH (WIDTHIFWINDOW 270))
-          (WINDOW-HEIGHT (HEIGHTIFWINDOW 120))
-          (ABORT-MENU-ITEM "Abort")
-          (ABORT-MENU-FONT (FONTCREATE 'GACHA 12 'BRR))
-          (ABORT-WINDOW (CREATEW (CREATEREGION (RAND 0 (- SCREENWIDTH WINDOW-WIDTH))
-                                        (- SCREENHEIGHT WINDOW-HEIGHT)
-                                        WINDOW-WIDTH WINDOW-HEIGHT)))
-          (ABORT-WINDOW-FONT (DSPFONT NIL ABORT-WINDOW))
-          (BOLD-ABORT-WINDOW-FONT (FONTCOPY ABORT-WINDOW-FONT 'WEIGHT 'BOLD]
-         (PRINTOUT ABORT-WINDOW "Sending copy " COPY# " of " .FONT BOLD-ABORT-WINDOW-FONT 
-                DOCUMENT-TYPE-AND-NAME-STRING .FONT ABORT-WINDOW-FONT " to " .FONT 
-                BOLD-ABORT-WINDOW-FONT PRINTER-NAME .FONT ABORT-WINDOW-FONT "." T)
-         (PRINTOUT ABORT-WINDOW "Select %"Abort%" below to stop printing " 
-                " this and all subsequent copies." T)
-         (ADDMENU (CREATE MENU
-                         ITEMS _ `[(,ABORT-MENU-ITEM (PROGN (PROCESS.EVAL ,SENDING-PROCESS
-                                                                   '(ERROR!))
-                                                            (PRINTOUT ,ABORT-WINDOW T 
-                                                                   "... printing aborted.")
-                                                            (BLOCK 2000)
-                                                            (CLOSEW ,ABORT-WINDOW))
-                                          ,(CONCAT 
-                                                  "Stops printing this and all subsequent copies of "
-                                                  DOCUMENT-TYPE-AND-NAME-STRING "."]
-                         MENUFONT _ ABORT-MENU-FONT)
-                ABORT-WINDOW
-                (CREATEPOSITION (/ (- WINDOW-WIDTH (STRINGWIDTH ABORT-MENU-ITEM ABORT-MENU-FONT))
-                                   2)
-                       20))
-         ABORT-WINDOW))
-
-(CL:DEFUN \ADD-TO-FONTPROFILE (FONTPROFILE FONTCLASS DEVICE FONT-DESCRIPTION)
-
-   (* ;; "sets the DEVICE component of the FONTCLASS entry of FONTPROFILE to be FONT-DESCRIPTION.")
-
-   (LET ((BUCKET (FASSOC FONTCLASS FONTPROFILE)))
-        (IF (NULL BUCKET)
-            THEN (ERROR "No such fontclass as " FONTCLASS)
-          ELSE 
-               (* ;; "the bucket looks like")
-
-               (* ;; "(fontclass prettyfont# displayfont pressfont interpressfont")
-
-               (* ;; "        (dev1 dev1-font) (dev2 dev2-font) ... )")
-
-               [SELECTQ DEVICE
-                   (DISPLAY (CL:SETF (CL:THIRD BUCKET)
-                                   FONT-DESCRIPTION))
-                   (PRESS (CL:SETF (CL:FOURTH BUCKET)
-                                 FONT-DESCRIPTION))
-                   (INTERPRESS (CL:SETF (CL:FIFTH BUCKET)
-                                      FONT-DESCRIPTION))
-                   (DESTRUCTURING-BIND (CLASS-NAME PRETTY-FONT# DISPLAY-FONT PRESS-FONT 
-                                              INTERPRESS-FONT . A-LIST)
-                          BUCKET
-                          (IF (NULL A-LIST)
-                              THEN (RPLACD (LAST BUCKET)
-                                          (LIST (LIST DEVICE FONT-DESCRIPTION)))
-                            ELSE (PUTASSOC DEVICE (LIST FONT-DESCRIPTION)
-                                        A-LIST]
-               BUCKET)))
-
-(CL:DEFUN \GET-FROM-FONTPROFILE (FONTPROFILE FONTCLASS DEVICE)
-
-   (* ;; "Retunrs the DEVICE component of the FONTCLASS entry of FONTPROFILE.")
-
-   [LET ((BUCKET (FASSOC FONTCLASS FONTPROFILE)))
-        (IF (NULL BUCKET)
-            THEN (ERROR "No such fontclass as " FONTCLASS)
-          ELSE 
-               (* ;; "the bucket looks like")
-
-               (* ;; "(fontclass prettyfont# displayfont pressfont interpressfont")
-
-               (* ;; "        (dev1 dev1-font) (dev2 dev2-font) ... )")
-
-               (SELECTQ DEVICE
-                   (DISPLAY (CL:THIRD BUCKET))
-                   (PRESS (CL:FOURTH BUCKET))
-                   (INTERPRESS (CL:FIFTH BUCKET))
-                   (DESTRUCTURING-BIND (CLASS-NAME PRETTY-FONT# DISPLAY-FONT PRESS-FONT 
-                                              INTERPRESS-FONT . A-LIST)
-                          BUCKET
-                          (IF (NULL A-LIST)
-                              THEN NIL
-                            ELSE (CADR (FASSOC DEVICE A-LIST])
-
-
-
-(* ;;; "initialization")
-
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(\HQFX80.INIT)
-
-(\FASTFX80.INIT)
-)
-
-(PUTPROPS FX-80DRIVER FILETYPE CL:COMPILE-FILE)
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (4439 8728 (\FASTFX80.INIT 4449 . 8726)) (8811 10748 (OPENFASTFX80STREAM 8821 . 10746)) 
-(10750 11195 (\FASTFX80.PREAMBLE 10750 . 11195)) (11197 11950 (\FASTFX80.RESET-PRINTER 11197 . 11950))
- (11952 12475 (\FASTFX80.OUTPUT-SIGNATURE 11952 . 12475)) (12476 13108 (\FASTFX80.CLOSE 12486 . 13106)
-) (13150 18112 (\FASTFX80.CHANGEFONT 13160 . 16384) (\FASTFX80.FONTCREATE 16386 . 17149) (
-\FASTFX80.CREATECHARSET 17151 . 18110)) (18114 18665 (\FASTFX80.INIT-FONT-PROFILE 18114 . 18665)) (
-18705 21838 (\FASTFX80.STRINGWIDTH 18715 . 20174) (\FASTFX80.CHARWIDTH 20176 . 20813) (
-\FASTFX80.SUBCHARWIDTH 20815 . 21836)) (21840 22336 (\FASTFX80.SPACEFACTOR 21840 . 22336)) (22419 
-35008 (\FASTFX80.CLIPPINGREGION 22429 . 23365) (\FASTFX80.MOVETO 23367 . 23636) (\FASTFX80.XPOSITION 
-23638 . 25782) (\FASTFX80.YPOSITION 25784 . 28287) (\FASTFX80.BACKUP.PAPER 28289 . 29056) (
-\FASTFX80.ADVANCE.PAPER 29058 . 29922) (\FASTFX80.NEWPAGE 29924 . 30270) (\FASTFX80.OUTCHAR 30272 . 
-32626) (\FASTFX80.NEWLINE 32628 . 33684) (\FASTFX80.LINEFEED 33686 . 34723) (\FASTFX80.DRAWLINE 34725
- . 35006)) (35010 36021 (\FASTFX80.STARTPAGE 35010 . 36021)) (36023 37129 (\FASTFX80.SMART-XPOSITION 
-36023 . 37129)) (37131 37544 (\FASTFX80.TOPMARGIN 37131 . 37544)) (37546 37968 (\FASTFX80.BOTTOMMARGIN
- 37546 . 37968)) (37970 38386 (\FASTFX80.LEFTMARGIN 37970 . 38386)) (38388 38807 (
-\FASTFX80.RIGHTMARGIN 38388 . 38807)) (38809 39023 (\FASTFX80.CUR-POS-VISIBLE? 38809 . 39023)) (39025 
-39482 (\FASTFX80.HORIZONTAL 39025 . 39482)) (39514 40336 (\FASTFX80.SEND 39514 . 40336)) (40338 40550 
-(MAKE-FASTFX80 40338 . 40550)) (40552 42254 (FASTFX80FILEP 40552 . 42254)) (42256 42452 (
-\FASTFX80.CANNOT-PRINT-BITMAPS 42256 . 42452)) (42453 42830 (\FASTFX80.CONVERT-TEDIT 42463 . 42828)) (
-42878 43180 (\FASTFX80.BOUT 42888 . 43178)) (43210 43637 (\FASTFX80.TRANSLATE-CHAR 43210 . 43637)) (
-43639 43876 (WITH-FASTFX80-DATA 43639 . 43876)) (50288 54402 (\HQFX80.INIT 50298 . 54400)) (54485 
-59838 (OPENHQFX80STREAM 54495 . 59836)) (59840 60194 (\HQFX80.PREAMBLE 59840 . 60194)) (60196 60904 (
-\HQFX80.RESET-PRINTER 60196 . 60904)) (60906 61410 (\HQFX80.OUTPUT-SIGNATURE 60906 . 61410)) (61411 
-62263 (\HQFX80.CLOSE 61421 . 62261)) (62305 80084 (\HQFX80.FONTCREATE 62315 . 63055) (
-\HQFX80.CHANGEFONT 63057 . 64497) (\HQFX80.CREATECHARSET 64499 . 73421) (\HQFX80.CHANGE-CHARSET 73423
- . 75946) (\HQFX80.READ-FONT-FILE 75948 . 77717) (\HQFX80.SEARCH-FONTS 77719 . 80082)) (80086 80631 (
-\HQFX80.INIT-FONT-PROFILE 80086 . 80631)) (80671 82631 (\HQFX80.CHARWIDTH 80681 . 81267) (
-\HQFX80.STRINGWIDTH 81269 . 82629)) (82633 83113 (\HQFX80.SPACEFACTOR 82633 . 83113)) (83196 91836 (
-\HQFX80.CLIPPINGREGION 83206 . 84428) (\HQFX80.LEFTMARGIN 84430 . 85195) (\HQFX80.RIGHTMARGIN 85197 . 
-85926) (\HQFX80.TOPMARGIN 85928 . 86492) (\HQFX80.BOTTOMMARGIN 86494 . 87070) (\HQFX80.XPOSITION 87072
- . 87541) (\HQFX80.YPOSITION 87543 . 88238) (\HQFX80.NEWLINE 88240 . 89657) (\HQFX80.NEWPAGE 89659 . 
-90088) (\HQFX80.LINEFEED 90090 . 90628) (\HQFX80.RESET 90630 . 90868) (\HQFX80.STARTPAGE 90870 . 91834
-)) (91838 92026 (\HQFX80.CUR-POS-VISIBLE? 91838 . 92026)) (92158 119893 (\HQFX80.BITBLT 92168 . 99412)
- (\HQFX80.BLTSHADE 99414 . 104165) (\HQFX80.DRAWELLIPSE 104167 . 118408) (\HQFX80.OPERATION 118410 . 
-119307) (\HQFX80.DRAWPOINT 119309 . 119891)) (119894 137294 (\HQFX80.DRAWLINE 119904 . 123122) (
-\HQFX80.CLIP-AND-DRAW-LINE 123124 . 128335) (\HQFX80.CLIP-AND-DRAW-LINE1 128337 . 137292)) (137295 
-146290 (\HQFX80.DRAWCIRCLE 137305 . 143923) (\HQFX80.CREATE-BRUSH-BBT 143925 . 146288)) (146292 146817
- (\HQFX80.DRAW-4-CIRCLE-POINTS 146292 . 146817)) (146818 156989 (\HQFX80.FILLCIRCLE 146828 . 156627) (
-\HQFX80.DRAWARC 156629 . 156987)) (156991 157556 (\HQFX80.FILL-CIRCLE-BLT 156991 . 157556)) (157588 
-186500 (\HQFX80.DRAWCURVE 157598 . 159491) (\HQFX80.DRAWCURVE2 159493 . 171129) (\HQFX80.DRAWCURVE3 
-171131 . 176773) (\HQFX80.LINEWITHBRUSH 176775 . 186498)) (186501 189958 (\HQFX80.BBTCURVEPT 186511 . 
-189956)) (191660 192811 (\HQFX80.SMOOTH-CURVE 191660 . 192811)) (192813 194697 (
-.SETUP.FOR.\HQFX80.BBTCURVEPT. 192813 . 194697)) (194742 198780 (\HQFX80.OUTCHAR 194752 . 196679) (
-\HQFX80.BLT-CHAR 196681 . 198778)) (198811 203326 (\HQFX80.DUMP-PAGE-BUFFER 198821 . 202982) (
-\HQFX80.ADVANCE-8-LINES 202984 . 203324)) (203328 204752 (\HQFX80.EIGHT-LINES-BLANK? 203328 . 204752))
- (204754 205508 (\HQFX80.BITMAP-LDB 204754 . 205508)) (205510 206000 (\HQFX80.CLEAR-SCANLINE 205510 . 
-206000)) (206002 206079 (\HQFX80.CLEAR-WORD-BOX 206002 . 206079)) (206081 206923 (\HQFX80.SEND 206081
- . 206923)) (206925 207128 (MAKE-HQFX80 206925 . 207128)) (207130 208512 (HQFX80FILEP 207130 . 208512)
-) (208546 212145 (\HQFX80.BITMAP-FILE 208556 . 211776) (\HQFX80.CONVERT-TEDIT 211778 . 212143)) (
-212193 212492 (\HQFX80.BOUT 212203 . 212490)) (212544 216169 (\HQFX80.FIX-LINE-LENGTH 212554 . 213355)
- (\HQFX80.FIX-FONT 213357 . 213673) (\HQFX80.FIX-Y 213675 . 216167)) (216171 216531 (
-\HQFX80.INVALIDATE-CACHE 216171 . 216531)) (216533 216776 (\HQFX80.INVALIDATE-FONT-CACHE 216533 . 
-216776)) (216778 216988 (\HQFX80.GET-CACHED-CHAR-WIDTH 216778 . 216988)) (216990 217132 (
-\HQFX80.GET-CHARACTER-OFFSET 216990 . 217132)) (217171 217722 (\HQFX80.GRAPHICS-MODE 217171 . 217722))
- (217723 220609 (\HQFX80.PRINTER-MODE 217733 . 220607)) (220611 220842 (WITH-HQFX80-DATA 220611 . 
-220842)) (222170 222530 (FX80-PRINT 222170 . 222530)) (222570 223191 (FX80-PRINT.BITMAP 222570 . 
-223191)) (223193 223490 (FX80-PRINT.PRINT-BITMAP 223193 . 223490)) (223492 224601 (
-FX80-PRINT.PRINT-BITMAP-PORTRAIT 223492 . 224601)) (224603 225722 (FX80-PRINT.PRINT-BITMAP-LANDSCAPE 
-224603 . 225722)) (225760 226002 (FX80-PRINT.FILE 225760 . 226002)) (226036 226472 (WITH-ABORT-WINDOW 
-226036 . 226472)) (226474 229154 (\FX80.CREATE-SEND-ABORT-WINDOW 226474 . 229154)) (229156 230619 (
-\ADD-TO-FONTPROFILE 229156 . 230619)) (230621 231679 (\GET-FROM-FONTPROFILE 230621 . 231679)))))
-STOP
diff --git a/obsolete/library/FX-80DRIVER.LCOM b/obsolete/library/FX-80DRIVER.LCOM
deleted file mode 100644
index b364e953..00000000
Binary files a/obsolete/library/FX-80DRIVER.LCOM and /dev/null differ
diff --git a/obsolete/library/FX-80Driver.tedit b/obsolete/library/FX-80Driver.tedit
deleted file mode 100644
index 6479f012..00000000
--- a/obsolete/library/FX-80Driver.tedit
+++ /dev/null
@@ -1,40 +0,0 @@
-1

Lisp Library Modules, Medley Release 1.0,  FX-80DRIVER
1

Lisp Library Modules, Medley Release 1.0,  FX-80DRIVER
FX-80DRIVER
1

FX-80DRIVER
1


FX-80DRIVER
6

FX-80Driver(FX-80DRIVER NIL FX-80Driver NIL NIL 99) prints text and graphics on Epson FX-80-compatible printers.  It implements a full device-independent graphics interface(GRAPHICS% INTERFACE NIL graphics% interface NIL NIL 99) for the FX-80, and can print source code, TEdit documents, bitmaps and windows at a variety of qualities and speeds.
The FX-80Driver contains two printer drivers(PRINTER% DRIVERS NIL printer% drivers NIL NIL 99): a fast driver, for quick printing of draft-quality text, and a high-quality driver, for slower printing of mixed-font text and graphics.  You can print early revisions of a document in fast mode, and then switch to high-quality mode for the final copy.  The matrix shown in Figure 1 illustrates the capabilities of each mode:
((SKETCH  "figure from {DSK}<FILECACHE>FX-80DRIVERS.TEDIT;1" VERSION 3 PRIRANGE  (31 . 0) SKETCHCONTEXT  ((ROUND 1 BLACK)  (GACHA 10  (MEDIUM REGULAR REGULAR))  (CENTER BASELINE)  (CURVE  18.0 8) NIL NIL  (CENTER CENTER)  (NIL NIL NIL) T NIL NIL 1 NIL))  ((0.0  116.0  (PRI 1))  (WIRE  ((96 . 184)  (328 . 184))  (ROUND 1 BLACK) NIL NIL 1 NIL NIL))  ((0.0  116.0  (PRI 2))  (WIRE  ((96 . 152)  (328 . 152))  (ROUND 1 BLACK) NIL NIL 1 NIL NIL))  ((0.0  100.0  (PRI 3))  (WIRE  ((176 . 248)  (176 . 48))  (ROUND 1 BLACK) NIL NIL 1 NIL NIL))  ((0.0  100.0  (PRI 5))  (WIRE  ((232 . 248)  (232 . 48))  (ROUND 1 BLACK) NIL NIL 1 NIL NIL))  ((0.0  116.0  (PRI 7))  (WIRE  ((96 . 120)  (328 . 120))  (ROUND 1 BLACK) NIL NIL 1 NIL NIL))  ((0.0  116.0  (PRI 8))  (WIRE  ((96 . 88)  (328 . 88))  (ROUND 1 BLACK) NIL NIL 1 NIL NIL))  ((0.0  116.0  (PRI 9))  (WIRE  ((96 . 216)  (328 . 216))  (ROUND 1 BLACK) NIL NIL 1 NIL NIL))  ((0.05  13.0  (PRI 10))  (TEXT  (200.0 .  232.0)  ("Fast") 1  (CENTER BASELINE)  (MODERN 10  (MEDIUM REGULAR REGULAR))  ((190.5  228.5 19 13)) BLACK))  ((0.05  13.0  (PRI 11))  (TEXT  (280.0 .  232.0)  ("High-quality") 1  (CENTER BASELINE)  (MODERN 10  (MEDIUM REGULAR REGULAR))  ((251.0  228.5 58 13)) BLACK))  ((0.05  13.0  (PRI 12))  (TEXT  (96.0 .  192.0)  ("TEdit") 1  (LEFT BOTTOM)  (MODERN 10  (MEDIUM REGULAR REGULAR))  ((96 192 25 13)) BLACK))  ((0.05  13.0  (PRI 13))  (TEXT  (96.0 .  160.0)  ("Sketch") 1  (LEFT BOTTOM)  (MODERN 10  (MEDIUM REGULAR REGULAR))  ((96 160 31 13)) BLACK))  ((0.05  13.0  (PRI 14))  (TEXT  (96.0 .  128.0)  ("Windows") 1  (LEFT BOTTOM)  (MODERN 10  (MEDIUM REGULAR REGULAR))  ((96 128 43 13)) BLACK))  ((0.05  13.0  (PRI 15))  (TEXT  (96.0 .  92.0)  ("Lisp source"  "code") 1  (LEFT BOTTOM)  (MODERN 10  (MEDIUM REGULAR REGULAR))  ((96 105 50 13)  (96 92 22 13)) BLACK))  ((0.05  13.0  (PRI 16))  (TEXT  (96.0 .  64.0)  ("Grapher") 1  (LEFT BOTTOM)  (MODERN 10  (MEDIUM REGULAR REGULAR))  ((96 64 39 13)) BLACK))  ((0.05  13.0  (PRI 25))  (TEXT  (202.0 .  200.0)  ("monofont"  "only") 1  (CENTER BASELINE)  (MODERN 10  (MEDIUM REGULAR REGULAR))  ((178.5  203.0 47 13)  (192.0  190.0 20 13)) BLACK))  ((0.05  13.0  (PRI 26))  (TEXT  (202.0 .  104.0)  ("monofont"  "only") 1  (CENTER BASELINE)  (MODERN 10  (MEDIUM REGULAR REGULAR))  ((178.5  107.0 47 13)  (192.0  94.0 20 13)) BLACK))  ((0.05  12.0  (PRI 27))  (TEXT  (280.0 .  168.0)  ("yes") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((269.5  165.0 21 12)) BLACK))  ((0.05  12.0  (PRI 28))  (TEXT  (280.0 .  200.0)  ("yes") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((269.5  197.0 21 12)) BLACK))  ((0.05  12.0  (PRI 29))  (TEXT  (280.0 .  136.0)  ("yes") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((269.5  133.0 21 12)) BLACK))  ((0.05  12.0  (PRI 30))  (TEXT  (280.0 .  104.0)  ("yes") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((269.5  101.0 21 12)) BLACK))  ((0.05  12.0  (PRI 31))  (TEXT  (280.0 .  72.0)  ("yes") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((269.5  69.0 21 12)) BLACK)))
(93.0 45.0 238.0 206.0)
1.0
8

Figure 1.  FX-80 printer drivers 
For historical reasons,  FX-80 in this document refers to any and all of the Epson FX-80 family (FX-80% FAMILY%  NIL FX-80% family%  NIL NIL 99)of dot-matrix graphics printers.  The module supports the FX-80, FX-85,  FX-86 and FX-286.  The Epson printers vary in speed and carriage width, but share a common command language.
Requirements
1

RS232 or TTY cable (see the wiring diagrams in the Introduction of this manual).
Serial interface card(SERIAL% INTERFACE% CARD NIL Serial% interface% card NIL NIL 99) in the printer.
DLRS23C or DLTTY.
Installation
1

FX-80 Serial Interface(FX-80% SERIAL% INTERFACE NIL FX-80% Serial% Interface NIL NIL 99)
The FX-80Driver module requires that your Epson be equipped with a suitable serial interface (such as the Hanzon Universal Card(HANZON% UNIVERSAL% CARD NIL HANZON% Universal% Card NIL NIL 99)).  
The interface should be set up with XOn/XOff flow control enabled,  9600 baud or slower, 1 stop bit, 8 bit characters, no parity.  
(See The Hanzon Universal Card booklet for instructions on the DIP switch settings.)
FX-80 DIP Switch Settings(FX-80% DIP% SWITCH% SETTINGS NIL FX-80% DIP% Switch% Settings NIL NIL 100)
The FX-80 should have its DIP switches set as shown in Figure 2. 
((SKETCH a% figure% from% a% document VERSION 3 PRIRANGE  (62 . 0) SKETCHCONTEXT  ((ROUND 1 BLACK)  (GACHA 10  (MEDIUM REGULAR REGULAR))  (CENTER BASELINE)  (CURVE  18.0 8) NIL NIL  (CENTER CENTER)  (NIL NIL NIL) T NIL NIL 1 NIL))  ((0.092  64.0  (PRI 61))  (GROUP  (200.0  141.0  128.0  92.0)  (((0.016  12.0  (PRI 29))  (BOX  (248.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 30))  (BOX  (200.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 31))  (BOX  (216.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 32))  (BOX  (232.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 33))  (BOX  (232.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 34))  (BOX  (216.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 35))  (BOX  (248.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 36))  (BOX  (200.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 38))  (BOX  (312.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 39))  (BOX  (264.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 40))  (BOX  (280.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 41))  (BOX  (296.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 42))  (BOX  (296.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 43))  (BOX  (280.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 44))  (BOX  (312.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 45))  (BOX  (264.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.05  12.0  (PRI 46))  (TEXT  (208.0 .  144.0)  ("1") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((204.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 47))  (TEXT  (224.0 .  144.0)  ("2") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((220.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 48))  (TEXT  (240.0 .  144.0)  ("3") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((236.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 49))  (TEXT  (256.0 .  144.0)  ("4") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((252.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 54))  (TEXT  (272.0 .  144.0)  ("5") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((268.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 55))  (TEXT  (288.0 .  144.0)  ("6") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((284.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 56))  (TEXT  (304.0 .  144.0)  ("7") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((300.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 57))  (TEXT  (320.0 .  144.0)  ("8") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((316.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 58))  (TEXT  (264.0 .  224.0)  ("Switch 1") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((236.0  221.0 56 12)) BLACK)))  (264 . 184)))  ((0.092  49.25  (PRI 62))  (GROUP  (61.5  141.0  98.5  92.0)  (((0.05  12.0  (PRI 11))  (TEXT  (104.0 .  144.0)  ("1") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((100.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 12))  (TEXT  (120.0 .  144.0)  ("2") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((116.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 13))  (TEXT  (136.0 .  144.0)  ("3") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((132.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 14))  (TEXT  (152.0 .  144.0)  ("4") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((148.5  141.0 7 12)) BLACK))  ((0.05  12.0  (PRI 17))  (TEXT  (72.0 .  192.0)  ("on") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((65.0  189.0 14 12)) BLACK))  ((0.05  12.0  (PRI 18))  (TEXT  (72.0 .  168.0)  ("off") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((61.5  165.0 21 12)) BLACK))  ((0.016  12.0  (PRI 23))  (BOX  (144.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 23))  (BOX  (96.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 23))  (BOX  (112.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 23))  (BOX  (128.0  184.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.016  12.0  (PRI 24))  (BOX  (144.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 24))  (BOX  (128.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 24))  (BOX  (112.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (43605 NIL NIL)))  ((0.016  12.0  (PRI 24))  (BOX  (96.0  160.0  16.0  24.0)  (ROUND 1 BLACK) NIL 1  (NIL NIL NIL)))  ((0.05  12.0  (PRI 37))  (TEXT  (128.0 .  224.0)  ("Switch 2") 1  (CENTER BASELINE)  (GACHA 10  (MEDIUM REGULAR REGULAR))  ((100.0  221.0 56 12)) BLACK)))  (112 . 184))))
(61.0 141.0 267.0 92.0)
1.0
8

Figure 2.  FX-80  DIP switch settings  
Switch 1 says no automatic linefeed, no automatic paper feed, no buzz on paper-out, and to allow no software deactivation of the printer.
Switch 2 says to use the USA character set, Pica type, allocate 2KB for user-defined characters, allow paper-out detection, and print zeros as zeros.
Note:	For the FX-85, -86 and -286 DIP switch settings, consult the corresponding Epson User's Manual.
Software
Load FX-80DRIVER.LCOM and the required .LCOM modules from the library.
Store all of the font files (file names ending with .displayfont) corresponding to the fonts you wish to use on some convenient directory or directories.
HQFX80-FONT-DIRECTORIES(HQFX80-FONT-DIRECTORIES (variable) NIL NIL NIL 100) should be a list that contains these directories; it should be the same as  DISPLAYFONTDIRECTORIES(DISPLAYFONTDIRECTORIES (variable) NIL NIL NIL 100).
Set FASTFX80-DEFAULT-DESTINATION(FASTFX80-DEFAULT-DESTINATION (variable) NIL NIL NIL 100) (determines where output to the FASTFX80 lineprinter device goes) and HQFX80-DEFAULT-DESTINATION(HQFX80-DEFAULT-DESTINATION (variable) NIL NIL NIL 100) (determines where output to the HQFX80 lineprinter device goes) to one of the following values; they need not be the same:

Destination	RS232 port	TTY port	file
1

Value	{RS232}	{TTY}	FileName
Speed	9600 max.	4800 max.	n/a
1

Load the appropriate device driver for each of these destinations: DLTTY.LCOM for the TTY port, and DLRS232C.LCOM for the RS232C port.
Run the function RS232C.INIT or TTY.INIT (as appropriate), and set the baud rate to match the setting on the printer.
User Interface
1

You can set up the FX-80 to be your default printer, send FX-80 output to a file for later printing, or programmatically open an image stream that produces output on the FX-80.  
Having the FX-80 set up as your default printer means that you can print the contents of windows by selecting the HARDCOPY menu item on the window of interest.  You can also use the HARDCOPY - TO A FILE submenu item to spool your output for later printing.  And you can write programs that use the OPENIMAGESTREAM(OPENIMAGESTREAM (function) NIL NIL NIL 101) function to create FX-80 format graphics output.
Printing in Fast Mode(PRINTING% IN% FAST% MODE NIL Printing% in% Fast% Mode NIL NIL 101)
1

You can print in fast mode by sending output to the printer FASTFX80 or by opening an image stream to a file with extension FASTFX80.  This mode is called fast because it uses the printer's built-in font, which allows a tight encoding of the document to be printed.  Fidelity to the original document is not as good as in high-quality mode.
The following restrictions apply:
ÿÿïf	ÿSpecial characters (that is, most Xerox Network Systems extended characters, such as the bullet or dagger; see CharCodeTables, VirtualKeyboards in this manual) are ignored.
ÿÿïf	ÿOnly one font is supported (though roman, italic, and bold typefaces do work).
ÿÿïf	ÿGraphics (lines, underlines, bitmaps) are ignored.
ÿÿïf	ÿMultiple column output does work.
Set FX-80 Fast Mode(ET% FX-80% FAST% MODE NIL et% FX-80% Fast% Mode NIL NIL 101)
To set your default printer to be a fast mode FX-80(FAST% MODE% FX-80 NIL fast% mode% FX-80 NIL NIL 101), make the list (FASTFX80 FASTFX80) the CAR of the list DEFAULTPRINTINGHOST.
Set FX-80 Destination(SET% FX-80% DESTINATION NIL Set% FX-80% Destination NIL NIL 101)
To set the default destination of all output to {LPT}.fastfx80,  set the variable FASTFX80-DEFAULT-DESTINATION to an appropriate file name string.  See the table above;  the file name could be that of a regular file like {DSK}SPOOLED-FAST-OUTPUT.
Set FX-80 Page Size(SET% FX-80% PAGE% SIZE NIL Set% FX-80% Page% Size NIL NIL 101)
To set the driver's page size to match the paper in the printer, set the two variables \FASTFX80.INCHES-PER-PAGE (page height in inches) and \FASTFX80.INCHES-PER-LINE (page width in inches) to appropriate values.  The defaults are 11 and 8.5, respectively.  These can be set in your Lisp INIT file.
Print a File(PRINT% A% FILE NIL Print% a% File NIL NIL 101)
Select the HARDCOPY command from the background (right-button) menu.  The system first formats the file for printing.  Then, when the FX-80Driver actually starts transmitting to the printer, a small abort window, bearing the name of the document and the name of the printer, will appear near the top of your screen.  
Abort a Print Job(ABORT% A% PRINT% JOB NIL Abort% a% Print% Job NIL NIL 101)
Clicking on the item marked ABORT in the print window will cleanly terminate the printing of the document.
Note:	After aborting a print job, you may need to turn the printer off and back on to make sure that other files will print successfully.
Printing in High-Quality Mode(PRINTING% IN% HIGH-QUALITY% MODE NIL Printing% in% High-Quality% Mode NIL NIL 102)
1

Print in high-quality mode by sending output to the printer HQFX80, or by opening an image stream on a file with type HQFX80.  High-quality mode printing supports all of Xerox Lisp's device-independent graphics operations, as well as multiple font printing and the XNS extended character set.  It prints at 72 dot-per-inch resolution.  Fidelity to the original document is better than in fast mode, though printing speed is slower.
Set HQ Mode(SET% HQ% MODE NIL Set% HQ% Mode NIL NIL 102)
To set your default printer to be a high-quality FX-80, make the list (HQFX80 HQFX80) the CAR of the list DEFAULTPRINTINGHOST.  You can use the PRINTERMENU module or your favorite structure editor to do this.
Set Destination(SET% DESTINATION NIL Set% Destination NIL NIL 102)
To set the default destination of all output to {LPT}.hqfx80, set the variable HQFX80-DEFAULT-DESTINATION to an appropriate file namestring.  This could be "{TTY}", "{RS232}", or even the name of a regular file like "{DSK}spooled-hq-output".
Set Page Size(SET% PAGE% SIZE NIL Set% Page% Size NIL NIL 102)
To set the driver's page size to match the paper in the printer, set the two variables \HQFX80.INCHES-PER-PAGE (page height in inches) and \HQFX80.INCHES-PER-LINE (page width in inches) to appropriate values.  The defaults are 11 and 8.5, respectively.  These can be set in your Lisp INIT file.
Print a File(PRINT% A% FILE NIL Print% a% File NIL NIL 102)
Select the HARDCOPY command.  The system first formats the file for printing.  Then, when the FX-80Driver actually starts transmitting to the printer, a small abort window, bearing the name of the document and the name of the printer, will appear near the top of your screen.  
Note:	After printing a document on HQFX80, you may need to turn the printer off and back on before you can print with FASTFX80 on that printer.
Abort a Print Job(ABORT% A% PRINT% JOB NIL Abort% a% Print% Job NIL NIL 102)
See above.
FX Printer Compatibility(FX% PRINTER% COMPATIBILITY NIL FX% Printer% Compatibility NIL NIL 102)
1

(FX80-PRINT(FX80-PRINT (function) NIL NIL NIL 102)  &KEY THING-TO-PRINT LANDSCAPE? COMPRESS? 
HIGH-QUALITY?) 	[Function]
THING-TO-PRINT may be one of a window, bitmap, or file path name.  If THING-TO-PRINT is a path name, the file will be treated as either a TEdit or Lisp source file, and printed in the appropriate style. 
In the window or bitmap cases, LANDSCAPE? specifies landscape printing (X-coordinates run down the left margin) when non-NIL; 
COMPRESS? specifies FX-80 compressed printing mode.
If  HIGH-QUALITY? is non-NIL and THING-TO-PRINT is a path name, output will be sent to the default high-quality FX-80 printer, otherwise to the default fast FX-80 printer.
The LANDSCAPE?, COMPRESS?, and HIGH-QUALITY? arguments all default to NIL.
Limitations
1

Landscape printing(LANDSCAPE% PRINTING NIL Landscape% printing NIL NIL 103) has not been implemented.
Examples
1

Send text output to fast FX-80:(SEND% TEXT% OUTPUT% TO% FAST% FX-80 NIL Send% text% output% to% fast% FX-80 NIL NIL 103)
(SETQ FX-80 (OPENIMAGESTREAM "{LPT}.FASTFX80"))
(CL:FORMAT FX-80 "HELLO, WORLD~%%")
(CL:CLOSE FX-80)
Print source code on fast FX-80(PRINT% SOURCE% CODE% ON% FAST% FX-80 NIL Print% source% code% on% fast% FX-80 NIL NIL 103) (assuming the FastFX80 is not your default printer, but is on the list DEFAULTPRINTINGHOST):
(LISTFILES (HOST FASTFX80) "{DSK}MYPROGRAM")
Note:	Source code is stored in pre-pretty-printed form on the file.  The pretty-printer's default linelength (width of a line in characters) is normally 102, which is too wide for the FastFX-80s 8.5-inch wide page.  To create source files which print nicely on the fast FX-80, you should set the variable FILELINELENGTH to a more appropriate value before you MAKEFILE.  70 works nicely on 8.5-inch paper with a standard font profile, though your mileage may vary.
Print source code in the the fast FX-80 mode, assuming the FastFX80 is your default printer:
(LISTFILES "{DSK}MYPROGRAM")
Print TEdit file in fast FX-80 mode(PRINT% TEDIT% FILE% IN% FAST% FX-80% MODE NIL Print% TEdit% file% in% fast% FX-80% mode NIL NIL 103), assuming the FastFX80 is your default printer:
(LISTFILES "{WAYCOOL:}<PUBLIC>GENSYM.TEDIT")
Print text and graphics in  high-quality mode:(PRINT% TEXT% AND% GRAPHICS% IN% % HIGH-QUALITY% MODE NIL Print% text% and% graphics% in% % high-quality% mode NIL NIL 103) 
(SETQ FX-80 (OPENIMAGESTREAM "{LPT}" 'HQFX80))
(MOVETO 300 300 FX-80)
(CL:FORMAT FX-80 "HELLO, WORLD~%%")
(DRAWCIRCLE 300 300 230 '(ROUND 8) NIL FX-80)
(CL:CLOSE FX-80)
Print source code in high-quality mode,(PRINT% SOURCE% CODE% IN% HIGH-QUALITY% MODE NIL Print% source% code% in% high-quality% mode NIL NIL 103) assuming the high-quality FX-80 is not your default printer, but is on the list DEFAULTPRINTINGHOST:
(LISTFILES (HOST HQFX80) "{DSK}MYPROGRAM")
Note:	See the previous note regarding FILELINELENGTH and the fast FX-80.  The same holds for high-quality FX-80 printing, and we recommend 70 as the value for FILELINELENGTH.
Print source code in high-quality mode, assuming the high-quality FX-80 is your default printer:
(LISTFILES "{DSK}MYPROGRAM")
Print  TEdit file in high-quality mode,(PRINT% % TEDIT% FILE% IN% HIGH-QUALITY% MODE NIL Print% % TEdit% file% in% high-quality% mode NIL NIL 104) assuming the high-quality FX-80 is your default printer:
(LISTFILES "{WAYGNARLY:}<PUBLIC>MAGNUMOPUS.TEDIT")
[This page intentionally left blank]



(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 99) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD RIGHT) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY HELVETICA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (270 15 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (TEXT NIL NIL (54 54 504 702) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY HELVETICA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (54 15 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))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD RIGHT) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY HELVETICA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (270 15 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))))) <``¼Ì8¤àT<``àÀ €àT,HHà5Hlàlà2llàà2H`à
-à2HHà
-à,llà,llà-llàT2Hlà
-l,HHà
--àT2HTàT2Hlàl-$$àT-àT,HHà
-2HHàÈ,HHà,HHà,HHà
-3àÈT3ààT<lløÌ8¤øT-T-øäìT2ÌÌøÈFøøPAGEHEADING	VERSOHEADFøøPAGEHEADING	RECTOHEADEøøPAGEHEADINGFOOTINGVEøøPAGEHEADINGFOOTINGR	HELVETICA
-CLASSIC
-CLASSIC
-CLASSICCLASSIC
-TITAN
-	HELVETICA	HELVETICACLASSIC
-	HELVETICAMODERN
-MODERN
-MODERNMODERNTERMINAL
-MODERN
-MODERNMODERN
- HRULE.GETFNMODERN
- 7HRULE.GETFNMODERN
-7HRULE.GETFNMODERN
-HRULE.GETFNMODERN
-
-HRULE.GETFNMODERN	(IM.INDEX.GETFNy	8IM.INDEX.GETFNv	,	2IM.INDEX.GETFNH	0SKIO.GETFN.2MODERN
-"`	0IM.INDEX.GETFNµ	


HRULE.GETFNMODERN
Q		@IM.INDEX.GETFN		

HRULE.GETFNMODERN
BIM.INDEX.GETFN	@IM.INDEX.GETFN	„		7	KIM.INDEX.GETFNB	\SKIO.GETFN.2MODERN
-(Š	–	Q					š	4IM.INDEX.GETFNCLASSIC
-M	3IM.INDEX.GETFNCLASSIC
-		9IM.INDEX.GETFNCLASSIC
-G	7IM.INDEX.GETFNCLASSIC
-|	%HRULE.GETFNMODERN
		HRULE.GETFNMODERN
C	
-	
			M	
HRULE.GETFNMODERN
³	*	,IM.INDEX.GETFNCLASSIC
-1	CIM.INDEX.GETFN
HRULE.GETFNMODERN
U	"		¯		Q		5		$	=IM.INDEX.GETFN3	5IM.INDEX.GETFN(	
		AIM.INDEX.GETFNR	o		?IM.INDEX.GETFNX		A		/		/IM.INDEX.GETFN	+	;IM.INDEX.GETFN	J	‰	SIM.INDEX.GETFN
HRULE.GETFNMODERN
¯	-IM.INDEX.GETFNZ	
	T	3IM.INDEX.GETFNO	3			*		
1IM.INDEX.GETFNX		z		/IM.INDEX.GETFN		�	;IM.INDEX.GETFN	GIM.INDEX.GETFN
HRULE.GETFNMODERN
'IM.INDEX.GETFNMODERN
-7	8	x		
-P			+		
		}		
-					
HRULE.GETFNMODERN
	9IM.INDEX.GETFN		
HRULE.GETFNMODERN
	YIM.INDEX.GETFN	0	$		[IM.INDEX.GETFNH		-1	(	a	]	
-#	eIM.INDEX.GETFN1	
--.	{IM.INDEX.GETFN	
-/		$	.	'	iIM.INDEX.GETFNQ		
-+&	k		a	
-'	kIM.INDEX.GETFN:	
-3$	QNÆzº
\ No newline at end of file
diff --git a/obsolete/library/IPFONTSAMPLE b/obsolete/library/IPFONTSAMPLE
deleted file mode 100644
index 24b19802..00000000
--- a/obsolete/library/IPFONTSAMPLE
+++ /dev/null
@@ -1,391 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "11-Jun-90 15:51:10" {DSK}<usr>local>lde>lispcore>library>FONTSAMPLE.;2 16609  
-
-      changes to%:  (VARS FONTSAMPLECOMS)
-
-      previous date%: "10-Jan-87 15:47:00" {DSK}<usr>local>lde>lispcore>library>FONTSAMPLE.;1)
-
-
-(* ; "
-Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT FONTSAMPLECOMS)
-
-(RPAQQ FONTSAMPLECOMS ((MACROS IDIVUP)
-                           (VARS FNT.PANEL FNT.FNAME FNT.INFOFONT FNT.OUTFTEXT)
-                           (FNS FNT.MAKEBOOK FNT.LESSP FNT.SORTP FNT.DISPLOOK FNT.DISPTBLE 
-                                FNT.DISPDSCR FNT.NARRDSCR FNT.DISPINIT FNT.FACEMAP FNT.SIZEMAP 
-                                FNT.MAKENAME FNT.MAKEWIND FNT.FILEMAP FNT.FINDALL FNT.FLST)))
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS IDIVUP DMACRO ((INUMEXPR IDENEXPR)
-                                 (LET (INUM IDEN)
-                                      (SETQ INUM INUMEXPR)
-                                      (SETQ IDEN IDENEXPR)
-                                      (IQUOTIENT (IPLUS INUM IDEN -1)
-                                             IDEN))))
-)
-
-(RPAQQ FNT.PANEL
-       ([PROG (SETQ FNT.WIND (FNT.MAKEWIND))
-              (SETQ FNT.FONTLIST '(GACHA 10 (MEDIUM REGULAR REGULAR)
-                                         0 INTERPRESS]
-        (PROG (CLEARW FNT.WIND)
-              (FNT.DISPTBLE FNT.WIND FNT.FONTLIST))
-        (PROG (SETQ FNT.FILENAME (FNT.MAKENAME FNT.FONTLIST))
-              (SETQ FNT.STRM (OPENIMAGESTREAM FNT.FILENAME 'INTERPRESS))
-              (TOTOPW FNT.WIND)
-              (BITBLT FNT.WIND 0 0 FNT.STRM 0 0 612 792 'INPUT 'REPLACE)
-              (CLOSEF FNT.STRM))))
-
-(RPAQQ FNT.FNAME {DSK}FONTBOOK.IP)
-
-(RPAQQ FNT.INFOFONT (TERMINAL 8 (MEDIUM REGULAR REGULAR)
-                               0))
-
-(RPAQQ FNT.OUTFTEXT "abcdefghijkl ABCDEFGHIJKL")
-(DEFINEQ
-
-(FNT.MAKEBOOK
-  [LAMBDA (OUTFROOTNAME ListOfFonts PRNTFN PERPAGE)          (* FS "30-Jun-86 11:45")
-          
-          (* * takes a file name and font specification and iteratively invokes a given 
-          print function (fnt.dispfont by default) on each font in the sorted list)
-
-    (LET (FONTLIST OUTFTYPE OUTFDSCR OUTFOPTS ITER THISPAGE OUTFNAME)
-          
-          (* * Handle input parm defaults * *)
-
-         (if (EQ PRNTFN NIL)
-             then (SETQQ PRNTFN FNT.DISPLOOK))
-         (if (EQ PERPAGE NIL)
-             then (SETQ PERPAGE (SELECTQ PRNTFN
-                                    (FNT.DISPTBLE 1)
-                                    (FNT.DISPLOOK 18)
-                                    1)))
-         (SETQQ OUTFTYPE INTERPRESS)
-         (SETQQ OUTFOPTS (REGION (2794 1905 25400 24765)))
-         (if (EQUAL ListOfFonts 'ALL)
-             then (SETQ FONTLIST (FNT.FINDALL OUTFTYPE))
-           else (SETQ FONTLIST ListOfFonts))
-          
-          (* * Iterate over files increment file names, iterate over fonts * *)
-
-         (SETQ ITER 0)
-         (for PAGENO from 1 to (IDIVUP (LENGTH FONTLIST)
-                                      PERPAGE)
-            do (SETQ OUTFNAME (FNT.FILEMAP OUTFROOTNAME PAGENO))
-               (if OUTFNAME
-                   then (SETQ OUTFDSCR (OPENIMAGESTREAM OUTFNAME OUTFTYPE OUTFOPTS)))
-               (SETQ THISPAGE (IMIN PERPAGE (IDIFFERENCE (LENGTH FONTLIST)
-                                                   ITER)))
-               [for I from 1 to THISPAGE do (SETQ ITER (ADD1 ITER))
-                                            (APPLY* PRNTFN OUTFDSCR (CAR (NTH FONTLIST ITER]
-               (CLOSEF OUTFDSCR)
-               (BLOCK])
-
-(FNT.LESSP
-  [LAMBDA (DSC1 DSC2)                                        (* FS " 5-Jul-86 23:11")
-          
-          (* * Impose alpha order on font list)
-
-    (PROG NIL
-          (if (NOT (LISTP DSC1))
-              then (RETURN (ALPHORDER DSC1 DSC2)))
-          
-          (* * Switch face & size for order * *)
-
-          [SETQ DSC1 (LIST (CAR DSC1)
-                           (CADDR DSC1)
-                           (CADR DSC1)
-                           (CADDDR DSC1)
-                           (CAR (CDDDR DSC1]
-          [SETQ DSC2 (LIST (CAR DSC2)
-                           (CADDR DSC2)
-                           (CADR DSC2)
-                           (CADDDR DSC2)
-                           (CAR (CDDDR DSC2]
-          (RETURN (FNT.SORTP DSC1 DSC2])
-
-(FNT.SORTP
-  [LAMBDA (DSC1 DSC2)                                        (* FS " 5-Jul-86 23:15")
-          
-          (* * Impose alpha order on font list)
-
-    (PROG (KEY1 KEY2)
-          (if (NOT (LISTP DSC1))
-              then (RETURN (ALPHORDER DSC1 DSC2)))
-          (SETQ KEY1 (CAR DSC1))
-          (SETQ KEY2 (CAR DSC2))
-          
-          (* * Reverse order of face * *)
-
-          [if (EQUAL KEY1 KEY2)
-              then (RETURN (FNT.SORTP (CDR DSC1)
-                                  (CDR DSC2]
-          [if (LISTP KEY1)
-              then (RETURN (NOT (FNT.SORTP KEY1 KEY2]
-          (if (NUMBERP KEY1)
-              then (RETURN (LESSP KEY1 KEY2)))
-          (RETURN (ALPHORDER KEY1 KEY2])
-
-(FNT.DISPLOOK
-  [LAMBDA (FILEDSC FONTDSC)                                  (* FS "24-Jan-86 18:19")
-          
-          (* * uses "private" global vars fnt.infofont and fnt.outftext to generate 
-          sample string)
-
-    (LET NIL (DSPFONT FNT.INFOFONT FILEDSC)
-         (TERPRI FILEDSC)
-         (TERPRI FILEDSC)
-         (TERPRI FILEDSC)
-         (TERPRI FILEDSC)
-         (FNT.NARRDSCR FILEDSC (LIST FONTDSC))
-         (DSPFONT FONTDSC FILEDSC)
-         (printout FILEDSC FNT.OUTFTEXT])
-
-(FNT.DISPTBLE
-  [LAMBDA (Stream FONTDSC)                                   (* FS "17-Mar-86 17:37")
-          
-          (* * generates a font table using prin1)
-
-    (LET* ((TitleFont (FONTCREATE FNT.INFOFONT))
-           (FontList (LIST FONTDSC))
-           (InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream)))
-           (DDev (IMAGESTREAMTYPE Stream)))
-          (for Font in FontList
-             do (DSPRIGHTMARGIN (TIMES 100.0 InchesToPrinterUnits)
-                       Stream)                               (* Let clip on right *)
-                (MOVETO (FTIMES 0.75 InchesToPrinterUnits)
-                       (FTIMES 10.0 InchesToPrinterUnits)
-                       Stream)
-                (DSPFONT TitleFont Stream)
-                (FNT.NARRDSCR Stream FontList)
-                (DSPFONT FONTDSC Stream)
-                (printout Stream FNT.OUTFTEXT)
-                (DSPFONT Font Stream)
-                (for YPosition from (TIMES 9 InchesToPrinterUnits) to (TIMES 1.5 InchesToPrinterUnits
-                                                                             )
-                   by (TIMES -0.5 InchesToPrinterUnits) bind (CharacterCode _ 0)
-                   do (for XPosition from (TIMES 0.75 InchesToPrinterUnits)
-                         to (TIMES 7.5 InchesToPrinterUnits) by (TIMES 0.45 InchesToPrinterUnits)
-                         do (MOVETO XPosition YPosition Stream)
-                            (if (NEQ CharacterCode (CHARCODE FF))
-                                then (if (EQ DDev 'DISPLAY)
-                                         then (BLTCHAR CharacterCode Stream)
-                                       else (PRIN1 (CHARACTER CharacterCode)
-                                                   Stream)))
-                            (SETQ CharacterCode (ADD1 CharacterCode)))
-                      (printout T "."))
-                (printout T " done." T])
-
-(FNT.DISPDSCR
-  [LAMBDA (OUTF FONTLIST)                                    (* FS " 2-Jul-85 13:00")
-          
-          (* * Prints a list of fontlists with facelist formatting appropriate for 8 pt.
-          terminal)
-
-    (PROG (NAME SIZE JUNK NUMB STRM TEMP OFFX UNITS T0 T1 T2 T3 T4 T5 T6 T7)
-          (if (EQ FONTLIST NIL)
-              then (RETURN NIL))
-          (SETQ TEMP (DSPSCALE NIL OUTF))
-          (SETQ UNITS (TIMES 4.25 TEMP))
-          (SETQ OFFX (TIMES 42.5 TEMP))
-          (SETQ T0 (PLUS OFFX (TIMES 0 UNITS)))
-          (SETQ T1 (PLUS OFFX (TIMES 14 UNITS)))
-          (SETQ T2 (PLUS OFFX (TIMES 20 UNITS)))
-          (SETQ T3 (PLUS OFFX (TIMES 30 UNITS)))
-          (SETQ T4 (PLUS OFFX (TIMES 40 UNITS)))
-          (SETQ T5 (PLUS OFFX (TIMES 50 UNITS)))
-          (SETQ T6 (PLUS OFFX (TIMES 55 UNITS)))
-          (SETQ T7 (PLUS OFFX (TIMES 70 UNITS)))
-          [MAPC FONTLIST '(LAMBDA (DESCR)
-                            (SETQ NAME (CAR DESCR))
-                            (SETQ SIZE (CADR DESCR))
-                            (SETQ JUNK (CADDR DESCR))
-                            (SETQ TEMP (CDDDR DESCR))
-                            (SETQ NUMB (CAR TEMP))
-                            (SETQ STRM (CADR TEMP))
-                            (DSPXPOSITION T0 OUTF)
-                            (printout OUTF NAME)
-                            (DSPXPOSITION T1 OUTF)
-                            (printout OUTF |.I3| SIZE)
-                            (DSPXPOSITION T2 OUTF)
-                            (printout OUTF "(" (CAR JUNK))
-                            (DSPXPOSITION T3 OUTF)
-                            (printout OUTF (CADR JUNK))
-                            (DSPXPOSITION T4 OUTF)
-                            (printout OUTF (CADDR JUNK)
-                                   ")")
-                            (DSPXPOSITION T5 OUTF)
-                            (printout OUTF NUMB)
-                            (DSPXPOSITION T6 OUTF)
-                            (printout OUTF STRM)
-                            (DSPXPOSITION T7 OUTF]
-          (RETURN NIL])
-
-(FNT.NARRDSCR
-  [LAMBDA (OUTF FONTLIST)                                    (* ; "Edited  9-Jan-87 18:57 by FS")
-          
-          (* * Prints a list of fontlists with narrow formatting appropriate for 8 pt.
-          terminal)
-
-    (PROG (NAME SIZE FACE NUMB STRM TEMP OFFX UNITS T0 T1 T2 T3 T4 T5 DESCR)
-          (if (EQ FONTLIST NIL)
-              then (RETURN NIL))
-          (if (TYPENAMEP FONTLIST 'FONTDESCRIPTOR)
-              then (SETQ FONTLIST (FNT.FLST FONTLIST)))
-          (SETQ TEMP (DSPSCALE NIL OUTF))
-          (SETQ UNITS (TIMES 4.25 TEMP))
-          (SETQ OFFX (TIMES 42.5 TEMP))
-          (SETQ T0 (PLUS OFFX (TIMES 0 UNITS)))
-          (SETQ T1 (PLUS OFFX (TIMES 14 UNITS)))
-          (SETQ T2 (PLUS OFFX (TIMES 20 UNITS)))
-          (SETQ T3 (PLUS OFFX (TIMES 28 UNITS)))
-          (SETQ T4 (PLUS OFFX (TIMES 33 UNITS)))
-          (SETQ T5 (PLUS OFFX (TIMES 48 UNITS)))
-          
-          (* * (MAPC FONTLIST (QUOTE (LAMBDA (DESCR)
-          (SETQ NAME (CAR DESCR)) (SETQ SIZE (CADR DESCR))
-          (SETQ FACE (FNT.FACEMAP (CADDR DESCR))) (SETQ TEMP
-          (CDDDR DESCR)) (SETQ NUMB (CAR TEMP)) (SETQ STRM
-          (CADR TEMP)) (DSPXPOSITION T0 OUTF) (printout OUTF NAME)
-          (DSPXPOSITION T1 OUTF) (printout OUTF |.I3| SIZE)
-          (DSPXPOSITION T2 OUTF) (printout OUTF FACE)
-          (DSPXPOSITION T3 OUTF) (printout OUTF NUMB)
-          (DSPXPOSITION T4 OUTF) (printout OUTF STRM)
-          (DSPXPOSITION T5 OUTF)))))
-
-          (for I in FONTLIST do (if (type? FONTDESCRIPTOR I)
-                                    then (SETQ DESCR (FNT.FLST I))
-                                  else (SETQ DESCR I))
-                                (SETQ NAME (CAR DESCR))
-                                (SETQ SIZE (CADR DESCR))
-                                (SETQ FACE (FNT.FACEMAP (CADDR DESCR)))
-                                (SETQ TEMP (CDDDR DESCR))
-                                (SETQ NUMB (CAR TEMP))
-                                (SETQ STRM (CADR TEMP))
-                                (DSPXPOSITION T0 OUTF)
-                                (printout OUTF NAME)
-                                (DSPXPOSITION T1 OUTF)
-                                (printout OUTF |.I3| SIZE)
-                                (DSPXPOSITION T2 OUTF)
-                                (printout OUTF FACE)
-                                (DSPXPOSITION T3 OUTF)
-                                (printout OUTF NUMB)
-                                (DSPXPOSITION T4 OUTF)
-                                (printout OUTF STRM)
-                                (DSPXPOSITION T5 OUTF))
-          (RETURN NIL])
-
-(FNT.DISPINIT
-  [LAMBDA (FILEDSC)                                          (* FS " 2-Jul-85 14:14")
-          
-          (* * initialization or optimization for fnt.dispfont)
-
-    (PROG (vars...)
-          (SETQ FNT.OUTFTEXT "abcdefghijkl ABCDEFGHIJKL")
-          (SETQQ FNT.INFOFONT (TERMINAL 8 (MEDIUM REGULAR REGULAR)
-                                     0 INTERPRESS))
-          (RETURN NIL])
-
-(FNT.FACEMAP
-  [LAMBDA (OLDFACE)                                          (* FS " 5-Sep-85 19:04")
-          
-          (* * make short face from facelist)
-
-    (SETQ OLDFACE (\FONTFACE OLDFACE))                       (* make list form *)
-    (CONCAT (GNC (MKSTRING (CAR OLDFACE)))
-           (GNC (MKSTRING (CADR OLDFACE)))
-           (GNC (MKSTRING (CADDR OLDFACE])
-
-(FNT.SIZEMAP
-  [LAMBDA (SIZE)                                             (* FS " 2-Jul-85 14:13")
-          
-          (* * make size into two character string)
-
-    (PROG (STR)
-          (if (ILESSP SIZE 10)
-              then (RETURN (CONCAT "0" (MKSTRING SIZE)))
-            else (RETURN (MKSTRING SIZE])
-
-(FNT.MAKENAME
-  [LAMBDA (FONTLIST)                                         (* FS " 3-Sep-85 16:07")
-          
-          (* * make a unique interpress file name given a fontlist)
-
-    (PROG (STR TYPE SIZE FACE DDEV)
-          (SETQ TYPE (MKSTRING (CAR FONTLIST)))
-          (SETQ SIZE (FNT.SIZEMAP (CADR FONTLIST)))
-          [SETQ FACE (MKSTRING (FNT.FACEMAP (CADDR FONTLIST]
-          (SETQ DDEV (CAR (CDDDDR FONTLIST)))
-          (SETQ STR (CONCAT (MKSTRING TYPE)
-                           (MKSTRING SIZE)
-                           (MKSTRING FACE)
-                           (GNC (MKSTRING DDEV))
-                           ".IP"))
-          (RETURN STR])
-
-(FNT.MAKEWIND
-  [LAMBDA NIL                                                (* FS "21-Mar-86 18:07")
-          
-          (* * MAKE A WINDOW)
-
-    (PROG (PPI)
-          (SETQ PPI (TIMES 72 (DSPSCALE NIL T)))
-          [SETQ FNT.WINDOW (CREATEW (create REGION
-                                           LEFT _ 0
-                                           BOTTOM _ 0
-                                           WIDTH _ (FIX (TIMES 8.5 PPI))
-                                           HEIGHT _ (TIMES 11 PPI]
-          (RETURN FNT.WINDOW])
-
-(FNT.FILEMAP
-  [LAMBDA (OUTFNAME NUMBER)                                  (* FS " 5-Sep-85 16:56")
-          
-          (* * Takes a file name and returns an Interpress file name with number at end * 
-          *)
-
-    (PROG (FNAME ROOTNAME DESTNAME)
-          (if (OR (EQ OUTFNAME T)
-                  (EQ OUTFNAME NIL))
-              then (RETURN OUTFNAME))
-          (SETQ FNAME OUTFNAME)
-          (SETQ ROOTNAME (FILENAMEFIELD FNAME 'NAME))
-          (SETQ ROOTNAME (MKATOM (CONCAT ROOTNAME NUMBER)))
-          (SETQ DESTNAME (PACKFILENAME 'NAME ROOTNAME 'BODY FNAME))
-          (RETURN DESTNAME])
-
-(FNT.FINDALL
-  [LAMBDA (DEVICE)                                           (* FS " 5-Sep-85 19:18")
-          
-          (* * Returns list of all fonts for device * *)
-
-    (LET (RESULT)
-         (SETQ RESULT (FONTSAVAILABLE '* '* '
-          
-          (* * *)
- '* DEVICE T))
-         (SETQ RESULT (SORT RESULT 'FNT.LESSP])
-
-(FNT.FLST
-  [LAMBDA (FONTOBJ)                                          (* ; "Edited  9-Jan-87 18:56 by FS")
-    (COND
-       [(TYPENAMEP FONTOBJ 'FONTDESCRIPTOR)
-        (LIST (FONTPROP FONTOBJ 'FAMILY)
-              (FONTPROP FONTOBJ 'SIZE)
-              (FONTPROP FONTOBJ 'FACE)
-              (FONTPROP FONTOBJ 'ROTATION)
-              (FONTPROP FONTOBJ 'DEVICE]
-       ((LISTP FONTOBJ)
-        FONTOBJ])
-)
-(PUTPROPS FONTSAMPLE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1964 16504 (FNT.MAKEBOOK 1974 . 3779) (FNT.LESSP 3781 . 4575) (FNT.SORTP 4577 . 5343) (
-FNT.DISPLOOK 5345 . 5862) (FNT.DISPTBLE 5864 . 7867) (FNT.DISPDSCR 7869 . 9976) (FNT.NARRDSCR 9978 . 
-12722) (FNT.DISPINIT 12724 . 13136) (FNT.FACEMAP 13138 . 13525) (FNT.SIZEMAP 13527 . 13863) (
-FNT.MAKENAME 13865 . 14549) (FNT.MAKEWIND 14551 . 15105) (FNT.FILEMAP 15107 . 15737) (FNT.FINDALL 
-15739 . 16082) (FNT.FLST 16084 . 16502)))))
-STOP
diff --git a/obsolete/library/IPFONTSAMPLE.LCOM b/obsolete/library/IPFONTSAMPLE.LCOM
deleted file mode 100644
index 2301a55a..00000000
Binary files a/obsolete/library/IPFONTSAMPLE.LCOM and /dev/null differ
diff --git a/obsolete/library/IPFONTSAMPLE.TEDIT b/obsolete/library/IPFONTSAMPLE.TEDIT
deleted file mode 100644
index 12d3aa87..00000000
Binary files a/obsolete/library/IPFONTSAMPLE.TEDIT and /dev/null differ
diff --git a/obsolete/library/PRESS b/obsolete/library/PRESS
deleted file mode 100644
index 1dc8916c..00000000
--- a/obsolete/library/PRESS
+++ /dev/null
@@ -1,2786 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
-(FILECREATED "14-Jul-2025 22:58:49" {WMEDLEY}<library>PRESS.;4 453237Q
-
-      :EDIT-BY rmk
-
-      :CHANGES-TO (FNS \DSPFONT.PRESS)
-
-      :PREVIOUS-DATE " 5-Jul-2025 18:52:40" {WMEDLEY}<library>PRESS.;3)
-
-
-(PRETTYCOMPRINT PRESSCOMS)
-
-(RPAQQ PRESSCOMS
-       [
-
-(* ;;; "PRESS printing support module")
-
-        (COMS 
-              (* ;; "Font creation functions")
-
-              (FNS \SEARCHPRESSFONTS \GETPRESSFONTNAMES \PRESSFAMILYCODELST \DECODEPRESSFACEBYTE 
-                   \CREATEPRESSFONT \CREATECHARSET.PRESS)
-              (INITVARS (PRESSFONTWIDTHSFILES '{ERIS}<LISP>FONTS>FONTS.WIDTHS))
-              (ALISTS (SYSTEMINITVARS PRESSFONTWIDTHSFILES))
-              (DECLARE%: DONTCOPY (CONSTANTS noInfoCode)))
-        
-        (* ;; "Bitmap printing support")
-
-        (FNS PRESSBITMAP FULLPRESSBITMAP SHOWREGION SHOWPRESSBITMAPREGION PRESSWINDOW 
-             \WRITEPRESSBITMAP)
-        
-        (* ;; "Basic PRESS data structure output functions")
-
-        (FNS \BCPLSOUT.PRESS \PAGEPAD.PRESS \ENTITYEND.PRESS \PARTEND.PRESS \ENTITYSTART.PRESS 
-             SETX.PRESS SETXY.PRESS SETY.PRESS SHOW.PRESS)
-        
-        (* ;; "Image stream support functions:")
-
-        (FNS OPENPRSTREAM \BITBLT.PRESS \BLTSHADE.PRESS \SCALEDBITBLT.PRESS \BITMAPSIZE.PRESS 
-             \CHARWIDTH.PRESS \CLOSEF.PRESS \DRAWLINE.PRESS \ENDPAGE.PRESS NEWLINE.PRESS 
-             NEWPAGE.PRESS SETUPFONTS.PRESS \DEFINEFONT.PRESS \DSPBOTTOMMARGIN.PRESS 
-             \DSPCLIPPINGREGION.PRESS \DSPFONT.PRESS \DSPLEFTMARGIN.PRESS \DSPLINEFEED.PRESS 
-             \DSPRIGHTMARGIN.PRESS \DSPSPACEFACTOR.PRESS \DSPTOPMARGIN.PRESS \DSPXPOSITION.PRESS 
-             \DSPYPOSITION.PRESS \FIXLINELENGTH.PRESS \OUTCHARFN.PRESS \SETSPACE.PRESS 
-             \STARTPAGE.PRESS \STRINGWIDTH.PRESS SHOWRECTANGLE.PRESS \PRESS.CONVERT.NSCHARACTER)
-        [COMS                                                (* ; "Drawcurve code")
-              (FNS \ENDVECRUN \VECENCODE \VECPUT \VECSKIP \VECFONTINIT \DRAWCIRCLE.PRESS 
-                   \DRAWARC.PRESS \DRAWCURVE.PRESS \DRAWCURVE.PRESS.LINE \DRAWELLIPSE.PRESS 
-                   \GETBRUSHFONT.PRESS \PRESSCURVE2)
-              (INITVARS (\VecFontDir))
-              (CONSTANTS (\MicasPerInch 2540))
-              (DECLARE%: DONTCOPY (CONSTANTS (ScansPerIn 384)
-                                         (PointsPerIn 72.27)
-                                         (MicasPerScan (FQUOTIENT \MicasPerInch ScansPerIn))
-                                         (ScansPerMica (FQUOTIENT ScansPerIn \MicasPerInch))
-                                         (ScansPerPoint (FQUOTIENT ScansPerIn PointsPerIn))
-                                         (PointsPerScan (FQUOTIENT PointsPerIn ScansPerIn))
-                                         (MicasPerPoint (FQUOTIENT \MicasPerInch PointsPerIn))
-                                         (PointsPerMica (FQUOTIENT PointsPerIn \MicasPerInch))
-                                         (SPRUCEPAPERTOPSCANS 4096)
-                                         (SPRUCEPAPERTOPMICAS (FIX (FQUOTIENT (FTIMES 
-                                                                                  SPRUCEPAPERTOPSCANS
-                                                                                     \MicasPerInch)
-                                                                          ScansPerIn)))
-                                         (SPRUCEPAPERRIGHTMICAS (FIX (FTIMES 8.5 \MicasPerInch)))
-                                         (SPRUCEPAPERRIGHTSCANS (FIX (FTIMES 8.5 ScansPerIn)))
-                                         (SPRUCEPAPERBOTTOMSCANS 0)
-                                         (SPRUCEPAPERBOTTOMMICAS 0)
-                                         (SPRUCEPAPERLEFTSCANS 0)
-                                         (SPRUCEPAPERLEFTMICAS 0]
-        
-        (* ;; "Initialization code")
-
-        (FNS \PRESSINIT)
-        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\PRESSINIT)))
-        (DECLARE%: DONTCOPY (RECORDS PRESSDATA FONTDIRENTRY))
-        (INITRECORDS PRESSDATA)
-        [INITVARS (DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 24765))
-               (PRESSBITMAPREGION (CREATEREGION 1270 1270 (FIX (TIMES 7.5 \MicasPerInch))
-                                         (TIMES 10 \MicasPerInch]
-        (GLOBALVARS DEFAULTPAGEREGION)
-        (DECLARE%: DONTCOPY (CONSTANTS (BYTESPERRECORD 512)
-                                   (LISPENTITYTYPE 6)
-                                   (MICASPERINCH \MicasPerInch))
-               (E (RESETSAVE (RADIX 8)))
-               (CONSTANTS * PRESSOPS))
-        
-        (* ;; "Hardcopy user interface connections:")
-
-        (COMS (FNS MAKEPRESS PRESSFILEP PRESS.BITMAPSCALE)
-              (ALISTS (IMAGESTREAMTYPES PRESS))
-              (ADDVARS [PRINTERTYPES ((PRESS SPRUCE PENGUIN DOVER)
-                                      (CANPRINT (PRESS))
-                                      (STATUS PUP.PRINTER.STATUS)
-                                      (PROPERTIES PUP.PRINTER.PROPERTIES)
-                                      (SEND EFTP)
-                                      (BITMAPSCALE NIL)
-                                      (BITMAPFILE (PRESSBITMAP FILE BITMAP SCALEFACTOR REGION 
-                                                         ROTATION TITLE)))
-                              ((FULLPRESS RAVEN)
-                                                             (* ; 
-                                                             "same as PRESS but can scale bitmaps")
-                               (CANPRINT (PRESS))
-                               (STATUS TRUE)
-                               (PROPERTIES NILL)
-                               (SEND EFTP)
-                               (BITMAPSCALE PRESS.BITMAPSCALE)
-                               (BITMAPFILE (FULLPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION 
-                                                  TITLE]
-                     (PRINTFILETYPES (PRESS (TEST PRESSFILEP)
-                                            (EXTENSION (PRESS))
-                                            (CONVERSION (TEXT MAKEPRESS TEDIT
-                                                              (LAMBDA (FILE PFILE FONTS HEADING)
-                                                                     (SETQ FILE (OPENTEXTSTREAM
-                                                                                 FILE))
-                                                                     (TEDIT.FORMAT.HARDCOPY
-                                                                      FILE PFILE T NIL NIL NIL
-                                                                      'PRESS)
-                                                                     (CLOSEF? FILE)
-                                                                     PFILE])
-
-
-
-(* ;;; "PRESS printing support module")
-
-
-
-
-(* ;; "Font creation functions")
-
-(DEFINEQ
-
-(\SEARCHPRESSFONTS
-  [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE)                (* rrb "26-Sep-84 16:35")
-          
-          (* * returns a list of the form (family size face rotation PRESS) for any font 
-          matching the specs. * is used as wildcard.)
-
-    (DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES))
-    (RESETLST (bind FONTSFOUND WSTRM for F inside PRESSFONTWIDTHSFILES when (INFILEP F)
-                 do [COND
-                       ((SETQ WSTRM (\GETSTREAM F 'INPUT T))
-                        (RESETSAVE NIL (LIST 'SETFILEPTR WSTRM (GETFILEPTR WSTRM)))
-                        (SETFILEPTR WSTRM 0))
-                       (T (RESETSAVE (SETQ WSTRM (OPENSTREAM F 'INPUT 'OLD 8))
-                                 '(PROGN (CLOSEF? OLDVALUE]
-                    (SETQ FONTSFOUND (UNION (\GETPRESSFONTNAMES WSTRM FAMILY PSIZE FACE ROTATION)
-                                            FONTSFOUND)) finally (RETURN FONTSFOUND])
-
-(\GETPRESSFONTNAMES
-  [LAMBDA (WSTRM FAMILY PSIZE FACE ROTATION)                 (* rmk%: "17-Dec-84 13:55")
-          
-          (* finds the fonts that exist that match the args.
-          * is used as wildcard.)
-
-    (bind FONTSFOUND TYPE XFACE XFAMILY XSIZE XFACE XROTATION
-          [XFACECODE _ (COND
-                          ((AND (LISTP FACE)
-                                (NOT (MEMB '* FACE)))
-          
-          (* if complete face is specified, compute code so don't have to on each font.)
-
-                           (\FACECODE FACE]
-          (FAMILYCODELST _ (\PRESSFAMILYCODELST WSTRM))
-          (NEXT _ 0)
-          (MICASIZE _ (AND (NEQ PSIZE '*)
-                           (IQUOTIENT (ITIMES PSIZE 2540)
-                                  72)))
-       do (SETFILEPTR WSTRM NEXT)
-          (SETQ TYPE (\BIN WSTRM))
-          (add NEXT (LLSH (IPLUS (\BIN WSTRM)
-                                 (LLSH (LOGAND TYPE 15)
-                                       8))
-                          1))
-          (SELECTQ (LRSH TYPE 4)
-              (4 (SETQ XFAMILY (OR (CDR (FASSOC (\BIN WSTRM)
-                                               FAMILYCODELST))
-                                   (ERROR "unknown code number in widths file")))
-                 [COND
-                    ((OR (EQ FAMILY '*)
-                         (EQ FAMILY XFAMILY))
-                     (COND
-                        ([AND (ILESSP (SETQ XFACE (\BIN WSTRM))
-                                     18)
-                              (COND
-                                 (XFACECODE (AND (EQ XFACECODE XFACE)
-                                                 (SETQ XFACE FACE)))
-                                 ((PROGN (SETQ XFACE (\DECODEPRESSFACEBYTE XFACE))
-                                         (OR (EQ FACE '*)
-                                             (EQUAL FACE XFACE)
-                                             (for SPEC in FACE as XFIELD in XFACE
-                                                always (OR (EQ SPEC XFIELD)
-                                                           (EQ SPEC '*]
-          
-          (* greater than 18 means either ASCII or other type of font, ignore it.)
-                                                             (* skip beg and end chars)
-                         (\BIN WSTRM)
-                         (\BIN WSTRM)
-                         (SETQ XSIZE (\WIN WSTRM))
-                         (COND
-                            ((OR (EQ PSIZE '*)
-                                 (EQ MICASIZE XSIZE)
-                                 (AND (EQ XSIZE 0)
-                                      (SETQ XSIZE MICASIZE)))
-          
-          (* if XSIZE is 0, the font widths are relative and are to be used for all font 
-          sizes. In this case, if the user asked about a particular size, claim that it 
-          is there.)
-
-                             (SETQ XROTATION (\WIN WSTRM))
-                             (COND
-                                ((OR (EQ ROTATION '*)
-                                     (EQ XROTATION ROTATION))
-                                 (push FONTSFOUND (LIST XFAMILY (FIXR (FQUOTIENT (ITIMES XSIZE 72)
-                                                                             2540))
-                                                        XFACE XROTATION 'PRESS])
-              (0 (RETURN FONTSFOUND))
-              NIL])
-
-(\PRESSFAMILYCODELST
-  [LAMBDA (WSTRM)                                            (* rrb "26-Sep-84 09:55")
-          
-          (* returns an ALIST of code -
-          family pairs from the press font widths file WSTRM.)
-          
-          (* leaving the file positioned at the beginning of the next file entry.)
-
-    (bind PAIRS TYPE (NEXT _ 0)
-       do (SETFILEPTR WSTRM NEXT)
-          (SETQ TYPE (\BIN WSTRM))
-          (add NEXT (LLSH (IPLUS (\BIN WSTRM)
-                                 (LLSH (LOGAND TYPE 15)
-                                       8))
-                          1))
-          (SELECTQ (LRSH TYPE 4)
-              (1 (SETQ PAIRS (CONS [CONS (\WIN WSTRM)
-                                         (PACKC (for I from 1 to (\BIN WSTRM)
-                                                   collect (\BIN WSTRM]
-                                   PAIRS)))
-              (0 (RETURN PAIRS))
-              NIL])
-
-(\DECODEPRESSFACEBYTE
-  [LAMBDA (FACECODE)                                         (* rrb "26-Sep-84 14:28")
-          
-          (* * returns a list of (weight slope expansion) from a press widths file byte 
-          code.)
-
-    (COND
-       [(ILESSP FACECODE 18)
-        (PROG (EXP SLOPE WEIGHT)
-              [SETQ EXP (COND
-                           ((IGEQ FACECODE 12)
-                            (SETQ FACECODE (IDIFFERENCE FACECODE 12))
-                            'EXPANDED)
-                           ((IGEQ FACECODE 6)
-                            (SETQ FACECODE (IDIFFERENCE FACECODE 6))
-                            'COMPRESSED)
-                           (T 'REGULAR]
-              [SETQ WEIGHT (COND
-                              ((IGEQ FACECODE 4)
-                               (SETQ FACECODE (IDIFFERENCE FACECODE 4))
-                               'LIGHT)
-                              ((IGEQ FACECODE 2)
-                               (SETQ FACECODE (IDIFFERENCE FACECODE 2))
-                               'BOLD)
-                              (T 'MEDIUM]
-              [SETQ SLOPE (COND
-                             ((EQ FACECODE 1)
-                              'ITALIC)
-                             (T 'REGULAR]
-              (RETURN (LIST WEIGHT SLOPE EXP]
-       (T                                                    (* non xerox font)
-          NIL])
-
-(\CREATEPRESSFONT
-  [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE)                (* jds "10-Mar-86 16:35")
-          
-          (* Widths array is fully allocated, with zeroes for characters with no 
-          information. An array is not allocated for fixed WidthsY.
-          DEVICE is PRESS or INTERPRESS)
-
-    (DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES))
-    (RESETLST                                                (* RESETLST to make sure the fontfiles 
-                                                             get closed)
-           (PROG ((FD (create FONTDESCRIPTOR
-                             FONTDEVICE _ DEVICE
-                             FONTFAMILY _ FAMILY
-                             FONTSIZE _ PSIZE
-                             FONTFACE _ FACE
-                             \SFFACECODE _ (\FACECODE FACE)
-                             ROTATION _ ROTATION
-                             FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72))
-                             \SFHeight _ 0
-                             \SFAscent _ 0
-                             \SFDescent _ 0)))
-                 (\GETCHARSETINFO 0 FD T)
-                 (RETURN FD])
-
-(\CREATECHARSET.PRESS
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
-                                                             (* ; "Edited 29-Jul-87 14:15 by jds")
-
-(* ;;; "just a dummy definition.  Press should not ever be trying to change character sets, since the fonts only contain charset 0 (roughly)")
-
-    (DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES))
-    (COND
-       ((NEQ 0 CHARSET)
-        (ERROR "Press does not support NS characters.")))
-    (RESETLST                                                (* ; 
-                                                     "RESETLST to make sure the fontfiles get closed")
-
-           (PROG* (WSTRM STRMCACHE XLATEDFAM FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY WIDTHS
-                         (PRESSMICASIZE (IQUOTIENT (ITIMES SIZE 2540)
-                                               72))
-                         (NSMICASIZE (FIXR (FQUOTIENT (ITIMES SIZE 2540)
-                                                  72)))
-                         (FACECODE (\FACECODE FACE))
-                         [FD (create FONTDESCRIPTOR
-                                    FONTDEVICE _ DEVICE
-                                    FONTFAMILY _ FAMILY
-                                    FONTSIZE _ SIZE
-                                    FONTFACE _ FACE
-                                    \SFFACECODE _ FACECODE
-                                    ROTATION _ ROTATION
-                                    FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72]
-                         (CSINFO (create CHARSETINFO)))
-
-(* ;;; "Go look for the fonts.widths file that has this font's info in it.")
-
-                  (OR [for F inside PRESSFONTWIDTHSFILES when (INFILEP F)
-                         do                                  (* ; 
-      "Look thru the candidate PRESSFONTWIDTHSFILES for a file that has a description for this font.")
-
-                            [COND
-                               [(SETQ WSTRM (\GETSTREAM F 'INPUT T))
-                                (COND
-                                   ((RANDACCESSP WSTRM)
-                                    (RESETSAVE NIL (LIST 'SETFILEPTR WSTRM (GETFILEPTR WSTRM)))
-                                    (SETFILEPTR WSTRM 0]
-                               (T (RESETSAVE (SETQ WSTRM (OPENSTREAM F 'INPUT 'OLD 8))
-                                         '(PROGN (CLOSEF? OLDVALUE]
-                            [OR (RANDACCESSP WSTRM)
-                                (COPYBYTES WSTRM (SETQ WSTRM (OPENSTREAM '{NODIRCORE} 'BOTH
-                                                                    'NEW]
-                            (push STRMCACHE WSTRM)           (* ; "Save for coercions below")
-
-                            (COND
-                               ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM NSMICASIZE FIRSTCHAR LASTCHAR 
-                                                     FAMILY FACECODE))
-                                                             (* ; 
-                                                     "OK, we found this font described in this file.")
-
-                                (RETURN T]
-                      [AND (SETQ XLATEDFAM (SELECTQ FAMILY
-                                               (MODERN 'HELVETICA)
-                                               (CLASSIC 'TIMESROMAN)
-                                               (LOGOTYPE 'LOGO)
-                                               (TERMINAL 'GACHA)
-                                               NIL))
-                           (for old WSTRM in (SETQ STRMCACHE (DREVERSE STRMCACHE))
-                              first (replace FONTFAMILY of FD with XLATEDFAM)
-                              do                             (* ; "Now try coercing the family name")
-          
-          (* ;; "We know the file was left open and is randaccessp from the previous loop, which must have run off the end of the file list")
-
-                                 (SETFILEPTR WSTRM 0)
-                                 (COND
-                                    ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM NSMICASIZE FIRSTCHAR 
-                                                          LASTCHAR XLATEDFAM FACECODE))
-                                     (replace FONTDEVICESPEC of FD
-                                        with (LIST XLATEDFAM SIZE FACE ROTATION DEVICE))
-                                     (replace FONTFAMILY of FD with FAMILY)
-                                     (RETURN T]
-                      [AND (SETQ XLATEDFAM (SELECTQ FAMILY
-                                               (MODERN 'FRUTIGER)
-                                               (CLASSIC 'CENTURY)
-                                               NIL))
-                           (for old WSTRM in STRMCACHE first (replace FONTFAMILY of FD with XLATEDFAM
-                                                                    )
-                              do (SETFILEPTR WSTRM 0)
-                                 (COND
-                                    ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM NSMICASIZE FIRSTCHAR 
-                                                          LASTCHAR XLATEDFAM FACECODE))
-                                     (replace FONTDEVICESPEC of FD
-                                        with (LIST XLATEDFAM SIZE FACE ROTATION DEVICE))
-                                     (replace FONTFAMILY of FD with FAMILY)
-                                     (RETURN T]
-                      (RETURN NIL))
-
-(* ;;; "Having found the font-widths file, now read the width info from it.")
-
-                  (SETQ RELFLAG (ZEROP RELFLAG))             (* ; 
- "Actually, \POSITIONFONTFILE returns zero if the font metrics are size-relative and must be scaled.")
-
-                  (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
-                  (SETFILEPTR WSTRM (UNFOLD (\FIXPIN WSTRM)
-                                           BYTESPERWORD))
-          
-          (* ;; "Read the location of the WD segment for this font (we're in the directory part of the file now), and go there.")
-
-                  (SETQ FBBOX (SIGNED (\WIN WSTRM)
-                                     BITSPERWORD))           (* ; 
-                        "replace (FONTDESCRIPTOR FBBOX) of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)")
-                                                             (* ; 
-                                                            "Get the max bounding width for the font")
-
-                  (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (IMINUS (SIGNED (\WIN WSTRM)
-                                                                                      BITSPERWORD)))
-                                                             (* ; "Descent is -FBBOY")
-
-                  (SETQ FOO (\WIN WSTRM))                    (* ; 
-                        "replace (FONTDESCRIPTOR FBBDX) of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)")
-                                                             (* ; "And the standard kern value (?)")
-
-                  (SETQ CHARSETHEIGHT (SIGNED (\WIN WSTRM)
-                                             BITSPERWORD))   (* ; 
-                                     "replace \SFHeight of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)")
-                                                             (* ; "Height is FBBDY")
-
-                  [COND
-                     (RELFLAG                                (* ; 
-                                                            "Dimensions are relative, must be scaled")
-          
-          (* ;; "replace (FONTDESCRIPTOR FBBOX) of FD with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBOX) of FD) NSMICASIZE) 1000)")
-
-                            (replace (CHARSETINFO CHARSETDESCENT) of CSINFO
-                               with (IQUOTIENT (ITIMES (fetch (CHARSETINFO CHARSETDESCENT)
-                                                          of CSINFO)
-                                                      NSMICASIZE)
-                                           1000))
-          
-          (* ;; "replace (FONTDESCRIPTOR FBBDX) of FD with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBDX) of FD) NSMICASIZE) 1000)")
-
-                            (SETQ CHARSETHEIGHT (IQUOTIENT (ITIMES CHARSETHEIGHT NSMICASIZE)
-                                                       1000]
-                  (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (IDIFFERENCE CHARSETHEIGHT
-                                                                             (fetch CHARSETDESCENT
-                                                                                of CSINFO)))
-                  (SETQ FIXEDFLAGS (LRSH (\BIN WSTRM)
-                                         6))                 (* ; "The fixed flags")
-
-                  (\BIN WSTRM)                               (* ; "Skip the spares")
-
-                  [COND
-                     ((EQ 2 (LOGAND FIXEDFLAGS 2))           (* ; "This font is fixed width.")
-
-                      (SETQ TEM (\WIN WSTRM))                (* ; 
-                                                             "Read the fixed width for this font")
-
-                      [COND
-                         ((AND RELFLAG (NOT (ZEROP TEM)))    (* ; "If it's size relative, scale it.")
-
-                          (SETQ TEM (IQUOTIENT (ITIMES TEM NSMICASIZE)
-                                           1000]
-                      (for I from FIRSTCHAR to LASTCHAR do   (* ; 
-                                                      "Fill in the char widths table with the width.")
-
-                                                           (\FSETWIDTH WIDTHS I TEM)))
-                     (T                                      (* ; 
-                                                    "Variable width font, so we have to read widths.")
-                                                             (* ; 
-                                 "AIN WIDTHS FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) WSTRM")
-
-                        (for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHS I noInfoCode))
-                        (\BINS (\GETOFD WSTRM 'INPUT)
-                               WIDTHS
-                               (UNFOLD FIRSTCHAR BYTESPERWORD)
-                               (UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
-                                      BYTESPERWORD))         (* ; "Read the X widths.")
-
-                        (for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (\FGETWIDTH WIDTHS I))
-                           do                                (* ; 
-                                              "For chars that have no width info, let width be zero.")
-
-                              (\FSETWIDTH WIDTHS I 0))
-                        (COND
-                           (RELFLAG                          (* ; 
-                                                       "If the widths are size-relative, scale them.")
-
-                                  (for I from FIRSTCHAR to LASTCHAR
-                                     do (\FSETWIDTH WIDTHS I (IQUOTIENT (ITIMES (\FGETWIDTH WIDTHS I)
-                                                                               NSMICASIZE)
-                                                                    1000]
-                  [COND
-                     [(EQ 1 (LOGAND FIXEDFLAGS 1))
-                      (COND
-                         ((ILESSP (GETFILEPTR WSTRM)
-                                 (GETEOFPTR WSTRM))
-                          (SETQ WIDTHSY (\WIN WSTRM)))
-                         (T                                  (* ; 
-                                                     "STAR FONT FILES LIKE TO LEAVE OFF THE Y WIDTH.")
-
-                            (SETQ WIDTHSY 0)))               (* ; 
-                  "The fixed width-Y for this font;  the width-Y field is a single integer in the FD")
-
-                      (replace (CHARSETINFO YWIDTHS) of CSINFO with (COND
-                                                                       ((AND RELFLAG
-                                                                             (NOT (ZEROP WIDTHSY)))
-                                                                        (IQUOTIENT (ITIMES WIDTHSY 
-                                                                                          NSMICASIZE)
-                                                                               1000))
-                                                                       (T WIDTHSY]
-                     (T                                      (* ; 
-                                                        "Variable Y-width font.  Fill it in as above")
-
-                        (SETQ WIDTHSY (replace (CHARSETINFO YWIDTHS) of CSINFO with (
-                                                                                 \CREATECSINFOELEMENT
-                                                                                     )))
-                        (for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHSY I noInfoCode))
-                        (\BINS (\GETOFD WSTRM 'INPUT)
-                               WIDTHSY
-                               (UNFOLD FIRSTCHAR BYTESPERWORD)
-                               (UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
-                                      BYTESPERWORD))         (* ; "Read the Y widths")
-
-                        (for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (\FGETWIDTH WIDTHSY I))
-                           do                                (* ; 
-                                               "Let any characters with no width info be zero height")
-
-                              (\FSETWIDTH WIDTHSY I 0))
-                        (COND
-                           (RELFLAG                          (* ; 
-                                                       "If the widths are size-relative, scale them.")
-
-                                  (for I from FIRSTCHAR to LASTCHAR
-                                     do (\FSETWIDTH WIDTHSY I (IQUOTIENT (ITIMES (\FGETWIDTH WIDTHSY 
-                                                                                        I)
-                                                                                NSMICASIZE)
-                                                                     1000]
-                  (RETURN CSINFO])
-)
-
-(RPAQ? PRESSFONTWIDTHSFILES '{ERIS}<LISP>FONTS>FONTS.WIDTHS)
-
-(ADDTOVAR SYSTEMINITVARS (PRESSFONTWIDTHSFILES {DSK}FONTS.WIDTHS))
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ noInfoCode 32768)
-
-
-(CONSTANTS noInfoCode)
-)
-)
-
-
-
-(* ;; "Bitmap printing support")
-
-(DEFINEQ
-
-(PRESSBITMAP
-  [LAMBDA (FILE BITMAP SCALEFACTOR CLIPPINGREGION)      (* ; "Edited 12-Jun-90 10:39 by mitani")
-
-         (* * This routine uses the whole page (ie PRTOP and PRRIGHT as opposed to 
-       PRWIDTH and PRHEIGHT) to produce a SPRUCE Press file.
-       It will truncate if necessary since SPRUCE does not support scaling)
-
-    (PROG ((PRSTREAM (OPENPRSTREAM FILE))
-           WIDTH HEIGHT PRDATA XPOS YPOS (PRESSPAGEHEIGHT (fetch (REGION HEIGHT) of 
-                                                                                    PRESSBITMAPREGION
-                                                                 ))
-           (PRESSPAGEWIDTH (fetch (REGION WIDTH) of PRESSBITMAPREGION)))
-          (SETQ PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))
-          (if (AND SCALEFACTOR (NOT (EQUAL SCALEFACTOR 1)))
-              then (ERROR "Spruce cannot scale bitmaps.  Try pressing to a full press printer."))
-                                                             (* Get width and height in screen 
-                                                           pts)
-          [COND
-             (CLIPPINGREGION (SETQ WIDTH (fetch (REGION WIDTH) of CLIPPINGREGION))
-                    (SETQ HEIGHT (fetch (REGION HEIGHT) of CLIPPINGREGION)))
-             (T (SETQ WIDTH (BITMAPWIDTH BITMAP))
-                (SETQ HEIGHT (BITMAPHEIGHT BITMAP]
-          (SETQ XPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEWIDTH (FIX (TIMES MicasPerPoint WIDTH)))
-                            2))
-          (SETQ YPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEHEIGHT (FIX (TIMES MicasPerPoint HEIGHT)))
-                            2))
-          [COND
-             ((OR (ILESSP XPOS 0)
-                  (ILESSP YPOS 0))
-              (printout T "Warning:  Bitmap too large for Spruce PRESS page, will be clipped..." T)
-              (SETQ XPOS (IMAX 0 XPOS))
-              (SETQ YPOS (IMAX 0 YPOS))
-              (SETQ CLIPPINGREGION (if CLIPPINGREGION
-                                       then [CREATEREGION (fetch (REGION LEFT) of 
-                                                                                       CLIPPINGREGION
-                                                                     )
-                                                       (fetch (REGION BOTTOM) of 
-                                                                                       CLIPPINGREGION
-                                                              )
-                                                       (FIX (MIN WIDTH (QUOTIENT PRESSPAGEWIDTH 
-                                                                              MicasPerPoint)))
-                                                       (FIX (MIN HEIGHT (QUOTIENT PRESSPAGEHEIGHT 
-                                                                               MicasPerPoint]
-                                     else (CREATEREGION 0 0 (FIX (MIN WIDTH (QUOTIENT 
-                                                                                       PRESSPAGEWIDTH
-                                                                                       MicasPerPoint)
-                                                                          ))
-                                                     (FIX (MIN HEIGHT (QUOTIENT PRESSPAGEHEIGHT 
-                                                                             MicasPerPoint]
-          (\WRITEPRESSBITMAP BITMAP (IPLUS (fetch (REGION LEFT) of PRESSBITMAPREGION)
-                                               XPOS)
-                 (IPLUS (fetch (REGION BOTTOM) of PRESSBITMAPREGION)
-                        YPOS)
-                 SCALEFACTOR CLIPPINGREGION PRSTREAM)
-          (RETURN (CLOSEF PRSTREAM])
-
-(FULLPRESSBITMAP
-  [LAMBDA (FILE BITMAP SCALEFACTOR CLIPPINGREGION)      (* ; "Edited 12-Jun-90 10:39 by mitani")
-
-         (* * This routine uses the whole page (ie PRTOP and PRRIGHT as opposed to 
-       PRWIDTH and PRHEIGHT) to produce a full Press file.
-       It will scale if necessary)
-
-         (* * When this fn is called from HARDCOPYW, the scalefactor should already be 
-       correct. On a direct call, it will handle it itself)
-
-    (PROG ((PRSTREAM (OPENPRSTREAM FILE))
-           WIDTH HEIGHT PRDATA XPOS YPOS (PRESSPAGEHEIGHT (fetch (REGION HEIGHT) of 
-                                                                                    PRESSBITMAPREGION
-                                                                 ))
-           (PRESSPAGEWIDTH (fetch (REGION WIDTH) of PRESSBITMAPREGION)))
-          (SETQ PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))
-          (if (NOT SCALEFACTOR)
-              then (SETQ SCALEFACTOR 1.0))               (* Get width and height in screen 
-                                                           pts)
-          [COND
-             (CLIPPINGREGION (SETQ WIDTH (fetch (REGION WIDTH) of CLIPPINGREGION))
-                    (SETQ HEIGHT (fetch (REGION HEIGHT) of CLIPPINGREGION)))
-             (T (SETQ WIDTH (BITMAPWIDTH BITMAP))
-                (SETQ HEIGHT (BITMAPHEIGHT BITMAP]
-          (SETQ XPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEWIDTH (FIX (TIMES MicasPerPoint WIDTH 
-                                                                        SCALEFACTOR)))
-                            2))
-          (SETQ YPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEHEIGHT (FIX (TIMES MicasPerPoint HEIGHT 
-                                                                         SCALEFACTOR)))
-                            2))
-          [COND
-             ((OR (ILESSP XPOS 0)
-                  (ILESSP YPOS 0))
-              (printout T "Warning:  Bitmap too large for PRESS page, will be scaled..." T)
-              (SETQ SCALEFACTOR (PRESS.BITMAPSCALE WIDTH HEIGHT))
-              (SETQ XPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEWIDTH (FIX (TIMES MicasPerPoint WIDTH 
-                                                                            SCALEFACTOR)))
-                                2))
-              (SETQ YPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEHEIGHT (FIX (TIMES MicasPerPoint HEIGHT 
-                                                                             SCALEFACTOR)))
-                                2))
-              (if (OR (ILESSP XPOS 0)
-                          (ILESSP YPOS 0))
-                  then (ERROR "Internal consistency check failed in FULLPRESSBITMAP."]
-          (\WRITEPRESSBITMAP BITMAP (IPLUS (fetch (REGION LEFT) of PRESSBITMAPREGION)
-                                               XPOS)
-                 (IPLUS (fetch (REGION BOTTOM) of PRESSBITMAPREGION)
-                        YPOS)
-                 SCALEFACTOR CLIPPINGREGION PRSTREAM)
-          (RETURN (CLOSEF PRSTREAM])
-
-(SHOWREGION
-  [LAMBDA (REGION STREAM)                               (* ; "Edited 12-Jun-90 10:38 by mitani")
-
-         (* * comment)
-
-    (PROG NIL
-          (MOVETO (fetch (REGION LEFT) of REGION)
-                 (fetch (REGION BOTTOM) of REGION)
-                 STREAM)
-          (RELDRAWTO (fetch (REGION WIDTH) of REGION)
-                 0 NIL NIL STREAM)
-          (RELDRAWTO 0 (fetch (REGION HEIGHT) of REGION)
-                 NIL NIL STREAM)
-          (RELDRAWTO (MINUS (fetch (REGION WIDTH) of REGION))
-                 0 NIL NIL STREAM)
-          (RELDRAWTO 0 (MINUS (fetch (REGION HEIGHT) of REGION))
-                 NIL NIL STREAM)
-          (RETURN STREAM])
-
-(SHOWPRESSBITMAPREGION
-  [LAMBDA NIL                                                (* gbn "16-Sep-84 19:18")
-          
-          (* * comment)
-
-    (PROG [(STR (OPENIMAGESTREAM '{LPT} 'PRESS]
-          (SHOWREGION PRESSBITMAPREGION STR)
-          (RETURN (CLOSEF STR])
-
-(PRESSWINDOW
-  [LAMBDA (W)                                           (* ; "Edited 12-Jun-90 10:39 by mitani")
-                                                             (* First Try)
-    (PROG ((PRSTREAM (OPENPRSTREAM '{CORE}WINDOW.PRESS (LIST 'HEADING "Press Stream Window Image"
-                                                                 'BREAKPAGEFILENAME 
-                                                                 "Press Stream Window Image")))
-           [BITMAP (WINDOW.BITMAP (OR W (WHICHW]
-           WIDTH HEIGHT (PTSTOMICAS 35))
-          (SETQ WIDTH (BITMAPWIDTH BITMAP))
-          (SETQ HEIGHT (BITMAPHEIGHT BITMAP))
-          (DSPXPOSITION (IPLUS (fetch PRLEFT of (fetch (STREAM IMAGEDATA) of PRSTREAM
-                                                               ))
-                               (IQUOTIENT (IDIFFERENCE (fetch PRWIDTH of (fetch
-                                                                                  (STREAM IMAGEDATA)
-                                                                                    of PRSTREAM))
-                                                 (ITIMES PTSTOMICAS WIDTH))
-                                      2))
-                 PRSTREAM)
-          (DSPYPOSITION (IPLUS (fetch PRBOTTOM of (fetch (STREAM IMAGEDATA) of 
-                                                                                             PRSTREAM
-                                                                 ))
-                               (IQUOTIENT (IDIFFERENCE (fetch PRHEIGHT of (fetch
-                                                                                   (STREAM IMAGEDATA)
-                                                                                     of PRSTREAM)
-                                                              )
-                                                 (ITIMES PTSTOMICAS HEIGHT))
-                                      2))
-                 PRSTREAM)
-          (\WRITEPRESSBITMAP BITMAP NIL NIL PRSTREAM)
-          (RETURN (CLOSEF PRSTREAM])
-
-(\WRITEPRESSBITMAP
-  [LAMBDA (BITMAP XPOS YPOS SCALEFACTOR CLIPPINGREGION PRSTREAM)
-                                                            (* ; "Edited 12-Jun-90 10:39 by mitani")
-                                                             (* This should define the origin of 
-                                                           the bitmap on the page)
-    [COND
-       (CLIPPINGREGION                                       (* UGH)
-              (SETQ BITMAP (PROG [(BM (BITMAPCREATE (fetch (REGION WIDTH) of CLIPPINGREGION)
-                                             (fetch (REGION HEIGHT) of CLIPPINGREGION]
-                                 (with REGION CLIPPINGREGION
-                                        (BITBLT BITMAP LEFT BOTTOM BM NIL NIL WIDTH HEIGHT))
-                                 (RETURN BM]
-    (PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))
-           (WW (fetch BITMAPRASTERWIDTH of BITMAP))
-           (HT (fetch BITMAPHEIGHT of BITMAP))
-           ELSTREAM TOTCOUNT CURX CURY)
-          (SETQ ELSTREAM (fetch ELSTREAM of PRDATA))
-          (SETQ CURX (fetch PRXPOS of PRDATA))
-          (SETQ CURY (fetch PRYPOS of PRDATA))
-          (SHOW.PRESS PRSTREAM)                          (* flush chars before ending entity)
-          (\ENTITYEND.PRESS PRSTREAM)
-
-         (* Close previous entity because we used to specify a translation for the 
-       bitmap entity. But now we are using the current x and y position.
-       All this stuff might therefore be unnecessary)
-
-          (\ENTITYSTART.PRESS PRSTREAM)
-          (SETXY.PRESS PRSTREAM XPOS YPOS)
-          (COND
-             ((NULL SCALEFACTOR)
-              (SETQ SCALEFACTOR 1.0)))
-          (\WOUT PRSTREAM 256)                               (* Output <<Set-Coding>>.
-                                                           (0 notates bitmap, followed by 2byte 
-                                                           width (in dots) and height
-                                                           (in dots)))
-          (\WOUT PRSTREAM (UNFOLD WW BITSPERWORD))           (* Width)
-          (\WOUT PRSTREAM HT)                                (* Height)
-          (\WOUT PRSTREAM (IPLUS 512 3))                     (* <<Set-Mode>> notates that the 
-                                                           Lisp bitmap is stored left-to-right 
-                                                           and top-to-bottom)
-          (\WOUT PRSTREAM 2)
-
-         (* you might think it should be MicasPerPoint -
-       ha ha ha! Only the value 32 works! Oops!)
-
-          [\WOUT PRSTREAM (FIXR (FTIMES SCALEFACTOR (TIMES 32 (UNFOLD WW BITSPERWORD]
-          [\WOUT PRSTREAM (FIXR (FTIMES SCALEFACTOR (TIMES 32 HT]
-          (\WOUT PRSTREAM 1)
-
-         (* Set Window. 2 bytes of how many bytes to skip, 2 bytes of how many dots wide 
-       to display followed by the same for lines)
-
-          (\WOUT PRSTREAM 0)                                 (* skip 0 dots)
-          (\WOUT PRSTREAM (UNFOLD WW BITSPERWORD))
-          (\WOUT PRSTREAM 0)                                 (* skip 0 lines)
-          (\WOUT PRSTREAM HT)
-          (\WOUT PRSTREAM 3)                                 (* <<Dots-Follow>>)
-                                                             (* TOTCOUNT is a word count.)
-          (\BOUTS PRSTREAM (fetch BITMAPBASE of BITMAP)
-                 0
-                 (UNFOLD (SETQ TOTCOUNT (ITIMES HT WW))
-                        BYTESPERWORD))
-          (\BOUT ELSTREAM ShowDotsCode)
-          (\FIXPOUT ELSTREAM (IPLUS TOTCOUNT 13))            (* Number of DL bytes)
-          (\ENTITYEND.PRESS PRSTREAM)
-          (\ENTITYSTART.PRESS PRSTREAM)                  (* Since START reestablishes X and 
-                                                           Y, following might not be necessary)
-          (SETXY.PRESS PRSTREAM CURX CURY])
-)
-
-
-
-(* ;; "Basic PRESS data structure output functions")
-
-(DEFINEQ
-
-(\BCPLSOUT.PRESS
-  [LAMBDA (STRM X N)                                         (* rmk%: "14-Jun-84 19:36")
-          
-          (* Puts out a Bcpl string X in N bytes, filling with zeroes or truncating if 
-          needed.)
-
-    (PROG [(NC (IMIN (NCHARS X)
-                     (SETQ N (SUB1 N]
-          (\BOUT STRM NC)
-          (for I from 1 to NC do (\BOUT STRM (NTHCHARCODE X I)))
-          (for I from (ADD1 NC) to N do (\BOUT STRM 0])
-
-(\PAGEPAD.PRESS
-  [LAMBDA (STRM)                                             (* rmk%: "14-Jun-84 18:30")
-          
-          (* Move the fileptr to the next record boundary, returning the number of words 
-          skipped.)
-
-    (PROG (PADDING (P (GETFILEPTR STRM)))
-          (SETQ PADDING (MODUP P BYTESPERRECORD))
-          (COND
-             ((IGREATERP PADDING 0)
-          
-          (* SETFILEPTR for all but 1, then \BOUT to make sure the file gets extended.)
-
-              [AND (NEQ PADDING 1)
-                   (SETFILEPTR STRM (IPLUS P (SUB1 PADDING]
-              (\BOUT STRM 0)))
-          (RETURN (FOLDLO PADDING BYTESPERWORD])
-
-(\ENTITYEND.PRESS
-  [LAMBDA (PRSTREAM XOFFSET YOFFSET ETYPE)              (* ; "Edited 12-Jun-90 10:39 by mitani")
-    (PROG (ELSTREAM DLLENGTH (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (SETQ ELSTREAM (fetch ELSTREAM of PRDATA))
-          (SETQ DLLENGTH (IDIFFERENCE (\GETFILEPTR PRSTREAM)
-                                (fetch DLSTARTBYTE of PRDATA)))
-          (COND
-             ((ODDP (GETFILEPTR ELSTREAM))
-              (\BOUT ELSTREAM NopCode)))
-          (\BOUT ELSTREAM (OR ETYPE LISPENTITYTYPE))
-          (\BOUT ELSTREAM (OR (fetch FONTSET# of (fetch PRCURRFDE of PRDATA))
-                              0))                            (* fontset)
-          (\FIXPOUT ELSTREAM (IDIFFERENCE (fetch DLSTARTBYTE of PRDATA)
-                                    (UNFOLD (fetch PRPARTSTART of PRDATA)
-                                           BYTESPERRECORD))) (* (IDIFFERENCE (fetch DLSTARTBYTE 
-                                                           of PRDATA) (UNFOLD
-                                                           (fetch PRPARTSTART of PRDATA) 
-                                                           BYTESPERRECORD)))
-                                                             (* part relative start of data list 
-                                                           for this entity)
-          (\FIXPOUT ELSTREAM DLLENGTH)                       (* length of data)
-          (\WOUT ELSTREAM (OR XOFFSET 0))                    (* Entity origin)
-          (\WOUT ELSTREAM (OR YOFFSET 0))
-          (\WOUT ELSTREAM (fetch PRLEFT of PRDATA))  (* The bounding box for this entity 
-                                                           -
-                                                           MAYBE LEFT AND BOTTOM ARE SIGNED?)
-          (\WOUT ELSTREAM (fetch PRBOTTOM of PRDATA))
-          (\WOUT ELSTREAM (IDIFFERENCE (fetch PRRIGHT of PRDATA)
-                                 (fetch PRLEFT of PRDATA)))
-                                                             (* width)
-          (\WOUT ELSTREAM (IDIFFERENCE (fetch PRTOP of PRDATA)
-                                 (fetch PRBOTTOM of PRDATA)))
-                                                             (* height)
-          (\WOUT ELSTREAM (ADD1 (FOLDLO (IDIFFERENCE (GETFILEPTR ELSTREAM)
-                                               (fetch ELSTARTBYTE of PRDATA))
-                                       BYTESPERWORD)))       (* Length in words--ADD1 for the 
-                                                           length itself)
-      ])
-
-(\PARTEND.PRESS
-  [LAMBDA (PRSTREAM PARTTYPE)                           (* ; "Edited 12-Jun-90 10:39 by mitani")
-
-         (* Closes one part and sets up for the next, by saving the partstart and 
-       emptying the entitylist stream)
-
-    (PROG (START PDSTREAM (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (SETQ PDSTREAM (fetch PDSTREAM of PRDATA))
-          (SETQ START (fetch PRPARTSTART of PRDATA))
-          (\WOUT PDSTREAM PARTTYPE)
-          (\WOUT PDSTREAM START)                             (* Starting record)
-                                                             (* Update starting record for next 
-                                                           part, and record length in records 
-                                                           of this part)
-          (\WOUT PDSTREAM (IDIFFERENCE (replace PRPARTSTART of PRDATA
-                                          with (FOLDHI (GETFILEPTR PRSTREAM)
-                                                          BYTESPERRECORD))
-                                 START))
-          (\WOUT PDSTREAM (\PAGEPAD.PRESS PRSTREAM))
-          (SETFILEPTR (fetch ELSTREAM of PRDATA)
-                 0])
-
-(\ENTITYSTART.PRESS
-  [LAMBDA (PRSTREAM)                                    (* ; "Edited 12-Jun-90 10:39 by mitani")
-    (PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (freplace PRSPACEWIDTH of PRDATA with NIL)
-
-         (* This really should be the spacewidth of the current font.
-       But then, if we switch fonts to one whose space*spacefactor comes out the same, 
-       we won't know to put out a setspace command.
-       So when we actually set up the first font in this entity, we will end up 
-       putting out an explicit setspace (even if the space factor is 1))
-
-          (freplace PRFONT of PRDATA with NIL)
-
-         (* We set the font to NIL, knowing that the current font can be recoverd from 
-       the PRCURRFDE. This font will be set in the press file before the first show, 
-       if no explicit dspfont intervenes. Note, however, that up until the first 
-       dspfont, the widthscache still corresponds to what was the PRFONT.)
-
-          (freplace DLSTARTBYTE of PRDATA with (\GETFILEPTR PRSTREAM))
-          (freplace ELSTARTBYTE of PRDATA with (\GETFILEPTR (fetch ELSTREAM
-                                                                           of PRDATA)))
-          (freplace STARTCHARBYTE of PRDATA with (\GETFILEPTR PRSTREAM))
-                                                             (* Entity starts with position at 
-                                                           0,0 so must re-establish current 
-                                                           position (?))
-          (SETXY.PRESS PRSTREAM (fetch PRXPOS of PRDATA)
-                 (fetch PRYPOS of PRDATA])
-
-(SETX.PRESS
-  [LAMBDA (PRSTREAM X)                                  (* ; "Edited 12-Jun-90 10:39 by mitani")
-    (PROG [(ELSTREAM (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM]
-          (COND
-             ([AND (IGEQ X SPRUCEPAPERLEFTMICAS)
-                   (ILEQ X SPRUCEPAPERRIGHTMICAS)
-                   (NOT (IEQP X (fetch PRXPOS of (fetch (STREAM IMAGEDATA) of 
-                                                                                             PRSTREAM
-                                                                ]
-              (\BOUT ELSTREAM SetXCode)                      (* Outcharfn ignores characters that 
-                                                           are not in the clipping region)
-              (\WOUT ELSTREAM X)))
-          (replace PRXPOS of (fetch (STREAM IMAGEDATA) of PRSTREAM) with X])
-
-(SETXY.PRESS
-  [LAMBDA (PRSTREAM X Y)                                (* ; "Edited 12-Jun-90 10:39 by mitani")
-    (PROG (ELSTREAM (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (SETQ ELSTREAM (fetch ELSTREAM of PRDATA))
-          (COND
-             ((AND (IGEQ X SPRUCEPAPERLEFTMICAS)
-                   (ILEQ X SPRUCEPAPERRIGHTMICAS))
-
-         (* this clause could be part of the above test to avoid putting out set x when 
-       the position is in the right place. There is a place that Ron thinks is in 
-       endvecrun where setxy is called to get the printer and the streams idea of 
-       where the position is back into step. Thus if this test is included, that setxy 
-       is not put out when it should be. rrb (NOT
-       (IEQP X (fetch PRXPOS of PRDATA))))
-
-              (\BOUT ELSTREAM SetXCode)
-              (\WOUT ELSTREAM X)))
-          (replace PRXPOS of PRDATA with X)
-          (COND
-             ((AND (IGEQ Y SPRUCEPAPERBOTTOMMICAS)
-                   (ILEQ Y SPRUCEPAPERTOPMICAS))
-
-         (* see above comment (NOT (IEQP Y (fetch PRYPOS of PRDATA))) This clause should 
-       NOT be reinserted, because functions like \ENTITYSTART.PRESS call this function 
-       and need to really have the commands emitted, even tho the PRXPOS and PRYPOS 
-       fields claim to be real.)
-
-              (\BOUT ELSTREAM SetYCode)
-              (\WOUT ELSTREAM Y)))
-          (RETURN (replace PRYPOS of PRDATA with Y])
-
-(SETY.PRESS
-  [LAMBDA (PRSTREAM Y)                                  (* ; "Edited 12-Jun-90 10:39 by mitani")
-    (PROG [(ELSTREAM (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM]
-          (COND
-             ([AND (IGEQ Y SPRUCEPAPERBOTTOMMICAS)
-                   (ILEQ Y SPRUCEPAPERTOPMICAS)
-                   (NOT (IEQP Y (fetch PRYPOS of (ffetch (STREAM IMAGEDATA) of 
-                                                                                             PRSTREAM
-                                                                ]
-              (\BOUT ELSTREAM SetYCode)
-              (\WOUT ELSTREAM Y)))
-          (freplace PRYPOS of (ffetch (STREAM IMAGEDATA) of PRSTREAM) with Y])
-
-(SHOW.PRESS
-  [LAMBDA (PRSTREAM)                                    (* ; "Edited 12-Jun-90 10:39 by mitani")
-    (PROG (CNT ELSTREAM (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))
-               (CURBYTE (\GETFILEPTR PRSTREAM)))
-          (SETQ ELSTREAM (fetch ELSTREAM of PRDATA))
-          (SETQ CNT (IDIFFERENCE CURBYTE (fetch STARTCHARBYTE of PRDATA)))
-          [COND
-             ((IGREATERP CNT 0)
-              [COND
-                 ((NULL (fetch PRFONT of PRDATA))
-
-         (* This is the first run of characters in this entity, and there has been no 
-       explicit dspfont. We therefore re-establish the current font as of the end of 
-       the last entity)
-
-                  (replace PRFONT of PRDATA with (fetch DESCR
-                                                                of (fetch PRCURRFDE
-                                                                          of PRDATA)))
-                  (\BOUT (fetch ELSTREAM of PRDATA)
-                         (LOGOR FontCode (fetch (FONTDIRENTRY FONT#) of (fetch PRCURRFDE
-                                                                                   of PRDATA]
-              (COND
-                 ((ILESSP CNT 33)                            (* short form)
-                  (\BOUT ELSTREAM (IPLUS ShowCharactersShortCode CNT -1)))
-                 (T                                          (* Break up every 255)
-                    (while (IGREATERP CNT 255) do (\BOUT ELSTREAM ShowCharactersCode)
-                                                         (\BOUT ELSTREAM 255)
-                                                         (SETQ CNT (IDIFFERENCE CNT 255))
-                       finally (\BOUT ELSTREAM ShowCharactersCode)
-                             (\BOUT ELSTREAM CNT]
-          (replace STARTCHARBYTE of PRDATA with CURBYTE])
-)
-
-
-
-(* ;; "Image stream support functions:")
-
-(DEFINEQ
-
-(OPENPRSTREAM
-  [LAMBDA (PRFILE OPTIONS)                                   (* rmk%: "17-Dec-84 10:34")
-          
-          (* Opens a Press stream, to which user can do OUTCHAR.
-          OPTIONS can include a REGION, HEADING, BREAKPAGEFILENAME, and FONTS.
-          FONTS is a list of fonts to be set up initially.
-          Headings will be printed in the first font in FONTS.
-          If FONTS is NIL, then the stream is initialized with the PRESS DEFAULTFONT)
-
-    (DECLARE (GLOBALVARS DEFAULTPAGEREGION \PRESSIMAGEOPS))
-    (PROG [OPT PRDATA (PRSTREAM (OPENSTREAM PRFILE 'OUTPUT 'NEW 8 '((TYPE BINARY]
-          [SETQ PRDATA (create PRESSDATA
-                              PRPAGEREGION _ (COND
-                                                ([type? REGION (SETQ OPT (LISTGET OPTIONS
-                                                                                'REGION]
-                                                 OPT)
-                                                (T DEFAULTPAGEREGION))
-                              PDSTREAM _ (PROG1 (OPENSTREAM '{NODIRCORE} 'BOTH 'OLD/NEW)
-          
-          (* Make sure the fileptr of the following is zero
-          (GETRESOURCE \PRESSPDSTREAM) (and free this in \CLOSE.PRESS))
-
-                                                )
-                              ELSTREAM _ (PROG1 (OPENSTREAM '{NODIRCORE} 'BOTH 'OLD/NEW)
-          
-          (* Make sure the fileptr of the following is zero
-          (GETRESOURCE \PRESSELSTREAM) (and free this in \CLOSE.PRESS))
-
-                                                )
-                              PRDOCNAME _ (LISTGET OPTIONS 'DOCUMENT.NAME]
-          (COND
-             ((OR (NEQ \NOIMAGEOPS (fetch (STREAM IMAGEOPS) of PRSTREAM))
-                  (NEQ 0 (GETEOFPTR PRSTREAM)))
-              (ERROR "can't convert existing file to Press" (FULLNAME PRSTREAM))
-                                                             (* GETEOFPTR might bomb on some 
-                                                             streams)
-              ))
-          (replace (STREAM OUTCHARFN) of PRSTREAM with (FUNCTION \OUTCHARFN.PRESS))
-          (replace (STREAM IMAGEOPS) of PRSTREAM with \PRESSIMAGEOPS)
-          (replace (STREAM IMAGEDATA) of PRSTREAM with PRDATA)
-          (COND
-             ((SETQ OPT (LISTGET OPTIONS 'HEADING))
-              (replace PRHEADING of PRDATA with OPT)))
-          (SETUPFONTS.PRESS PRSTREAM (LISTGET OPTIONS 'FONTS))
-          (\STARTPAGE.PRESS PRSTREAM)
-          (RETURN PRSTREAM])
-
-(\BITBLT.PRESS
-  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH 
-                 HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
-                 CLIPPEDSOURCEBOTTOM)                        (* hdj " 5-Dec-84 18:39")
-    (LET* ((OLDX (\DSPXPOSITION.PRESS DESTINATION))
-           (OLDY (\DSPYPOSITION.PRESS DESTINATION))
-           (DESTINATIONLEFT (OR DESTINATIONLEFT OLDX))
-           (DESTINATIONBOTTOM (OR DESTINATIONBOTTOM OLDY)))
-          (\DSPXPOSITION.PRESS DESTINATION DESTINATIONLEFT)
-          (\DSPYPOSITION.PRESS DESTINATION DESTINATIONBOTTOM)
-          (\WRITEPRESSBITMAP SOURCEBITMAP DESTINATIONLEFT DESTINATIONBOTTOM 1
-                 (COND
-                    (CLIPPINGREGION (INTERSECTREGIONS CLIPPINGREGION (CREATEREGION CLIPPEDSOURCELEFT 
-                                                                            CLIPPEDSOURCEBOTTOM WIDTH 
-                                                                            HEIGHT)))
-                    (T (CREATEREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM WIDTH HEIGHT)))
-                 DESTINATION)
-          (\DSPXPOSITION.PRESS DESTINATION OLDX)
-          (\DSPYPOSITION.PRESS DESTINATION OLDY))
-    T])
-
-(\BLTSHADE.PRESS
-  [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)
-                                                             (* hdj "12-Mar-85 12:30")
-    (LET* ((REGION (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT))
-           (DESTREGION (if CLIPPINGREGION
-                           then (INTERSECTREGIONS REGION CLIPPINGREGION)
-                         else REGION)))
-          
-          (* * (SHOWSHADE.IP STREAM TEXTURE DESTREGION OPERATION))
-                                                             (* Dovers print at 32 micas per point)
-          (\BLTSHADE.GENERICPRINTER TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT 
-                 OPERATION CLIPPINGREGION 32])
-
-(\SCALEDBITBLT.PRESS
-  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH 
-                 HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
-                 CLIPPEDSOURCEBOTTOM SCALE)                  (* hdj "14-Feb-85 14:33")
-    (LET* ((OLDX (\DSPXPOSITION.PRESS DESTINATION))
-           (OLDY (\DSPYPOSITION.PRESS DESTINATION))
-           (DESTINATIONLEFT (OR DESTINATIONLEFT OLDX))
-           (DESTINATIONBOTTOM (OR DESTINATIONBOTTOM OLDY)))
-          (\DSPXPOSITION.PRESS DESTINATION DESTINATIONLEFT)
-          (\DSPYPOSITION.PRESS DESTINATION DESTINATIONBOTTOM)
-          (\WRITEPRESSBITMAP SOURCEBITMAP DESTINATIONLEFT DESTINATIONBOTTOM SCALE
-                 (COND
-                    (CLIPPINGREGION (INTERSECTREGIONS CLIPPINGREGION (CREATEREGION CLIPPEDSOURCELEFT 
-                                                                            CLIPPEDSOURCEBOTTOM WIDTH 
-                                                                            HEIGHT)))
-                    (T (CREATEREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM WIDTH HEIGHT)))
-                 DESTINATION)
-          (\DSPXPOSITION.PRESS DESTINATION OLDX)
-          (\DSPYPOSITION.PRESS DESTINATION OLDY))
-    T])
-
-(\BITMAPSIZE.PRESS
-  [LAMBDA (STREAM BITMAP DIMENSION)                          (* rmk%: "17-Dec-84 10:22")
-    (SELECTQ DIMENSION
-        (WIDTH (UNFOLD (BITMAPWIDTH BITMAP)
-                      32))
-        (HEIGHT (UNFOLD (BITMAPHEIGHT BITMAP)
-                       32))
-        (NIL (CONS (UNFOLD (BITMAPWIDTH BITMAP)
-                          32)
-                   (UNFOLD (BITMAPHEIGHT BITMAP)
-                          32)))
-        (\ILLEGAL.ARG DIMENSION])
-
-(\CHARWIDTH.PRESS
-  [LAMBDA (STREAM CHARCODE)                             (* ; "Edited 12-Jun-90 10:39 by mitani")
-                                                             (* Gets the width of CHARCODE in an 
-                                                           Interpress STREAM, observing 
-                                                           spacefactor)
-
-         (* * Convert from NS characters back to old PARC-internal coding for PRESS 
-       fonts)
-
-    (SETQ CHARCODE (\PRESS.CONVERT.NSCHARACTER CHARCODE))
-
-         (* * Then compute the character's width.)
-
-    (COND
-       ((EQ CHARCODE (CHARCODE SPACE))                       (* If it's a SPACE, use the declared 
-                                                           space width from the stream)
-        (ffetch PRSPACEWIDTH of (ffetch (STREAM IMAGEDATA) of STREAM)))
-       (T (\FGETCHARWIDTH (ffetch PRFONT of (ffetch (STREAM IMAGEDATA) of STREAM))
-                 (LOGAND CHARCODE \CHARMASK])
-
-(\CLOSEF.PRESS
-  [LAMBDA (PRSTREAM)                                    (* ; "Edited 12-Jun-90 10:39 by mitani")
-                                                             (* FILENAME is for the printer break 
-                                                           page)
-    (\ENDPAGE.PRESS PRSTREAM)
-    (PROG (PDSTREAM (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (SETQ PDSTREAM (fetch PDSTREAM of PRDATA))
-          (COND
-             ((NEQ 0 (GETFILEPTR PDSTREAM))
-              (for FDE DESCR in (fetch PRESSFONTDIR of PRDATA) as I from
-                                                                                        0
-                 do (SETQ DESCR (fetch DESCR of FDE))
-                       (\WOUT PRSTREAM 16)
-                       (\BOUT PRSTREAM (fetch FONTSET# of FDE)) 
-                                                             (* Fontset)
-                       (\BOUT PRSTREAM (fetch FONT# of FDE)) 
-                                                             (* font#)
-                       (\BOUT PRSTREAM 3)                    (* (\BOUT PRSTREAM
-                                                           (fetch FIRSTCHAR of DESCR)))
-                       (\BOUT PRSTREAM 254)                  (* (\BOUT PRSTREAM
-                                                           (fetch LASTCHAR of DESCR)))
-                       (\BCPLSOUT.PRESS PRSTREAM (FONTPROP DESCR 'DEVICEFAMILY)
-                              20)
-                       [\BOUT PRSTREAM (\FACECODE (FONTPROP DESCR 'DEVICEFACE]
-                       (\BOUT PRSTREAM 3)                    (* (\BOUT PRSTREAM
-                                                           (fetch FIRSTCHAR of DESCR)))
-                       (\WOUT PRSTREAM (FONTPROP DESCR 'DEVICESIZE))
-                       (\WOUT PRSTREAM (fetch ROTATION of DESCR)))
-              (\WOUT PRSTREAM 0)                             (* Font part ends with 0 word)
-              (\PARTEND.PRESS PRSTREAM 1)
-              (COPYBYTES PDSTREAM PRSTREAM 0 (GETFILEPTR PDSTREAM))
-              (\PAGEPAD.PRESS PRSTREAM)
-              (PROG (DDRECORD (DDFILEPTR (GETFILEPTR PRSTREAM)))
-                                                             (* Write document directory)
-                    (SETQ DDRECORD (FOLDLO DDFILEPTR BYTESPERRECORD))
-                    (\WOUT PRSTREAM 27183)                   (* password)
-                    (\WOUT PRSTREAM (ADD1 DDRECORD))
-                    (\WOUT PRSTREAM (FOLDLO (GETFILEPTR PDSTREAM)
-                                           8))               (* number of parts, since each 
-                                                           occupies 8 bytes in PD)
-                    (\WOUT PRSTREAM (fetch PRPARTSTART of PRDATA))
-                                                             (* part directory)
-                    (\WOUT PRSTREAM (IDIFFERENCE DDRECORD (fetch PRPARTSTART of PRDATA)))
-                    (\SIGNEDWOUT PRSTREAM -1)                (* obselete)
-                    (\FIXPOUT PRSTREAM (LISP.TO.ALTO.DATE (IDATE)))
-                    (\WOUT PRSTREAM 1)
-                    (\WOUT PRSTREAM 1)                       (* copies)
-                    (\SIGNEDWOUT PRSTREAM -1)
-                    (\SIGNEDWOUT PRSTREAM -1)                (* first and last pages)
-                    (\SIGNEDWOUT PRSTREAM -1)                (* printing mode default)
-                    (SETFILEPTR PRSTREAM (IPLUS DDFILEPTR 256))
-                    (\BCPLSOUT.PRESS PRSTREAM (OR (fetch PRDOCNAME of PRDATA)
-                                                      (FULLNAME PRSTREAM))
-                           52)
-                    (\BCPLSOUT.PRESS PRSTREAM USERNAME 32)
-                    (\BCPLSOUT.PRESS PRSTREAM (GETFILEINFO PRSTREAM 'CREATIONDATE)
-                           40)
-                    (\PAGEPAD.PRESS PRSTREAM])
-
-(\DRAWLINE.PRESS
-  [LAMBDA (PRSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING)
-                                                             (* rrb "27-Sep-85 18:15")
-    (COND
-       (DASHING 
-          
-          (* hack to handle dashing by breaking into small lines.
-          Should be removed if \DRAWCURVE.PRESS is ever updated to handle dashing.
-          rrb -
-          27-sept-85)
-
-              (DRAWDASHEDLINE X1 Y1 X2 Y2 WIDTH OPERATION PRSTREAM COLOR DASHING))
-       (T (\DRAWCURVE.PRESS PRSTREAM (LIST (CREATEPOSITION X1 Y1)
-                                           (CREATEPOSITION X2 Y2))
-                 NIL
-                 (LIST 'BUTT WIDTH)
-                 DASHING)))
-    Y2])
-
-(\ENDPAGE.PRESS
-  [LAMBDA (PRSTREAM)                                    (* ; "Edited 12-Jun-90 10:39 by mitani")
-    (PROG [(ELSTREAM (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM]
-          (SHOW.PRESS PRSTREAM)
-          (\ENTITYEND.PRESS PRSTREAM)
-          (COND
-             ((NEQ 0 (\GETFILEPTR ELSTREAM))
-              (COND
-                 ((ODDP (\GETFILEPTR PRSTREAM))
-                  (\BOUT PRSTREAM 0)))
-              (\WOUT PRSTREAM 0)                             (* 0 word to separate DL from EL)
-              (COPYBYTES ELSTREAM PRSTREAM 0 (\GETFILEPTR ELSTREAM))
-              (\PARTEND.PRESS PRSTREAM 0])
-
-(NEWLINE.PRESS
-  [LAMBDA (PRSTREAM)                                    (* ; "Edited 12-Jun-90 10:39 by mitani")
-                                                             (* Go to next line
-                                                           (or next page))
-    (PROG (NEWYPOS (PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (SETQ NEWYPOS (IPLUS (ffetch PRYPOS of PRDATA)
-                               (ffetch PRLINEFEED of PRDATA)))
-          (COND
-             ((ILESSP NEWYPOS (ffetch PRBOTTOM of PRDATA))
-              (NEWPAGE.PRESS PRSTREAM))
-             (T (SHOW.PRESS PRSTREAM)
-                (SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA)
-                       NEWYPOS])
-
-(NEWPAGE.PRESS
-  [LAMBDA (PRSTREAM)                                         (* rmk%: "16-Jun-84 14:29")
-    (\ENDPAGE.PRESS PRSTREAM)
-    (\STARTPAGE.PRESS PRSTREAM])
-
-(SETUPFONTS.PRESS
-  [LAMBDA (PRSTREAM FONTS)                              (* ; "Edited 12-Jun-90 10:40 by mitani")
-
-         (* Sets up fonts in the initial fontset.
-       and sets heading font. Leaves PRFONT as NIL.
-       This means that \DSPFONT.PRESS of the heading font will establish that as the 
-       current font when the first page opens.)
-
-    (for F FLG inside (OR FONTS DEFAULTFONT) do (SETQ F (FONTCREATE F NIL NIL NIL
-                                                                           'PRESS))
-                                                           (COND
-                                                              (FLG (\DEFINEFONT.PRESS PRSTREAM F)
-                                                                   )
-                                                              (T (\DSPFONT.PRESS PRSTREAM F)
-                                                             (* Install first font as current 
-                                                           font and heading font.
-                                                           font.)
-                                                                 (\ENTITYEND.PRESS PRSTREAM)
-                                                                 (replace PRHEADINGFONT
-                                                                    of (fetch (STREAM 
-                                                                                            IMAGEDATA
-                                                                                             )
-                                                                              of PRSTREAM)
-                                                                    with F)
-                                                                 (SETQ FLG T])
-
-(\DEFINEFONT.PRESS
-  [LAMBDA (PRSTREAM FONT)                               (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (RETURN (OR (FASSOC FONT (fetch PRESSFONTDIR of PRDATA))
-                      (CAR (push (fetch PRESSFONTDIR of PRDATA)
-                                  (PROG1 (create FONTDIRENTRY
-                                                DESCR _ FONT
-                                                FONT# _ (fetch PRNEXTFONT# of PRDATA)
-                                                FONTSET# _ (fetch PRMAXFONTSET of PRDATA))
-                                      (COND
-                                         ((EQ 16 (add (fetch PRNEXTFONT# of PRDATA)
-                                                        1))
-                                          (add (fetch PRMAXFONTSET of PRDATA)
-                                                 1)
-                                          (replace PRNEXTFONT# of PRDATA with 0))))])
-
-(\DSPBOTTOMMARGIN.PRESS
-  [LAMBDA (PRSTREAM YPOSITION)                          (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (PROG1 (fetch PRBOTTOM of (fetch (STREAM IMAGEDATA) of PRSTREAM))
-        (COND
-           (YPOSITION (replace PRBOTTOM of (fetch (STREAM IMAGEDATA) of PRSTREAM)
-                         with YPOSITION))))])
-
-(\DSPCLIPPINGREGION.PRESS
-  [LAMBDA (STREAM REGION)                               (* ; "Edited 12-Jun-90 10:40 by mitani")
-                                                             (* sets the clipping region of a 
-                                                           PRESS stream.)
-    (PROG ((PRDATA (FETCH (STREAM IMAGEDATA) OF STREAM)))
-          (RETURN (PROG1 (ffetch PRClippingRegion of PRDATA)
-                      [COND
-                         (REGION (OR (type? REGION REGION)
-                                     (ERROR REGION " is not a REGION."))
-                                (UNINTERRUPTABLY
-                                    (freplace PRClippingRegion of PRDATA with REGION))])])
-
-(\DSPFONT.PRESS
-  [LAMBDA (PRSTREAM FONT)                                    (* ; "Edited 14-Jul-2025 22:58 by rmk")
-                                                             (* ; "Edited  5-Jul-2025 18:49 by rmk")
-
-(* ;;; "The DSPFONT method for PRESS-type image streams -- change the stream's current font to FONT")
-
-         (* * The DSPFONT method for PRESS-type image streams --
-         change the stream's current font to FONT)
-
-    (PROG ((PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM))
-           CSINFO OLDFONT FDENTRY)
-          (SETQ OLDFONT (ffetch PRFONT of PRDATA))
-          (COND
-             ([OR (NULL FONT)
-                  (EQ OLDFONT (SETQ FONT (OR (FONTCREATE FONT NIL NIL NIL 'PRESS T)
-                                             (FONTCOPY OLDFONT FONT]
-                                                             (* ; 
-                         "If no new font was specified, or it's the same font, don't bother with it.")
-              (RETURN OLDFONT)))
-          (SHOW.PRESS PRSTREAM)
-          (SETQ CSINFO (\GETCHARSETINFO 0 FONT T))           (* ; 
-                                                        "Since PRESS only uses charset 0 for now....")
-          (SETQ FDENTRY (\DEFINEFONT.PRESS PRSTREAM FONT))
-          (COND
-             ((NEQ (ffetch FONTSET# of FDENTRY)
-                   (ffetch FONTSET# of (ffetch PRCURRFDE of PRDATA)))
-                                                             (* ; "Swtich font sets")
-              (\ENTITYEND.PRESS PRSTREAM)
-              (\ENTITYSTART.PRESS PRSTREAM)))
-          (freplace PRCURRFDE of PRDATA with FDENTRY)
-          (freplace PRFONT of PRDATA with FONT)
-          (\BOUT (ffetch ELSTREAM of PRDATA)
-                 (LOGOR FontCode (ffetch FONT# of FDENTRY)))
-          (freplace PRWIDTHSCACHE of PRDATA with (fetch (CHARSETINFO WIDTHS) OF CSINFO))
-          [\SETSPACE.PRESS PRSTREAM (FIXR (TIMES (ffetch PRSPACEFACTOR of PRDATA)
-                                                 (\FGETWIDTH (ffetch PRWIDTHSCACHE of PRDATA)
-                                                        (CHARCODE SPACE]
-          [freplace PRLINEFEED of PRDATA with (IDIFFERENCE (CONSTANT (IMINUS MicasPerPoint))
-                                                     (FONTPROP FONT 'HEIGHT]
-          (\FIXLINELENGTH.PRESS PRSTREAM)
-          (RETURN OLDFONT])
-
-(\DSPLEFTMARGIN.PRESS
-  [LAMBDA (PRSTREAM XPOSITION)                          (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (PROG1 (ffetch PRLEFT of (ffetch (STREAM IMAGEDATA) of PRSTREAM))
-        (COND
-           (XPOSITION (freplace PRLEFT of (ffetch (STREAM IMAGEDATA) of PRSTREAM)
-                         with XPOSITION)
-                  (\FIXLINELENGTH.PRESS PRSTREAM))))])
-
-(\DSPLINEFEED.PRESS
-  [LAMBDA (PRSTREAM DELTAY)                             (* ; "Edited 12-Jun-90 10:40 by mitani")
-                                                             (* sets the amount that a line feed 
-                                                           increases the y coordinate by.)
-    (PROG ((PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (RETURN (PROG1 (ffetch PRLINEFEED of PRDATA)
-                      [AND DELTAY (COND
-                                     ((NUMBERP DELTAY)
-                                      (freplace PRLINEFEED of PRDATA with DELTAY))
-                                     (T (\ILLEGAL.ARG DELTAY])])
-
-(\DSPRIGHTMARGIN.PRESS
-  [LAMBDA (PRSTREAM XPOSITION)                          (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (PROG1 (ffetch PRRIGHT of (ffetch (STREAM IMAGEDATA) of PRSTREAM))
-        (COND
-           (XPOSITION (freplace PRRIGHT of (ffetch (STREAM IMAGEDATA) of PRSTREAM)
-                         with XPOSITION)
-                  (\FIXLINELENGTH.PRESS PRSTREAM))))])
-
-(\DSPSPACEFACTOR.PRESS
-  [LAMBDA (STREAM FACTOR)                               (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (PROG ((PRDATA (ffetch (STREAM IMAGEDATA) of STREAM)))
-          (RETURN (PROG1 (ffetch PRSPACEFACTOR of PRDATA)
-                      [COND
-                         (FACTOR (SHOW.PRESS STREAM)
-                                (freplace PRSPACEFACTOR of PRDATA with FACTOR)
-                                (\SETSPACE.PRESS STREAM
-                                       (FIXR (TIMES FACTOR (\FGETWIDTH (ffetch PRWIDTHSCACHE
-                                                                          of PRDATA)
-                                                                  (CHARCODE SPACE])])
-
-(\DSPTOPMARGIN.PRESS
-  [LAMBDA (PRSTREAM YPOSITION)                          (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (PROG1 (fetch PRTOP of (fetch (STREAM IMAGEDATA) of PRSTREAM))
-        (COND
-           (YPOSITION (replace PRTOP of (fetch (STREAM IMAGEDATA) of PRSTREAM)
-                         with YPOSITION))))])
-
-(\DSPXPOSITION.PRESS
-  [LAMBDA (PRSTREAM XPOSITION)                          (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (PROG1 (fetch PRXPOS of (fetch (STREAM IMAGEDATA) of PRSTREAM))
-        (COND
-           (XPOSITION (SHOW.PRESS PRSTREAM)
-                  (SETX.PRESS PRSTREAM XPOSITION))))])
-
-(\DSPYPOSITION.PRESS
-  [LAMBDA (PRSTREAM YPOSITION)                          (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (PROG1 (fetch PRYPOS of (fetch (STREAM IMAGEDATA) of PRSTREAM))
-        (COND
-           (YPOSITION (SHOW.PRESS PRSTREAM)
-                  (SETY.PRESS PRSTREAM YPOSITION))))])
-
-(\FIXLINELENGTH.PRESS
-  [LAMBDA (PRSTREAM)                                    (* ; "Edited 12-Jun-90 10:40 by mitani")
-
-         (* PRSTREAM is known to be a stream of type press.
-       Called by RIGHTMARGIN LEFTMARGIN and \DSPFONT.PRESS to update the LINELENGTH 
-       field in the stream. also called when the stream is created.)
-
-    (PROG (LLEN (PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (freplace (STREAM LINELENGTH) of PRSTREAM
-             with (COND
-                         ((IGREATERP [SETQ LLEN (IQUOTIENT (IDIFFERENCE (ffetch PRRIGHT
-                                                                           of PRDATA)
-                                                                  (ffetch PRLEFT of PRDATA))
-                                                       (fetch FONTAVGCHARWIDTH
-                                                          of (fetch PRFONT of PRDATA]
-                                 1)
-                          LLEN)
-                         (T 10])
-
-(\OUTCHARFN.PRESS
-  [LAMBDA (PRSTREAM CHARCODE)                           (* ; "Edited 12-Jun-90 10:40 by mitani")
-                                                             (* Handle all the special-purpose 
-                                                           characters going to a PRESS file)
-    (SELCHARQ CHARCODE
-         (EOL                                                (* New Line)
-              (NEWLINE.PRESS PRSTREAM)
-              (replace (STREAM CHARPOSITION) of PRSTREAM with 0))
-         (LF                                                 (* Line feed--move down, but not 
-                                                           over)
-             (\DSPXPOSITION.PRESS PRSTREAM (PROG1 (DSPXPOSITION NIL PRSTREAM)
-                                                      (NEWLINE.PRESS PRSTREAM))))
-         (^L                                                 (* Form Feed)
-             (replace (STREAM CHARPOSITION) of PRSTREAM with 0)
-             (NEWPAGE.PRESS PRSTREAM))
-         (PROG (XPOS NEWXPOS CLIPPINGREGION (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)))
-               (SETQ XPOS (fetch PRXPOS of PRDATA))
-               (SETQ CHARCODE (\PRESS.CONVERT.NSCHARACTER CHARCODE))
-               [SETQ NEWXPOS (IPLUS XPOS (COND
-                                            ((EQ CHARCODE (CHARCODE SPACE))
-                                             (ffetch PRSPACEWIDTH of PRDATA))
-                                            (T (\FGETWIDTH (ffetch PRWIDTHSCACHE of PRDATA)
-                                                      CHARCODE]
-               (COND
-                  ((AND [IGEQ XPOS (fetch (REGION LEFT) of (SETQ CLIPPINGREGION
-                                                                    (fetch PRClippingRegion
-                                                                       of PRDATA]
-                        (ILEQ NEWXPOS (fetch (REGION RIGHT) of CLIPPINGREGION))
-                        (IGEQ (fetch PRYPOS of PRDATA)
-                              (fetch (REGION BOTTOM) of CLIPPINGREGION)))
-                                                             (* Bottom test should really 
-                                                           subtract off the descent, and also 
-                                                           should do a top-test)
-                                                             (* The Y-tests can probably be done 
-                                                           inside SETXY, SETY, and DSPFONT.)
-                   [COND
-                      ((NOT (ffetch CHARWASDISPLAYING of PRDATA))
-                                                             (* Was being clipped, now not)
-                       (freplace CHARWASDISPLAYING of PRDATA with T)
-                       (SHOW.PRESS PRSTREAM)             (* SHOW shouldn't be necessary, but 
-                                                           |...|)
-                       (SETXY.PRESS PRSTREAM XPOS (fetch PRYPOS of PRDATA]
-                   (\BOUT PRSTREAM CHARCODE))
-                  (T (SHOW.PRESS PRSTREAM)               (* Don't put out any characters if 
-                                                           out of the clipping region)
-                     (freplace CHARWASDISPLAYING of PRDATA with NIL)))
-               (replace PRXPOS of PRDATA with NEWXPOS])
-
-(\SETSPACE.PRESS
-  [LAMBDA (PRSTREAM S)                                  (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (PROG (ELSTREAM (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (AND (EQ S (ffetch PRSPACEWIDTH of PRDATA))
-               (RETURN))
-          (SETQ ELSTREAM (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (if (ILEQ S 2047)
-              then (\WOUT ELSTREAM (IPLUS (LLSH SetSpaceXShortCode 8)
-                                              S))
-            else (\BOUT ELSTREAM SetSpaceXCode)
-                  (\WOUT ELSTREAM S))
-          (freplace PRSPACEWIDTH of PRDATA with S])
-
-(\STARTPAGE.PRESS
-  [LAMBDA (PRSTREAM)                                    (* ; "Edited 12-Jun-90 10:40 by mitani")
-                                                             (* Should be called only when no 
-                                                           previous page is open)
-    (PROG (CFONT HFONT SPACEFACTOR (PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM)))
-          (SETQ CFONT (ffetch PRFONT of PRDATA))
-
-         (* Save current font so that \ENTITYSTART.PRESS can make PRFONT be NIL, 
-       indicating that there is no actual font at the beginning of a page)
-
-          (\ENTITYSTART.PRESS PRSTREAM)
-          [COND
-             ((ffetch PRHEADING of PRDATA)
-              (SETQ SPACEFACTOR (ffetch PRSPACEFACTOR of PRDATA))
-              (freplace PRSPACEFACTOR of PRDATA with 1)
-              (SETQ HFONT (ffetch PRHEADINGFONT of PRDATA))
-              (\DSPFONT.PRESS PRSTREAM HFONT)            (* Set up heading font)
-              [SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA)
-                     (IDIFFERENCE (ffetch PRTOP of PRDATA)
-                            (FONTPROP HFONT 'ASCENT]
-              (PRIN3 (ffetch PRHEADING of PRDATA)
-                     PRSTREAM)                               (* Skip an inch before page number)
-              (SHOW.PRESS PRSTREAM)
-              (SETX.PRESS PRSTREAM (IPLUS MICASPERINCH (ffetch PRXPOS of PRDATA)))
-              (PRIN3 "Page " PRSTREAM)
-              (PRIN3 (add (ffetch PRPAGENUM of PRDATA)
-                            1)
-                     PRSTREAM)
-              (NEWLINE.PRESS PRSTREAM)                   (* Skip 2 lines)
-              (NEWLINE.PRESS PRSTREAM)
-              (freplace PRSPACEFACTOR of PRDATA with SPACEFACTOR))
-             (T (SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA)
-                       (IDIFFERENCE (ffetch PRTOP of PRDATA)
-                              (FONTPROP CFONT 'ASCENT]       (* Now we set the font to our
-                                                           (previous) current font)
-          (\DSPFONT.PRESS PRSTREAM CFONT])
-
-(\STRINGWIDTH.PRESS
-  [LAMBDA (STREAM STRING RDTBL)                         (* ; "Edited 12-Jun-90 10:40 by mitani")
-
-         (* * Returns the width of STRING in the press STREAM, observing spacefactor)
-
-         (* * This is based on the code in \STRINGWIDTH.GENERIC)
-
-    (PROG [(PRFONT (ffetch PRFONT of (ffetch (STREAM IMAGEDATA) of STREAM]
-          [COND
-             [(LITATOM STRING)                               (* It's an atom. Loop thru its 
-                                                           characters.)
-              (if RDTBL
-                  then (GO SLOW)
-                else                                     (* Only doing pname, much simpler 
-                                                           task)
-                      (RETURN (LET ((WIDTHSBASE (ffetch (CHARSETINFO WIDTHS)
-                                                   of (\GETCHARSETINFO 0 PRFONT)))
-                                    CSET)
-                                   (for C inatom STRING
-                                      sum (SETQ C (\PRESS.CONVERT.NSCHARACTER C)) 
-                                                             (* CONVERT from NS characters back 
-                                                           to old PARC-internal coding for 
-                                                           PRESS fonts)
-                                            (COND
-                                               ((EQ C (CHARCODE SPACE))
-                                                (ffetch PRSPACEWIDTH of (ffetch
-                                                                                 (STREAM IMAGEDATA)
-                                                                                   of STREAM)))
-                                               (T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C]
-             ((STRINGP STRING)                               (* It's a string; we know how to 
-                                                           loop thru its chars quickly)
-              (RETURN
-               (LET ((TOTAL 0)
-                     (WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO 0 PRFONT)))
-                     ESCWIDTH ESC CSET)
-                    [COND
-                       (RDTBL                                (* Count delimiting quotes and 
-                                                           internal escapes)
-                              (SETQ TOTAL (UNFOLD (\FGETWIDTH WIDTHSBASE (CHARCODE %"))
-                                                 2))
-                              (SETQ ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL))
-                              (SETQ ESCWIDTH (\FGETWIDTH WIDTHSBASE ESC]
-                    [for C instring STRING
-                       do (SETQ C (\PRESS.CONVERT.NSCHARACTER C)) 
-                                                             (* CONVERT from NS characters back 
-                                                           to old PARC-internal coding for 
-                                                           PRESS fonts)
-                             (add TOTAL (COND
-                                               ((EQ C (CHARCODE SPACE))
-                                                (ffetch PRSPACEWIDTH of (ffetch
-                                                                                 (STREAM IMAGEDATA)
-                                                                                   of STREAM)))
-                                               (T (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C))
-                                                         (COND
-                                                            ((AND RDTBL (OR (EQ C (CHARCODE %"))
-                                                                            (EQ C ESC)))
-                                                             (* String char must be escaped)
-                                                             ESCWIDTH)
-                                                            (T 0]
-                    TOTAL]
-      SLOW
-          (RETURN (LET ((TOTALWIDTH 0)
-                        (WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO 0 PRFONT
-                                                                                   )))
-                        CSET)
-
-         (* * Neither atom nor string; we have to use \MAPPNAME to do the job.)
-
-                       (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CC)
-                                              (SETQ CC (\PRESS.CONVERT.NSCHARACTER CC))
-                                                             (* Convert from NS characters back 
-                                                           to old PARC-internal coding for 
-                                                           PRESS fonts)
-                                              (add TOTALWIDTH (COND
-                                                                     ((EQ CC (CHARCODE SPACE))
-                                                                      (ffetch PRSPACEWIDTH
-                                                                         of (ffetch
-                                                                                 (STREAM IMAGEDATA)
-                                                                                   of STREAM)))
-                                                                     (T (\FGETWIDTH WIDTHSBASE
-                                                                               (\CHAR8CODE CC]
-                              STRING RDTBL RDTBL)
-                       TOTALWIDTH])
-
-(SHOWRECTANGLE.PRESS
-  [LAMBDA (PRSTREAM WIDTH HEIGHT)                       (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (PROG [(ELSTREAM (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM]
-          (\BOUT ELSTREAM ShowRectangleCode)
-          (\WOUT ELSTREAM WIDTH)
-          (\WOUT ELSTREAM HEIGHT])
-
-(\PRESS.CONVERT.NSCHARACTER
-  [LAMBDA (CHARCODE)                                         (* jds " 4-Nov-85 08:02")
-          
-          (* Provide backward compatibility for extended-language characters in the PRESS 
-          printing environment. Converts certain of the NS characters into their 
-          equivalent PARC-internal charcodes)
-
-    (SELCHARQ CHARCODE
-         (357,55                                             (* em quad)
-                 153)
-         (357,54                                             (* en quad)
-                 152)
-         (357,57                                             (* Thin space)
-                 159)
-         (357,44                                             (* en dash / figure dash)
-                 155)
-         (357,45                                             (* em dash)
-                 156)
-         (357,146                                            (* bullet)
-                  183)
-         (0,251                                              (* left single quote)
-                96)
-         (0,271                                              (* right single quote)
-                39)
-         (\CHAR8CODE CHARCODE])
-)
-
-
-
-(* ; "Drawcurve code")
-
-(DEFINEQ
-
-(\ENDVECRUN
-  [LAMBDA (PRSTREAM HALFVECWIDTH)                       (* ; "Edited 12-Jun-90 10:40 by mitani")
-    (SHOW.PRESS PRSTREAM)
-    (PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))
-           ORIGXPOS ORIGYPOS XPOS YPOS WASDISPLAYING ORIGWASDISPLAYING)
-          (COND
-             ((NOT (fetch VECMOVINGRIGHT of PRDATA))
-
-         (* We've been moving to the left, so it's time to uncache those characters we 
-       saved.)
-
-              (SETQ XPOS (fetch VECCURX of PRDATA))
-              (SETQ YPOS (fetch VECCURY of PRDATA))
-              (SETQ ORIGXPOS (FIXR (FTIMES MicasPerScan XPOS)))
-                                                             (* Remember where the end of the 
-                                                           line is, so we can come back here.)
-              (SETQ ORIGYPOS (FIXR (FTIMES MicasPerScan YPOS)))
-              [SETQ ORIGWASDISPLAYING (AND (IGEQ XPOS (IPLUS SPRUCEPAPERLEFTSCANS HALFVECWIDTH))
-                                           (IGEQ YPOS (IPLUS SPRUCEPAPERBOTTOMSCANS HALFVECWIDTH))
-                                           (ILESSP YPOS (IDIFFERENCE SPRUCEPAPERTOPSCANS HALFVECWIDTH
-                                                               ))
-                                           (ILESSP XPOS (IDIFFERENCE SPRUCEPAPERRIGHTSCANS 
-                                                               HALFVECWIDTH]
-              (SETQ WASDISPLAYING ORIGWASDISPLAYING)         (* Decide whether to start out by 
-                                                           displaying any characters or not.)
-              (COND
-                 (WASDISPLAYING (SETXY.PRESS PRSTREAM ORIGXPOS ORIGYPOS)))
-
-         (* We may have been adjusting the X and Y position in the PRDATA without 
-       actually putting out the file commands)
-
-              [for CH in (fetch VECSEGCHARS of PRDATA)
-                 do (COND
-                           [(AND (IGEQ XPOS (IPLUS SPRUCEPAPERLEFTSCANS HALFVECWIDTH))
-                                 (IGEQ YPOS (IPLUS SPRUCEPAPERBOTTOMSCANS HALFVECWIDTH))
-                                 (ILESSP YPOS (IDIFFERENCE SPRUCEPAPERTOPSCANS HALFVECWIDTH))
-                                 (ILESSP XPOS (IDIFFERENCE SPRUCEPAPERRIGHTSCANS HALFVECWIDTH)))
-                                                             (* We're on-paper.
-                                                           Go ahead and display the character.)
-                            (COND
-                               ((NOT WASDISPLAYING)          (* We haven't really been displaying 
-                                                           characters up to now--we need to 
-                                                           reposition.)
-                                (SHOW.PRESS PRSTREAM)
-                                (SETXY.PRESS PRSTREAM (FIXR (FTIMES MicasPerScan XPOS))
-                                       (FIXR (FTIMES MicasPerScan YPOS)))
-                                (SETQ WASDISPLAYING T)))
-                            (\BOUT PRSTREAM (\VECENCODE (IMINUS (CAR CH))
-                                                   (IMINUS (CDR CH]
-                           (T                                (* We are off-paper.
-                                                           Stop displaying, and remember that 
-                                                           we took a hiatus)
-                              (SETQ WASDISPLAYING NIL)))
-                       (SETQ XPOS (IDIFFERENCE XPOS (CAR CH)))
-                       (SETQ YPOS (IDIFFERENCE YPOS (CDR CH]
-              (SHOW.PRESS PRSTREAM)
-              (SETXY.PRESS PRSTREAM ORIGXPOS ORIGYPOS)
-              (replace VECWASDISPLAYING of PRDATA with ORIGWASDISPLAYING)))
-          (replace VECSEGCHARS of PRDATA with NIL])
-
-(\VECENCODE
-  [LAMBDA (DX DY)                                            (* jds "18-DEC-81 15:48")
-          
-          (* Given dx and dy in dover pixels, decide which Vector Font character 
-          represents that move, and return it.)
-
-    (if (ILESSP 0 DY)
-        then (IDIFFERENCE (IPLUS 160 DX (IMINUS DY))
-                    (ITIMES 9 (IMAX DX DY)))
-      else (IDIFFERENCE (IDIFFERENCE (IDIFFERENCE 160 DX)
-                               DY)
-                  (ITIMES 7 (IMAX DX (IMINUS DY])
-
-(\VECPUT
-  [LAMBDA (PRSTREAM DX DY HALFVECWIDTH)                 (* ; "Edited 12-Jun-90 10:40 by mitani")
-
-         (* Send this dx,dy pair to the press file;
-       hold and reverse any strings which run right-to-left on the page.)
-
-    (PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))
-           XPOS YPOS)
-          (COND
-             ((OR (AND (fetch VECMOVINGRIGHT of PRDATA)
-                       (ILESSP DX 0))
-                  (AND (NOT (fetch VECMOVINGRIGHT of PRDATA))
-                       (ILESSP 0 DX)))
-
-         (* We switched direction (LEFT->RIGHT or RIGHT->LEFT)%.
-       Put out what we've got, and start the new run.)
-
-              (\ENDVECRUN PRSTREAM HALFVECWIDTH)
-              (replace VECMOVINGRIGHT of PRDATA with (NOT (fetch VECMOVINGRIGHT
-                                                                         of PRDATA)))
-                                                             (* Switch the direction we think 
-                                                           we're moving.)
-              ))
-          (SETQ XPOS (fetch VECCURX of PRDATA))      (* In DOVER spots)
-          (SETQ YPOS (fetch VECCURY of PRDATA))
-          (replace VECCURX of PRDATA with (IPLUS XPOS DX))
-          (replace VECCURY of PRDATA with (IPLUS YPOS DY))
-          (COND
-             [(fetch VECMOVINGRIGHT of PRDATA)       (* We're moving right, and are 
-                                                           really putting out characters.)
-                                                             (* SPRUCEPAPERTOPSCANS is in dover 
-                                                           points)
-              (COND
-                 ((AND (IGEQ YPOS (IPLUS SPRUCEPAPERBOTTOMSCANS HALFVECWIDTH))
-                       (ILESSP YPOS (IDIFFERENCE SPRUCEPAPERTOPSCANS HALFVECWIDTH))
-                       (IGEQ XPOS (IPLUS SPRUCEPAPERLEFTSCANS HALFVECWIDTH))
-                       (ILESSP XPOS (IDIFFERENCE SPRUCEPAPERRIGHTSCANS HALFVECWIDTH)))
-                                                             (* We're on-paper.
-                                                           Go ahead and display this character.)
-                  (COND
-                     ((NOT (fetch VECWASDISPLAYING of PRDATA))
-                                                             (* We haven't been displaying.
-                                                           before really putting out the 
-                                                           character,)
-                      (SHOW.PRESS PRSTREAM)
-                      (SETXY.PRESS PRSTREAM (FIXR (FTIMES MicasPerScan XPOS))
-                             (FIXR (FTIMES MicasPerScan YPOS)))
-                                                             (* So move to where we're emerging 
-                                                           onto the paper.)
-                      (replace VECWASDISPLAYING of PRDATA with T)))
-                  (\BOUT PRSTREAM (\VECENCODE DX DY)))
-                 (T                                          (* We're off-page.
-                                                           Remember to do a SETXY when we get 
-                                                           back on.)
-                    (replace VECWASDISPLAYING of PRDATA with NIL]
-             (T 
-
-         (* We're moving left--and so caching characters for later.
-       Don't bother making any checks going this way.)
-
-                (push (fetch VECSEGCHARS of PRDATA)
-                       (CONS DX DY))                         (* Just cache the DX,DY pair)
-                ])
-
-(\VECSKIP
-  [LAMBDA (PRSTREAM DX DY)                                   (* rmk%: "17-Dec-84 10:10")
-                                                             (* Put out blank space for DX, DY)
-    (\ENDVECRUN PRSTREAM)
-    (SETQ VecCurX (IPLUS VecCurX DX))
-    (SETQ VecCurY (IPLUS VecCurY DY))
-    (\ENDVECRUN PRSTREAM])
-
-(\VECFONTINIT
-  [LAMBDA NIL                                                (* jds " 2-Jan-86 14:24")
-          
-          (* Initialize \VecFontDir, a list of lists of dummy font descriptors for the 
-          ReDraw vector fonts. The structure is ((round brushes)
-          (square brushes) (horizontal brushes) (vertical brushes)))
-
-    (DECLARE (GLOBALVARS \VecFontDir))
-          
-          (* WIDTHS is a dummy array descriptor so that \DSPFONT.PRESS doesn't get 
-          confused. If any real character output were done with this descriptor in force, 
-          the results would be disastrous. But the RESETSAVE in \PRESSCURVE2 should 
-          prevent this.)
-          
-          (* NOTE%: Perhaps we should just use the unit widths vector for this)
-
-    (OR \VecFontDir (SETQ \VecFontDir
-                     (BIND FD CSINFO for FMLY (WIDTHS _ (ARRAY 256 'SMALLP 1 0))
-                        in '(NEWVEC SNEWVEC HNEWVEC VNEWVEC)
-                        collect (for BRUSH in '(4 8 16 32 64)
-                                   collect (SETQ FD (create FONTDESCRIPTOR
-                                                           FONTDEVICE _ 'PRESS
-                                                           FONTFAMILY _ FMLY
-                                                           FONTSIZE _ BRUSH
-                                                           FONTFACE _ '(MEDIUM REGULAR REGULAR)
-                                                           ROTATION _ 0
-                                                           FONTAVGCHARWIDTH _ 1)) 
-                                                             (* Create a dummy font descriptor for 
-                                                             this dummy font)
-                                         (SETQ CSINFO (CREATE CHARSETINFO
-                                                             WIDTHS _ (FETCH (ARRAYP BASE)
-                                                                         OF WIDTHS))) 
-          
-          (* And a CHARSETINFO that claims the characters are all 0 wide)
-
-                                         (\RPLPTR (FETCH (FONTDESCRIPTOR FONTCHARSETVECTOR)
-                                                     OF FD)
-                                                0 CSINFO)    (* And Smash it into the charset 
-                                                             vector.)
-          
-          (* * Now collect the font descriptors for the directory)
-
-                                         FD])
-
-(\DRAWCIRCLE.PRESS
-  [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING)      (* rmk%: "27-Sep-84 17:23")
-    (PROG [(R2RAD (FIXR (FTIMES RADIUS (CONSTANT (FQUOTIENT (SQRT 2)
-                                                        2]
-          (DRAWCURVE (LIST (CREATEPOSITION (IPLUS CENTERX RADIUS)
-                                  CENTERY)
-                           (CREATEPOSITION (IPLUS CENTERX R2RAD)
-                                  (IPLUS CENTERY R2RAD))
-                           (CREATEPOSITION CENTERX (IPLUS CENTERY RADIUS))
-                           (CREATEPOSITION (IDIFFERENCE CENTERX R2RAD)
-                                  (IPLUS CENTERY R2RAD))
-                           (CREATEPOSITION (IDIFFERENCE CENTERX RADIUS)
-                                  CENTERY)
-                           (CREATEPOSITION (IDIFFERENCE CENTERX R2RAD)
-                                  (IDIFFERENCE CENTERY R2RAD))
-                           (CREATEPOSITION CENTERX (IDIFFERENCE CENTERY RADIUS))
-                           (CREATEPOSITION (IPLUS CENTERX R2RAD)
-                                  (IDIFFERENCE CENTERY R2RAD)))
-                 T BRUSH DASHING STREAM))
-    (MOVETO CENTERX CENTERY STREAM])
-
-(\DRAWARC.PRESS
-  [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING)
-                                                             (* rrb " 4-Oct-85 17:27")
-                                                             (* draws an arc on an press file)
-    (\DRAWARC.GENERIC STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING])
-
-(\DRAWCURVE.PRESS
-  [LAMBDA (PRSTREAM KNOTS CLOSED BRUSH DASHING)              (* rmk%: "20-Nov-84 13:59")
-          
-          (* draws a spline curve with a given brush brush.
-          Knots and brushwidth assumed to be in micas)
-
-    [COND
-       ((LISTP KNOTS)
-        (SHOW.PRESS PRSTREAM)
-        (PROG [LASTKNOT (DASHLST (AND DASHING (OR (AND (LISTP DASHING)
-                                                       (EVERY DASHING (FUNCTION FIXP))
-                                                       DASHING)
-                                                  (\ILLEGAL.ARG DASHING]
-          
-          (* The above makes sure that DASHING is a list of numbers.)
-
-              [OR (CDR KNOTS)
-                  (SETQ KNOTS (LIST (CAR KNOTS)
-                                    (CAR KNOTS]              (* Handle the trival one-knot case.)
-              (COND
-                 ((AND (NULL DASHING)
-                       (EQ 2 (LENGTH KNOTS))
-                       (\DRAWCURVE.PRESS.LINE PRSTREAM (fetch XCOORD of (CAR KNOTS))
-                              (fetch YCOORD of (CAR KNOTS))
-                              (fetch XCOORD of (CADR KNOTS))
-                              (fetch YCOORD of (CADR KNOTS))
-                              BRUSH DASHING))
-          
-          (* There were only two knots, and no dashing.
-          \DRAWCURVE.PRESS.LINE returned T if it managed to draw the line the fast way.)
-                                                             (* Have to move to the endpoint of the 
-                                                             line.)
-                  )
-                 (T                                          (* Otherwise, use the full-strength 
-                                                             curve drawer.)
-                    (\PRESSCURVE2 PRSTREAM
-                           (PARAMETRICSPLINE [for KNOT in KNOTS
-                                                collect (CREATEPOSITION (FIXR (FTIMES (fetch XCOORD
-                                                                                         of KNOT)
-                                                                                     ScansPerMica))
-                                                               (FIXR (FTIMES (fetch YCOORD
-                                                                                of KNOT)
-                                                                            ScansPerMica]
-                                  CLOSED)
-                           DASHING
-                           (\GETBRUSHFONT.PRESS BRUSH))
-          
-          (* This already leaves the current position at the endpoint of the curve.)
-
-                    ))
-              (SETQ LASTKNOT (CAR (LAST KNOTS)))
-              (SETXY.PRESS PRSTREAM (fetch XCOORD of LASTKNOT)
-                     (fetch YCOORD of LASTKNOT]
-    PRSTREAM])
-
-(\DRAWCURVE.PRESS.LINE
-  [LAMBDA (PRSTREAM X1 Y1 X2 Y2 BRUSH DASHING)               (* rmk%: "17-Dec-84 10:05")
-          
-          (* Returns T if this is a horizontal or vertical line, hence can be drawn as a 
-          rectangle.)
-
-    (PROG (WIDTH BACKOFF LEFT BOTTOM DIST LB TR (SHAPE 'ROUND))
-          (SETQ WIDTH (OR (COND
-                             ((LISTP BRUSH)
-                              (SETQ SHAPE (CAR BRUSH))
-                              (CADR BRUSH))
-                             (T BRUSH))
-                          1))
-          [SELECTQ SHAPE
-              (BUTT (SETQ BACKOFF 0))
-              (ROUND (RETURN NIL))
-              (PROGN (SETQ BACKOFF (IQUOTIENT WIDTH 2]
-          
-          (* For butt ends, we want the line to end at the given coordinate position)
-          
-          (* LB is left or bottom, TR is top or right, depending on orientation)
-
-          (COND
-             ((EQP X1 X2)                                    (* Vertical line)
-              (SETQ LEFT (IDIFFERENCE X1 (IQUOTIENT WIDTH 2)))
-                                                             (* Off to the left or right?)
-              (AND (OR (ILESSP LEFT SPRUCEPAPERLEFTMICAS)
-                       (IGREATERP (IPLUS LEFT WIDTH)
-                              SPRUCEPAPERRIGHTMICAS))
-                   (RETURN T))
-              (COND
-                 ((IGREATERP Y1 Y2)
-                  (SETQ LB Y2)
-                  (SETQ TR Y1))
-                 (T (SETQ LB Y1)
-                    (SETQ TR Y2)))
-              (SETQ LB (IMAX SPRUCEPAPERBOTTOMMICAS (IDIFFERENCE LB BACKOFF)))
-                                                             (* Clip to page)
-              (SETQ TR (IMIN SPRUCEPAPERTOPMICAS (IPLUS TR BACKOFF)))
-              (SETQ DIST (IDIFFERENCE TR LB))
-              (OR (IGREATERP DIST 0)
-                  (RETURN T))
-              (SETXY.PRESS PRSTREAM LEFT LB)                 (* Move to where the line starts)
-              (SHOWRECTANGLE.PRESS PRSTREAM WIDTH DIST)      (* Draw the rectangle that will do the 
-                                                             job.)
-              (RETURN T))
-             ((EQP Y1 Y2)                                    (* Horizontal line)
-              (SETQ BOTTOM (IDIFFERENCE Y1 (IQUOTIENT WIDTH 2)))
-                                                             (* Off to the bottom or top?)
-              (AND (OR (ILESSP BOTTOM SPRUCEPAPERBOTTOMMICAS)
-                       (IGREATERP (IPLUS BOTTOM WIDTH)
-                              SPRUCEPAPERTOPMICAS))
-                   (RETURN T))
-              (COND
-                 ((IGREATERP X1 X2)
-                  (SETQ LB X2)
-                  (SETQ TR X1))
-                 (T (SETQ LB X1)
-                    (SETQ TR X2)))
-              (SETQ LB (IMAX SPRUCEPAPERLEFTMICAS (IDIFFERENCE LB BACKOFF)))
-                                                             (* Clip to page)
-              (SETQ TR (IMIN SPRUCEPAPERRIGHTMICAS (IPLUS TR BACKOFF)))
-              (SETQ DIST (IDIFFERENCE TR LB))
-              (OR (IGREATERP DIST 0)
-                  (RETURN T))
-              (SETXY.PRESS PRSTREAM LB BOTTOM)               (* Move to where the line starts)
-              (SHOWRECTANGLE.PRESS PRSTREAM DIST WIDTH)      (* Draw the rectangle that will do the 
-                                                             job.)
-              (RETURN T])
-
-(\DRAWELLIPSE.PRESS
-  [LAMBDA (PRSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING)
-                                                             (* rmk%: "23-Aug-84 10:51")
-    (PROG [(SINOR (COND
-                     (ORIENTATION (SIN ORIENTATION))
-                     (T 0.0)))
-           (COSOR (COND
-                     (ORIENTATION (COS ORIENTATION))
-                     (T 1.0]
-          (\DRAWCURVE.PRESS PRSTREAM [LIST (CREATEPOSITION (PLUS CENTERX (FTIMES COSOR 
-                                                                                SEMIMAJORRADIUS))
-                                                  (PLUS CENTERY (FTIMES SINOR SEMIMAJORRADIUS)))
-                                           (CREATEPOSITION (DIFFERENCE CENTERX (FTIMES SINOR 
-                                                                                      SEMIMINORRADIUS
-                                                                                      ))
-                                                  (PLUS CENTERY (FTIMES COSOR SEMIMINORRADIUS)))
-                                           (CREATEPOSITION (DIFFERENCE CENTERX (FTIMES COSOR 
-                                                                                      SEMIMAJORRADIUS
-                                                                                      ))
-                                                  (DIFFERENCE CENTERY (FTIMES SINOR SEMIMAJORRADIUS))
-                                                  )
-                                           (CREATEPOSITION (PLUS CENTERX (FTIMES SINOR 
-                                                                                SEMIMINORRADIUS))
-                                                  (DIFFERENCE CENTERY (FTIMES COSOR SEMIMINORRADIUS]
-                 T BRUSH DASHING)
-          (MOVETO CENTERX CENTERY PRSTREAM])
-
-(\GETBRUSHFONT.PRESS
-  [LAMBDA (BRUSH)                                            (* rmk%: "17-Dec-84 10:13")
-    (\VECFONTINIT)
-    (PROG [(LIST1 (SELECTQ (CAR (LISTP BRUSH))
-                      (ROUND (CAR \VecFontDir))
-                      (SQUARE (CADR \VecFontDir))
-                      (HORIZONTAL (CADDR \VecFontDir))
-                      (VERTICAL (CADDDR \VecFontDir))
-                      (BUTT (CAR \VecFontDir))
-                      (CAR \VecFontDir]
-          (AND (LISTP BRUSH)
-               (SETQ BRUSH (CADR BRUSH)))
-          (RETURN (SELECTQ (FIXR (FTIMES (OR BRUSH 1)
-                                        PointsPerMica))
-                      ((0 1) 
-                           (CAR LIST1))
-                      (2 (CADR LIST1))
-                      ((3 4 5) 
-                           (CADDR LIST1))
-                      ((6 7 8) 
-                           (CADDDR LIST1))
-                      (CADDDR LIST1])
-
-(\PRESSCURVE2
-  [LAMBDA (PRSTREAM SPLINE DASHING BRUSHFONT)           (* ; "Edited 12-Jun-90 10:40 by mitani")
-                                                             (* Given a spline curve and a font, 
-                                                           draw the lines to PRSTREAM)
-    (RESETLST
-        (RESETSAVE NIL (LIST 'DSPFONT (DSPFONT BRUSHFONT PRSTREAM)
-                             PRSTREAM))
-        [PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)))
-              (COND
-                 ((IGREATERP (IDIFFERENCE (GETFILEPTR (fetch ELSTREAM of PRDATA))
-                                    (fetch ELSTARTBYTE of PRDATA))
-                         25000)
-                  (\ENTITYEND.PRESS PRSTREAM)            (* Hack to prevent mysterious 
-                                                           overflow in length of entities)
-                  (\ENTITYSTART.PRESS PRSTREAM]
-        (\BOUT (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM))
-               ResetSpaceCode)
-
-         (* because the space code shouldn't be interpreted specially when we are 
-       drawing in the vector font)
-
-        (PROG ((XPOLY (create POLYNOMIAL))
-               (X'POLY (create POLYNOMIAL))
-               (YPOLY (create POLYNOMIAL))
-               (Y'POLY (create POLYNOMIAL))
-               (X (fetch (SPLINE SPLINEX) of SPLINE))
-               (Y (fetch (SPLINE SPLINEY) of SPLINE))
-               (X' (fetch (SPLINE SPLINEDX) of SPLINE))
-               (Y' (fetch (SPLINE SPLINEDY) of SPLINE))
-               (X'' (fetch (SPLINE SPLINEDDX) of SPLINE))
-               (Y'' (fetch (SPLINE SPLINEDDY) of SPLINE))
-               (X''' (fetch (SPLINE SPLINEDDDX) of SPLINE))
-               (Y''' (fetch (SPLINE SPLINEDDDY) of SPLINE))
-               (%#KNOTS (fetch %#KNOTS of SPLINE))
-               (X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
-                        1))
-               (Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
-                        1))
-               IX IY DX DY XT YT X'T Y'T NEWXT NEWYT XDIFF YDIFF XWALLDT YWALLDT DUPLICATEKNOT 
-               EXTRANEOUS TT NEWT DELTA DASHON DASHLST DASHCNT HALFVECWIDTH PUTDX EXTRADX PUTDY 
-               EXTRADY)
-              (SETQ HALFVECWIDTH (FONTPROP BRUSHFONT 'SIZE))
-
-         (* Half the width of the brush, in dots.
-       Used to help decide when the line we're drawing goes off-paper.)
-
-              (SETQ DASHON T)
-
-         (* These are initialized outside the prog-bindings cause the compiler can't 
-       hack so many initialized variables)
-
-              (SETQ DASHLST DASHING)
-              (SETQ DASHCNT (CAR DASHING))
-              (SETXY.PRESS PRSTREAM (FIXR (FTIMES X0 MicasPerScan))
-                     (FIXR (FTIMES Y0 MicasPerScan)))        (* Move to the first knot on the 
-                                                           curve)
-              (replace VECMOVINGRIGHT of (fetch (STREAM IMAGEDATA) of PRSTREAM)
-                 with T)                                 (* Start by assuming we're moving in 
-                                                           increasing X (since the vector fonts 
-                                                           only have strokes that work in that 
-                                                           direction))
-              (replace VECWASDISPLAYING of (fetch (STREAM IMAGEDATA) of PRSTREAM)
-                 with (AND (GEQ X0 0)
-                               (GEQ Y0 0)))
-              (replace VECSEGCHARS of (fetch (STREAM IMAGEDATA) of PRSTREAM)
-                 with NIL)
-              (replace VECCURX of (fetch (STREAM IMAGEDATA) of PRSTREAM) with
-                                                                                         X0)
-                                                             (* And set the current X and Y 
-                                                           positions, denominated in dover 
-                                                           spots)
-              (replace VECCURY of (fetch (STREAM IMAGEDATA) of PRSTREAM) with
-                                                                                         Y0)
-                                                             (* Set up initial values in vec 
-                                                           variables, perform SetX/SetY.)
-              (SETQ TT 0.0)
-              (SETQ DELTA 16)
-              (SETQ IX (FIXR X0))
-              (SETQ IY (FIXR Y0))
-              [for KNOT# from 1 to (SUB1 %#KNOTS)
-                 do (LOADPOLY XPOLY X'POLY (ELT X''' KNOT#)
-                               (ELT X'' KNOT#)
-                               (ELT X' KNOT#)
-                               (ELT X KNOT#))                (* Set up the polynomials that 
-                                                           describe X and X' over this segment)
-                       (LOADPOLY YPOLY Y'POLY (ELT Y''' KNOT#)
-                              (ELT Y'' KNOT#)
-                              (ELT Y' KNOT#)
-                              (ELT Y KNOT#))                 (* Set up the polynomials that 
-                                                           describe Y and Y' over this segment)
-                       (SETQ XT (POLYEVAL TT XPOLY 3))       (* XT _ X (t) --Evaluate the next 
-                                                           point)
-                       (SETQ YT (POLYEVAL TT YPOLY 3))       (* YT _ Y (t))
-                       (COND
-                          [(NOT (IEQP KNOT# (SUB1 %#KNOTS)))
-
-         (* This isn't the last knot. Check to see if the next knot in line is a 
-       duplicated knot.)
-
-                           (SETQ DUPLICATEKNOT (AND (EQP (ELT X (ADD1 KNOT#))
-                                                         (ELT X (IPLUS KNOT# 2)))
-                                                    (EQP (ELT Y (ADD1 KNOT#))
-                                                         (ELT Y (IPLUS KNOT# 2]
-                          (T (SETQ DUPLICATEKNOT NIL)))
-                       [until (GEQ TT 1.0)
-                          do 
-
-         (* Run the parameter, TT, from 0.0 up to |1.0.|
-       That moves the X and Y locations smoothly from this knot to the next one.)
-
-                                (SETQ X'T (POLYEVAL TT X'POLY 2)) 
-                                                             (* X'T _ X' (t))
-                                (SETQ Y'T (POLYEVAL TT Y'POLY 2)) 
-                                                             (* Y'T _ Y' (t))
-                                (COND
-                                   ((EQP X'T 0.0)            (* Never let X' really get to 0.0 --
-                                                           things become ill-conditioned there.)
-                                    (SETQ X'T 5.0E-4)))
-                                (COND
-                                   ((EQP Y'T 0.0)            (* Likewise Y'.)
-                                    (SETQ Y'T 5.0E-4)))
-                                [COND
-                                   ((FGTP X'T 0.0)           (* If X' is positive, we'll try 
-                                                           moving in the +X direction)
-                                    (SETQ DX DELTA))
-                                   (T                        (* If not, we'll try the -X 
-                                                           direction.)
-                                      (SETQ DX (IMINUS DELTA]
-                                [COND
-                                   ((FGTP Y'T 0.0)           (* Likewise, if Y' is positive, try 
-                                                           moving by DELTA in the +Y direction)
-                                    (SETQ DY DELTA))
-                                   (T (SETQ DY (IMINUS DELTA]
-                                (SETQ XWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IX DX)
-                                                                XT)
-                                                     X'T))   (* Compute a dT, based on moving by 
-                                                           DELTA in X.)
-                                (SETQ YWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IY DY)
-                                                                YT)
-                                                     Y'T))   (* And a dT based on moving by DELTA 
-                                                           in Y.)
-                                [COND
-                                   ((FLESSP XWALLDT YWALLDT)
-
-         (* Use the smaller of the two dT's. In this case, dT for X was smaller, so 
-       compute a new DY as depending on DX.)
-
-                                    (SETQ NEWT (FPLUS TT XWALLDT))
-                                    (SETQ DY (IDIFFERENCE (FIXR (FPLUS YT (FTIMES XWALLDT Y'T)))
-                                                    IY)))
-                                   (T 
-
-         (* Changing Y gave the smaller dT. Compute a new DX, as though it depended on 
-       DY.)
-
-                                      (SETQ NEWT (FPLUS TT YWALLDT))
-                                      (SETQ DX (IDIFFERENCE (FIXR (FPLUS XT (FTIMES YWALLDT X'T)))
-                                                      IX]
-                                (SETQ PUTDX DX)
-                                (SETQ EXTRADX 0)
-                                (SETQ PUTDY DY)
-                                (SETQ EXTRADY 0)
-                                [COND
-                                   ((IGREATERP DX 16)
-                                    (SETQ PUTDX 16)
-                                    (SETQ EXTRADX (IDIFFERENCE DX 16]
-                                [COND
-                                   ((IGREATERP -16 DX)
-                                    (SETQ PUTDX -16)
-                                    (SETQ EXTRADX (IPLUS DX 16]
-                                [COND
-                                   ((IGREATERP DY 16)
-                                    (SETQ PUTDY 16)
-                                    (SETQ EXTRADY (IDIFFERENCE DY 16]
-                                [COND
-                                   ((IGREATERP -16 DY)
-                                    (SETQ PUTDY -16)
-                                    (SETQ EXTRADY (IPLUS DY 16]
-                                (COND
-                                   ([AND (FGTP NEWT 1.0)
-                                         (OR DUPLICATEKNOT (EQ KNOT# (SUB1 %#KNOTS]
-                                    (SETQ NEWT 1.0)))
-                                (SETQ NEWXT (POLYEVAL NEWT XPOLY 3)) 
-                                                             (* New XT _ X (new t))
-                                (SETQ NEWYT (POLYEVAL NEWT YPOLY 3)) 
-                                                             (* New YT _ Y (new t))
-                                (SETQ XDIFF (ABS (FDIFFERENCE (IPLUS IX DX)
-                                                        NEWXT)))
-                                (SETQ YDIFF (ABS (FDIFFERENCE (IPLUS IY DY)
-                                                        NEWYT)))
-                                (COND
-                                   ((AND (IGREATERP DELTA 1)
-                                         (OR (FGTP XDIFF 1.0)
-                                             (FGTP YDIFF 1.0)))
-
-         (* If we're more than a dover spot off where we'd expect to be because of the 
-       size of DELTA--and if there's room to make DELTA smaller--then try 
-       DELTA_DELTA/2)
-
-                                    (SETQ DELTA (LRSH DELTA 1)))
-                                   (T 
-
-         (* No, this estimate is close enough. Put out a vector segment based on it, and 
-       move to the new TT.)
-
-                                      (\VECPUT PRSTREAM PUTDX PUTDY HALFVECWIDTH)
-                                                             (* Print out a stroke using the 
-                                                           vector font.)
-                                      (COND
-                                         ((OR (NEQ EXTRADX 0)
-                                              (NEQ EXTRADY 0))
-                                                             (* If, actually, it was too big for 
-                                                           one stroke, use another.)
-                                          (\VECPUT PRSTREAM EXTRADX EXTRADY HALFVECWIDTH)))
-                                      (SETQ IX (IPLUS IX DX))(* Our new current location, in 
-                                                           Dover spots)
-                                      (SETQ IY (IPLUS IY DY))
-                                      (SETQ TT NEWT)         (* Set TT to its new value)
-                                      (SETQ XT NEWXT)        (* And set the new floating-point 
-                                                           values for X (t) and Y
-                                                           (t)%.)
-                                      (SETQ YT NEWYT)
-                                      (COND
-                                         ((AND (ILESSP DELTA 16)
-                                               (OR (FLESSP XDIFF 0.5)
-                                                   (FLESSP YDIFF 0.5)))
-                                                             (* If we were especially close, try 
-                                                           making DELTA larger for the next go 
-                                                           round.)
-                                          (SETQ DELTA (LLSH DELTA 1]
-                       (SETQ TT (FDIFFERENCE TT 1.0)) 
-
-         (* Having moved past a knot, back the value of the parameter TT back down.
-       However, don't set it to 0.0--let's try to keep the line going from where it 
-       got to in passing the last knot.)
-
-                       (COND
-                          (DUPLICATEKNOT 
-
-         (* This next knot is a duplicate. Skip over it, and start from the following 
-       knot. This will avoid odd problems trying to go nowhere while obeying the 
-       constraints of X' and Y' at that knot--since it's a duplicate, X' and Y' are 
-       discontinuous there.)
-
-                                 (add KNOT# 1]
-              (\ENDVECRUN PRSTREAM HALFVECWIDTH)))])
-)
-
-(RPAQ? \VecFontDir )
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \MicasPerInch 2540)
-
-
-(CONSTANTS (\MicasPerInch 2540))
-)
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ ScansPerIn 384)
-
-(RPAQQ PointsPerIn 72.27)
-
-(RPAQ MicasPerScan (FQUOTIENT \MicasPerInch ScansPerIn))
-
-(RPAQ ScansPerMica (FQUOTIENT ScansPerIn \MicasPerInch))
-
-(RPAQ ScansPerPoint (FQUOTIENT ScansPerIn PointsPerIn))
-
-(RPAQ PointsPerScan (FQUOTIENT PointsPerIn ScansPerIn))
-
-(RPAQ MicasPerPoint (FQUOTIENT \MicasPerInch PointsPerIn))
-
-(RPAQ PointsPerMica (FQUOTIENT PointsPerIn \MicasPerInch))
-
-(RPAQQ SPRUCEPAPERTOPSCANS 4096)
-
-(RPAQ SPRUCEPAPERTOPMICAS (FIX (FQUOTIENT (FTIMES SPRUCEPAPERTOPSCANS \MicasPerInch)
-                                      ScansPerIn)))
-
-(RPAQ SPRUCEPAPERRIGHTMICAS (FIX (FTIMES 8.5 \MicasPerInch)))
-
-(RPAQ SPRUCEPAPERRIGHTSCANS (FIX (FTIMES 8.5 ScansPerIn)))
-
-(RPAQQ SPRUCEPAPERBOTTOMSCANS 0)
-
-(RPAQQ SPRUCEPAPERBOTTOMMICAS 0)
-
-(RPAQQ SPRUCEPAPERLEFTSCANS 0)
-
-(RPAQQ SPRUCEPAPERLEFTMICAS 0)
-
-
-(CONSTANTS (ScansPerIn 384)
-       (PointsPerIn 72.27)
-       (MicasPerScan (FQUOTIENT \MicasPerInch ScansPerIn))
-       (ScansPerMica (FQUOTIENT ScansPerIn \MicasPerInch))
-       (ScansPerPoint (FQUOTIENT ScansPerIn PointsPerIn))
-       (PointsPerScan (FQUOTIENT PointsPerIn ScansPerIn))
-       (MicasPerPoint (FQUOTIENT \MicasPerInch PointsPerIn))
-       (PointsPerMica (FQUOTIENT PointsPerIn \MicasPerInch))
-       (SPRUCEPAPERTOPSCANS 4096)
-       (SPRUCEPAPERTOPMICAS (FIX (FQUOTIENT (FTIMES SPRUCEPAPERTOPSCANS \MicasPerInch)
-                                        ScansPerIn)))
-       (SPRUCEPAPERRIGHTMICAS (FIX (FTIMES 8.5 \MicasPerInch)))
-       (SPRUCEPAPERRIGHTSCANS (FIX (FTIMES 8.5 ScansPerIn)))
-       (SPRUCEPAPERBOTTOMSCANS 0)
-       (SPRUCEPAPERBOTTOMMICAS 0)
-       (SPRUCEPAPERLEFTSCANS 0)
-       (SPRUCEPAPERLEFTMICAS 0))
-)
-)
-
-
-
-(* ;; "Initialization code")
-
-(DEFINEQ
-
-(\PRESSINIT
-  [LAMBDA NIL                                                (* rrb " 4-Oct-85 17:27")
-    (DECLARE (GLOBALVARS \PRESSIMAGEOPS))
-    (SETQ \PRESSIMAGEOPS (create IMAGEOPS
-                                IMAGETYPE _ 'PRESS
-                                IMCLOSEFN _ (FUNCTION \CLOSEF.PRESS)
-                                IMXPOSITION _ (FUNCTION \DSPXPOSITION.PRESS)
-                                IMYPOSITION _ (FUNCTION \DSPYPOSITION.PRESS)
-                                IMFONT _ (FUNCTION \DSPFONT.PRESS)
-                                IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.PRESS)
-                                IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.PRESS)
-                                IMLINEFEED _ (FUNCTION \DSPLINEFEED.PRESS)
-                                IMDRAWLINE _ (FUNCTION \DRAWLINE.PRESS)
-                                IMDRAWCURVE _ (FUNCTION \DRAWCURVE.PRESS)
-                                IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.PRESS)
-                                IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.PRESS)
-                                IMFILLCIRCLE _ [FUNCTION (LAMBDA (STREAM)
-                                                           (\UNIMPIMAGEOP STREAM 'FILLCIRCLE]
-                                IMBLTSHADE _ (FUNCTION \BLTSHADE.PRESS)
-                                IMBITBLT _ (FUNCTION \BITBLT.PRESS)
-                                IMSCALE _ [FUNCTION (LAMBDA NIL
-                                                      (CONSTANT (FQUOTIENT MICASPERINCH 72]
-                                IMTERPRI _ (FUNCTION NEWLINE.PRESS)
-                                IMBOTTOMMARGIN _ (FUNCTION \DSPBOTTOMMARGIN.PRESS)
-                                IMTOPMARGIN _ (FUNCTION \DSPTOPMARGIN.PRESS)
-                                IMFONTCREATE _ 'PRESS
-                                IMNEWPAGE _ (FUNCTION NEWPAGE.PRESS)
-                                IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.PRESS)
-                                IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.PRESS)
-                                IMCHARWIDTH _ (FUNCTION \CHARWIDTH.PRESS)
-                                IMBITMAPSIZE _ (FUNCTION \BITMAPSIZE.PRESS)
-                                IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.PRESS)
-                                IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.PRESS)
-                                IMDRAWARC _ (FUNCTION \DRAWARC.PRESS])
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(\PRESSINIT)
-)
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE PRESSDATA (PRHEADING                               (* ; 
-                                                           "The string to be printed atop each page.")
-                           PRHEADINGFONT                     (* ; "Font to print the heading in")
-                           PRXPOS                            (* ; "Current X position")
-                           PRYPOS                            (* ; "Current Y position")
-                           PRFONT                            (* ; "Current font")
-                           PRCURRFDE PRESSFONTDIR (PRWIDTHSCACHE POINTER 
-                                                             (* ; 
-                                                 "Widths table for the current logical character set")
-                                                         )
-                           PRCOLOR PRLINEFEED PRPAGESTATE PDSTREAM ELSTREAM XPRPAGEREGION PRDOCNAME
-                           (PRLEFT WORD)                     (* ; "Page left margin")
-                           (PRBOTTOM WORD)                   (* ; "Page bottom margin")
-                           (PRRIGHT WORD)                    (* ; "Page right margin")
-                           (PRTOP WORD)                      (* ; "Page top margin")
-                           (PRPAGENUM WORD)                  (* ; "Current Page number")
-                           (PRNEXTFONT# BYTE)
-                           (PRMAXFONTSET BYTE)
-                           (PRPARTSTART INTEGER)
-                           (DLSTARTBYTE INTEGER)
-                           (ELSTARTBYTE INTEGER)
-                           (STARTCHARBYTE INTEGER)
-                           (VECMOVINGRIGHT FLAG)             (* ; 
-                            "If we're drawing a curve with vector fonts, are we moving to the right?")
-                           (VECWASDISPLAYING FLAG)
-
-                           (* ;; "Used during curve/line clipping to remember whether we were on-screen or not, so we know when to force a SETXY.")
-
-                           VECSEGCHARS                       (* ; 
-                                        "Cache for vector characters while we're moving to the left.")
-                           VECCURX                           (* ; 
-                                              "Current X position within vector code, in Dover spots")
-                           VECCURY                           (* ; 
-                                                "Current Y position with vector code, in Dover spots")
-                           PRSPACEFACTOR PRSPACEWIDTH (CHARWASDISPLAYING FLAG)
-                                                             (* ; 
-                           "Says whether we have been printing characters inside the clipping region")
-                           PRClippingRegion
-
-                           (* ;; "The edges of the paper, as far as PRESS is concerned.  Used to protect SPRUCE users who get killed when the image goes off-paper")
-
-                           PRLOGICALFONT                     (* ; "Current logical font")
-                           PRLOGICALCHARSET                  (* ; 
-                      "Current logical character set, whose info is cached.  NIL if cache is invalid")
-                           (PRTRANSLATIONCACHE POINTER       (* ; 
-                                            "Translation table for the current logical character set")
-                                  ))
-                    PRSPACEFACTOR _ 1 PRXPOS _ 0 PRYPOS _ 0  (* ; 
-                      "We assume that the origin is translated to the bottom-left of the page region")
-                    PRClippingRegion _ (create REGION
-                                              LEFT _ SPRUCEPAPERLEFTMICAS
-                                              BOTTOM _ SPRUCEPAPERBOTTOMMICAS
-                                              WIDTH _ (DIFFERENCE SPRUCEPAPERRIGHTMICAS 
-                                                             SPRUCEPAPERLEFTMICAS)
-                                              HEIGHT _ 29210)
-                    [ACCESSFNS ((PRWIDTH (IDIFFERENCE (fetch (PRESSDATA PRRIGHT) of DATUM)
-                                                (fetch (PRESSDATA PRLEFT) of DATUM)))
-                                (PRHEIGHT (IDIFFERENCE (fetch (PRESSDATA PRTOP) of DATUM)
-                                                 (fetch (PRESSDATA PRBOTTOM) of DATUM)))
-                                (PRPAGEREGION (fetch (PRESSDATA XPRPAGEREGION) of DATUM)
-                                       (PROGN (replace (PRESSDATA XPRPAGEREGION) of DATUM
-                                                 with NEWVALUE)
-                                              (replace (PRESSDATA PRLEFT) of DATUM
-                                                 with (fetch (REGION LEFT) of NEWVALUE))
-                                              (replace (PRESSDATA PRBOTTOM) of DATUM
-                                                 with (fetch (REGION BOTTOM) of NEWVALUE))
-                                              (replace (PRESSDATA PRRIGHT) of DATUM
-                                                 with (IPLUS (fetch (REGION LEFT) of NEWVALUE)
-                                                             (fetch (REGION WIDTH) of NEWVALUE)))
-                                              (replace (PRESSDATA PRTOP) of DATUM
-                                                 with (IPLUS (fetch (REGION BOTTOM) of NEWVALUE)
-                                                             (fetch (REGION HEIGHT) of NEWVALUE])
-
-(RECORD FONTDIRENTRY (DESCR FONT# FONTSET#))
-)
-
-(/DECLAREDATATYPE 'PRESSDATA
-       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-               POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP
-               FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER
-               )
-       '((PRESSDATA 0 POINTER)
-         (PRESSDATA 2 POINTER)
-         (PRESSDATA 4 POINTER)
-         (PRESSDATA 6 POINTER)
-         (PRESSDATA 8 POINTER)
-         (PRESSDATA 10 POINTER)
-         (PRESSDATA 12 POINTER)
-         (PRESSDATA 14 POINTER)
-         (PRESSDATA 16 POINTER)
-         (PRESSDATA 18 POINTER)
-         (PRESSDATA 20 POINTER)
-         (PRESSDATA 22 POINTER)
-         (PRESSDATA 24 POINTER)
-         (PRESSDATA 26 POINTER)
-         (PRESSDATA 28 POINTER)
-         (PRESSDATA 30 (BITS . 15))
-         (PRESSDATA 31 (BITS . 15))
-         (PRESSDATA 32 (BITS . 15))
-         (PRESSDATA 33 (BITS . 15))
-         (PRESSDATA 34 (BITS . 15))
-         (PRESSDATA 35 (BITS . 7))
-         (PRESSDATA 35 (BITS . 135))
-         (PRESSDATA 36 FIXP)
-         (PRESSDATA 38 FIXP)
-         (PRESSDATA 40 FIXP)
-         (PRESSDATA 42 FIXP)
-         (PRESSDATA 28 (FLAGBITS . 0))
-         (PRESSDATA 28 (FLAGBITS . 16))
-         (PRESSDATA 44 POINTER)
-         (PRESSDATA 46 POINTER)
-         (PRESSDATA 48 POINTER)
-         (PRESSDATA 50 POINTER)
-         (PRESSDATA 52 POINTER)
-         (PRESSDATA 52 (FLAGBITS . 0))
-         (PRESSDATA 54 POINTER)
-         (PRESSDATA 56 POINTER)
-         (PRESSDATA 58 POINTER)
-         (PRESSDATA 60 POINTER))
-       '62)
-)
-
-(/DECLAREDATATYPE 'PRESSDATA
-       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-               POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP
-               FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER
-               )
-       '((PRESSDATA 0 POINTER)
-         (PRESSDATA 2 POINTER)
-         (PRESSDATA 4 POINTER)
-         (PRESSDATA 6 POINTER)
-         (PRESSDATA 8 POINTER)
-         (PRESSDATA 10 POINTER)
-         (PRESSDATA 12 POINTER)
-         (PRESSDATA 14 POINTER)
-         (PRESSDATA 16 POINTER)
-         (PRESSDATA 18 POINTER)
-         (PRESSDATA 20 POINTER)
-         (PRESSDATA 22 POINTER)
-         (PRESSDATA 24 POINTER)
-         (PRESSDATA 26 POINTER)
-         (PRESSDATA 28 POINTER)
-         (PRESSDATA 30 (BITS . 15))
-         (PRESSDATA 31 (BITS . 15))
-         (PRESSDATA 32 (BITS . 15))
-         (PRESSDATA 33 (BITS . 15))
-         (PRESSDATA 34 (BITS . 15))
-         (PRESSDATA 35 (BITS . 7))
-         (PRESSDATA 35 (BITS . 135))
-         (PRESSDATA 36 FIXP)
-         (PRESSDATA 38 FIXP)
-         (PRESSDATA 40 FIXP)
-         (PRESSDATA 42 FIXP)
-         (PRESSDATA 28 (FLAGBITS . 0))
-         (PRESSDATA 28 (FLAGBITS . 16))
-         (PRESSDATA 44 POINTER)
-         (PRESSDATA 46 POINTER)
-         (PRESSDATA 48 POINTER)
-         (PRESSDATA 50 POINTER)
-         (PRESSDATA 52 POINTER)
-         (PRESSDATA 52 (FLAGBITS . 0))
-         (PRESSDATA 54 POINTER)
-         (PRESSDATA 56 POINTER)
-         (PRESSDATA 58 POINTER)
-         (PRESSDATA 60 POINTER))
-       '62)
-
-(RPAQ? DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 24765))
-
-(RPAQ? PRESSBITMAPREGION (CREATEREGION 1270 1270 (FIX (TIMES 7.5 \MicasPerInch))
-                                (TIMES 10 \MicasPerInch)))
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS DEFAULTPAGEREGION)
-)
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ BYTESPERRECORD 512)
-
-(RPAQQ LISPENTITYTYPE 6)
-
-(RPAQ MICASPERINCH \MicasPerInch)
-
-
-(CONSTANTS (BYTESPERRECORD 512)
-       (LISPENTITYTYPE 6)
-       (MICASPERINCH \MicasPerInch))
-)
-
-
-
-(RPAQQ PRESSOPS
-       (SetX SetY ShowCharacters ShowCharactersShortCode SkipCharactersShortCode 
-             ShowCharactersAndSkipCode SetSpaceXShortCode SetSpaceYShortCode FontCode 
-             SkipControlBytesImmediateCode AlternativeCode OnlyOnCopyCode SetXCode SetYCode 
-             ShowCharactersCode SkipCharactersCode SkipControlBytesCode ShowCharacterImmediateCode 
-             SetSpaceXCode SetSpaceYCode ResetSpaceCode SpaceCode SetBrightnessCode SetHueCode 
-             SetSaturationCode ShowObjectCode ShowDotsCode ShowDotsOpaqueCode ShowRectangleCode 
-             NopCode))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ SetX 0)
-
-(RPAQQ SetY 1)
-
-(RPAQQ ShowCharacters 2)
-
-(RPAQQ ShowCharactersShortCode 0)
-
-(RPAQQ SkipCharactersShortCode 40Q)
-
-(RPAQQ ShowCharactersAndSkipCode 100Q)
-
-(RPAQQ SetSpaceXShortCode 140Q)
-
-(RPAQQ SetSpaceYShortCode 150Q)
-
-(RPAQQ FontCode 160Q)
-
-(RPAQQ SkipControlBytesImmediateCode 353Q)
-
-(RPAQQ AlternativeCode 354Q)
-
-(RPAQQ OnlyOnCopyCode 355Q)
-
-(RPAQQ SetXCode 356Q)
-
-(RPAQQ SetYCode 357Q)
-
-(RPAQQ ShowCharactersCode 360Q)
-
-(RPAQQ SkipCharactersCode 361Q)
-
-(RPAQQ SkipControlBytesCode 362Q)
-
-(RPAQQ ShowCharacterImmediateCode 363Q)
-
-(RPAQQ SetSpaceXCode 364Q)
-
-(RPAQQ SetSpaceYCode 365Q)
-
-(RPAQQ ResetSpaceCode 366Q)
-
-(RPAQQ SpaceCode 367Q)
-
-(RPAQQ SetBrightnessCode 370Q)
-
-(RPAQQ SetHueCode 371Q)
-
-(RPAQQ SetSaturationCode 372Q)
-
-(RPAQQ ShowObjectCode 373Q)
-
-(RPAQQ ShowDotsCode 374Q)
-
-(RPAQQ ShowDotsOpaqueCode 375Q)
-
-(RPAQQ ShowRectangleCode 376Q)
-
-(RPAQQ NopCode 377Q)
-
-
-(CONSTANTS SetX SetY ShowCharacters ShowCharactersShortCode SkipCharactersShortCode 
-       ShowCharactersAndSkipCode SetSpaceXShortCode SetSpaceYShortCode FontCode 
-       SkipControlBytesImmediateCode AlternativeCode OnlyOnCopyCode SetXCode SetYCode 
-       ShowCharactersCode SkipCharactersCode SkipControlBytesCode ShowCharacterImmediateCode 
-       SetSpaceXCode SetSpaceYCode ResetSpaceCode SpaceCode SetBrightnessCode SetHueCode 
-       SetSaturationCode ShowObjectCode ShowDotsCode ShowDotsOpaqueCode ShowRectangleCode NopCode)
-)
-)
-
-
-
-(* ;; "Hardcopy user interface connections:")
-
-(DEFINEQ
-
-(MAKEPRESS
-  [LAMBDA (FILE PFILE FONTS HEADING TABS PRINTOPTIONS)       (* ; "Edited 26-Aug-87 13:57 by Snow")
-
-    (TEXTTOIMAGEFILE FILE PFILE 'PRESS FONTS HEADING TABS PRINTOPTIONS])
-
-(PRESSFILEP
-  [LAMBDA (FILE)                                             (* ; "Edited 20-Feb-87 18:41 by jds")
-          
-          (* ;; "Returns FILE if it looks like a Press file")
-
-    (AND (SETQ FILE (OR (STREAMP FILE)
-                        (FINDFILE FILE)))
-         (PROG [(LEN (GETFILEINFO FILE 'LENGTH]
-               (AND (NOT (ZEROP LEN))
-                    (EVENP LEN BYTESPERRECORD)
-                    (RESETLST [COND
-                                 (T (RESETSAVE (SETQ PRESS-STREAM (OPENSTREAM FILE 'INPUT
-                                                                         'OLD 10Q))
-                                           '(PROGN (CLOSEF? OLDVALUE]
-                           (SETFILEPTR PRESS-STREAM (IDIFFERENCE LEN BYTESPERRECORD))
-                           (IEQP 65057Q (\WIN PRESS-STREAM)))
-                    (RETURN FILE])
-
-(PRESS.BITMAPSCALE
-  [LAMBDA (WIDTH HEIGHT)                                (* ; "Edited 12-Jun-90 10:38 by mitani")
-    (MIN (FQUOTIENT (TIMES (fetch (REGION HEIGHT) of PRESSBITMAPREGION)
-                           PointsPerMica)
-                HEIGHT)
-         (FQUOTIENT (TIMES (fetch (REGION WIDTH) of PRESSBITMAPREGION)
-                           PointsPerMica)
-                WIDTH)
-         (PROG1 2                                            (* MAXPRESSRATIO)])
-)
-
-(ADDTOVAR IMAGESTREAMTYPES (PRESS (OPENSTREAM OPENPRSTREAM)
-                                  (FONTCREATE \CREATEPRESSFONT)
-                                  (CREATECHARSET \CREATECHARSET.PRESS)
-                                  (FONTSAVAILABLE \SEARCHPRESSFONTS)))
-
-(ADDTOVAR PRINTERTYPES
-          ((PRESS SPRUCE PENGUIN DOVER)
-           (CANPRINT (PRESS))
-           (STATUS PUP.PRINTER.STATUS)
-           (PROPERTIES PUP.PRINTER.PROPERTIES)
-           (SEND EFTP)
-           (BITMAPSCALE NIL)
-           (BITMAPFILE (PRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))
-          ((FULLPRESS RAVEN)
-                                                             (* ; 
-                                                             "same as PRESS but can scale bitmaps")
-           (CANPRINT (PRESS))
-           (STATUS TRUE)
-           (PROPERTIES NILL)
-           (SEND EFTP)
-           (BITMAPSCALE PRESS.BITMAPSCALE)
-           (BITMAPFILE (FULLPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE))))
-
-(ADDTOVAR PRINTFILETYPES
-          [PRESS (TEST PRESSFILEP)
-                 (EXTENSION (PRESS))
-                 (CONVERSION (TEXT MAKEPRESS TEDIT (LAMBDA (FILE PFILE FONTS HEADING)
-                                                          (SETQ FILE (OPENTEXTSTREAM FILE))
-                                                          (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL
-                                                                 NIL 'PRESS)
-                                                          (CLOSEF? FILE)
-                                                          PFILE])
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (15566Q 72545Q (\SEARCHPRESSFONTS 15600Q . 17535Q) (\GETPRESSFONTNAMES 17537Q . 26375Q) 
-(\PRESSFAMILYCODELST 26377Q . 30321Q) (\DECODEPRESSFACEBYTE 30323Q . 33112Q) (\CREATEPRESSFONT 33114Q
- . 35361Q) (\CREATECHARSET.PRESS 35363Q . 72543Q)) (73202Q 127005Q (PRESSBITMAP 73214Q . 102616Q) (
-FULLPRESSBITMAP 102620Q . 110632Q) (SHOWREGION 110634Q . 112176Q) (SHOWPRESSBITMAPREGION 112200Q . 
-112642Q) (PRESSWINDOW 112644Q . 117003Q) (\WRITEPRESSBITMAP 117005Q . 127003Q)) (127103Q 156756Q (
-\BCPLSOUT.PRESS 127115Q . 130072Q) (\PAGEPAD.PRESS 130074Q . 131331Q) (\ENTITYEND.PRESS 131333Q . 
-136627Q) (\PARTEND.PRESS 136631Q . 141216Q) (\ENTITYSTART.PRESS 141220Q . 144631Q) (SETX.PRESS 144633Q
- . 146466Q) (SETXY.PRESS 146470Q . 151472Q) (SETY.PRESS 151474Q . 153074Q) (SHOW.PRESS 153076Q . 
-156754Q)) (157040Q 273644Q (OPENPRSTREAM 157052Q . 164201Q) (\BITBLT.PRESS 164203Q . 166615Q) (
-\BLTSHADE.PRESS 166617Q . 170252Q) (\SCALEDBITBLT.PRESS 170254Q . 172700Q) (\BITMAPSIZE.PRESS 172702Q
- . 173642Q) (\CHARWIDTH.PRESS 173644Q . 175713Q) (\CLOSEF.PRESS 175715Q . 205704Q) (\DRAWLINE.PRESS 
-205706Q . 207244Q) (\ENDPAGE.PRESS 207246Q . 210516Q) (NEWLINE.PRESS 210520Q . 212131Q) (NEWPAGE.PRESS
- 212133Q . 212425Q) (SETUPFONTS.PRESS 212427Q . 216160Q) (\DEFINEFONT.PRESS 216162Q . 220304Q) (
-\DSPBOTTOMMARGIN.PRESS 220306Q . 221102Q) (\DSPCLIPPINGREGION.PRESS 221104Q . 222476Q) (\DSPFONT.PRESS
- 222500Q . 227461Q) (\DSPLEFTMARGIN.PRESS 227463Q . 230343Q) (\DSPLINEFEED.PRESS 230345Q . 231655Q) (
-\DSPRIGHTMARGIN.PRESS 231657Q . 232542Q) (\DSPSPACEFACTOR.PRESS 232544Q . 234150Q) (
-\DSPTOPMARGIN.PRESS 234152Q . 234735Q) (\DSPXPOSITION.PRESS 234737Q . 235455Q) (\DSPYPOSITION.PRESS 
-235457Q . 236175Q) (\FIXLINELENGTH.PRESS 236177Q . 240274Q) (\OUTCHARFN.PRESS 240276Q . 247332Q) (
-\SETSPACE.PRESS 247334Q . 250630Q) (\STARTPAGE.PRESS 250632Q . 255173Q) (\STRINGWIDTH.PRESS 255175Q . 
-270553Q) (SHOWRECTANGLE.PRESS 270555Q . 271276Q) (\PRESS.CONVERT.NSCHARACTER 271300Q . 273642Q)) (
-273704Q 404746Q (\ENDVECRUN 273716Q . 303534Q) (\VECENCODE 303536Q . 304565Q) (\VECPUT 304567Q . 
-314215Q) (\VECSKIP 314217Q . 314752Q) (\VECFONTINIT 314754Q . 322077Q) (\DRAWCIRCLE.PRESS 322101Q . 
-324404Q) (\DRAWARC.PRESS 324406Q . 325177Q) (\DRAWCURVE.PRESS 325201Q . 333137Q) (
-\DRAWCURVE.PRESS.LINE 333141Q . 342006Q) (\DRAWELLIPSE.PRESS 342010Q . 345567Q) (\GETBRUSHFONT.PRESS 
-345571Q . 347473Q) (\PRESSCURVE2 347475Q . 404744Q)) (410600Q 415424Q (\PRESSINIT 410612Q . 415422Q)) 
-(444757Q 450046Q (MAKEPRESS 444771Q . 445275Q) (PRESSFILEP 445277Q . 447054Q) (PRESS.BITMAPSCALE 
-447056Q . 450044Q)))))
-STOP
diff --git a/obsolete/library/PRESS.LCOM b/obsolete/library/PRESS.LCOM
deleted file mode 100644
index 5887ff08..00000000
Binary files a/obsolete/library/PRESS.LCOM and /dev/null differ
diff --git a/obsolete/library/Press.tedit b/obsolete/library/Press.tedit
deleted file mode 100644
index 93ad4833..00000000
Binary files a/obsolete/library/Press.tedit and /dev/null differ
diff --git a/obsolete/library/TABLEBROWSERDECLS b/obsolete/library/TABLEBROWSERDECLS
deleted file mode 100644
index 752883ae..00000000
--- a/obsolete/library/TABLEBROWSERDECLS
+++ /dev/null
@@ -1,137 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED "26-Jun-99 00:30:01" {DSK}<project>medley3.5>library>TABLEBROWSERDECLS.;2 7377   
-
-      changes to%:  (RECORDS TABLEBROWSER TABLEITEM)
-
-      previous date%: "20-Jan-93 14:52:38" {DSK}<project>medley3.5>library>TABLEBROWSERDECLS.;1)
-
-
-(* ; "
-Copyright (c) 1985, 1988, 1990, 1993, 1999 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT TABLEBROWSERDECLSCOMS)
-
-(RPAQQ TABLEBROWSERDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM)
-                                  (CONSTANTS TB.LEFT.MARGIN)))
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE TABLEBROWSER ((TBREADY FLAG)
-                            (TBHEIGHTEXPLICIT FLAG)          (* ; 
-                                             "True if creator set explicit item height or baseline")
-                            (TBITEMS POINTER)                (* ; "List of items in this browser")
-                            (TB#ITEMS WORD)                  (* ; "Number of items")
-                            (TB#DELETED WORD)                (* ; "Number of items marked deleted")
-                            (TB#LINESPERITEM WORD)           (* ; 
-               "Number of lines occupied by each item, normally 1 (dunno if any other values work)")
-                            (TBFIRSTSELECTEDITEM WORD)       (* ; 
-                                  "Number of first selected item.  If none selected, is > TB#ITEMS")
-                            (TBLASTSELECTEDITEM WORD)        (* ; 
-                                            "Number of last selected item.  If none selected, is 0")
-                            (TBITEMHEIGHT WORD)              (* ; 
-                                                 "Height of an item, i.e., fontheight*linesperitem")
-                            (TBMAXXPOS WORD)                 (* ; 
-                                             "The largest x-position a user printfn has printed to")
-                            (TBFONTHEIGHT WORD)              (* ; "Height, ascent, descent of font")
-                            (TBFONTASCENT WORD)
-                            (TBBASELINE WORD)
-                            (TBWINDOW POINTER)               (* ; 
-                    "Pointer to the display window.  Need to snap this link when browser is closed")
-                            (TBLOCK POINTER)                 (* ; 
-                                                    "Monitor lock guarding some browser operations")
-                            (TBUSERDATA POINTER)             (* ; "Arbitrary user storage")
-                            (TBFONT POINTER)                 (* ; "Pointer to font used by display")
-                            (TBEXTENT POINTER)               (* ; 
-         "Window's extent, updated as items are added, deleted, or printfn prints farther to right")
-                            (TBUPDATEFROMHERE POINTER)       (* ; 
-       "If changes have occurred while shrunk, this gives the # of first item that needs redisplay")
-                            (TBCOLUMNS POINTER)              (* ; 
-                                                           "Number of columns--not yet implemented")
-                            (TBPRINTFN POINTER)              (* ; 
-                        "(Browser Item Window) -- displays Item at current line position in window")
-                            (TBCOPYFN POINTER)               (* ; 
-                                                           "(Browser Item) -- copy selects Item")
-                            (TBFONTCHANGEFN POINTER)         (* ; 
-                                     "(Browser Window) -- called when tb.set.font changes the font")
-                            (TBCLOSEFN POINTER)              (* ; 
-                   "(Browser Window Close/Shrink) -- called when you try to close or shrink window")
-                            (TBAFTERCLOSEFN POINTER)         (* ; 
-                                             "(Browser Window) -- called to cleanup AFTER a closew")
-                            (TBTITLEEVENTFN POINTER)         (* ; 
-                                      "(Window Browser) -- handles button event in browser's title")
-                            (TBLINETHICKNESS POINTER)        (* ; 
-                                                     "Thickness of line for deletions (normally 1)")
-                            (TBORIGIN POINTER)               (* ; 
-                                                          "Y position of the top of the first item")
-                            (TBTAILHINT POINTER)             (* ; 
-                                                  "A tail of TBITEMS, used to speed up TB.NTH.ITEM")
-                            (TBHEADINGWINDOW POINTER)        (* ; 
-    "An optional %"header window%" that should be horizontally scrolled in synchrony with this one")
-                            (NIL POINTER)))
-
-(DATATYPE TABLEITEM ((TISELECTED FLAG)
-                         (TIDELETED FLAG)
-                         (TIUNDELETABLE FLAG)
-                         (TIUNSELECTABLE FLAG)
-                         (TIUNCOPYSELECTABLE FLAG)
-                         (TIDATA POINTER)
-                         (TI# WORD)))
-)
-
-(/DECLAREDATATYPE 'TABLEBROWSER
-       '(FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER
-              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
-              POINTER POINTER POINTER POINTER)
-       '((TABLEBROWSER 0 (FLAGBITS . 0))
-         (TABLEBROWSER 0 (FLAGBITS . 16))
-         (TABLEBROWSER 0 POINTER)
-         (TABLEBROWSER 2 (BITS . 15))
-         (TABLEBROWSER 3 (BITS . 15))
-         (TABLEBROWSER 4 (BITS . 15))
-         (TABLEBROWSER 5 (BITS . 15))
-         (TABLEBROWSER 6 (BITS . 15))
-         (TABLEBROWSER 7 (BITS . 15))
-         (TABLEBROWSER 8 (BITS . 15))
-         (TABLEBROWSER 9 (BITS . 15))
-         (TABLEBROWSER 10 (BITS . 15))
-         (TABLEBROWSER 11 (BITS . 15))
-         (TABLEBROWSER 12 POINTER)
-         (TABLEBROWSER 14 POINTER)
-         (TABLEBROWSER 16 POINTER)
-         (TABLEBROWSER 18 POINTER)
-         (TABLEBROWSER 20 POINTER)
-         (TABLEBROWSER 22 POINTER)
-         (TABLEBROWSER 24 POINTER)
-         (TABLEBROWSER 26 POINTER)
-         (TABLEBROWSER 28 POINTER)
-         (TABLEBROWSER 30 POINTER)
-         (TABLEBROWSER 32 POINTER)
-         (TABLEBROWSER 34 POINTER)
-         (TABLEBROWSER 36 POINTER)
-         (TABLEBROWSER 38 POINTER)
-         (TABLEBROWSER 40 POINTER)
-         (TABLEBROWSER 42 POINTER)
-         (TABLEBROWSER 44 POINTER)
-         (TABLEBROWSER 46 POINTER))
-       '48)
-
-(/DECLAREDATATYPE 'TABLEITEM '(FLAG FLAG FLAG FLAG FLAG POINTER WORD)
-       '((TABLEITEM 0 (FLAGBITS . 0))
-         (TABLEITEM 0 (FLAGBITS . 16))
-         (TABLEITEM 0 (FLAGBITS . 32))
-         (TABLEITEM 0 (FLAGBITS . 48))
-         (TABLEITEM 0 (FLAGBITS . 64))
-         (TABLEITEM 2 POINTER)
-         (TABLEITEM 1 (BITS . 15)))
-       '4)
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ TB.LEFT.MARGIN 8)
-
-
-(CONSTANTS TB.LEFT.MARGIN)
-)
-(PUTPROPS TABLEBROWSERDECLS COPYRIGHT ("Venue & Xerox Corporation" 1985 1988 1990 1993 1999))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
diff --git a/obsolete/library/TABLEBROWSERDECLS.LCOM b/obsolete/library/TABLEBROWSERDECLS.LCOM
deleted file mode 100644
index fa540277..00000000
--- a/obsolete/library/TABLEBROWSERDECLS.LCOM
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "26-Jun-99 00:30:15" ("compiled on " {DSK}<project>medley3.5>library>TABLEBROWSERDECLS.;2
) "29-Jan-99 11:25:20" tcompl'd in "LFG 21-Jun-99 ..." dated "21-Jun-99 23:39:34")
(FILECREATED "26-Jun-99 00:30:01" {DSK}<project>medley3.5>library>TABLEBROWSERDECLS.;2 7377 changes 
to%: (RECORDS TABLEBROWSER TABLEITEM) previous date%: "20-Jan-93 14:52:38" 
{DSK}<project>medley3.5>library>TABLEBROWSERDECLS.;1)
(PRETTYCOMPRINT TABLEBROWSERDECLSCOMS)
(RPAQQ TABLEBROWSERDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) (CONSTANTS TB.LEFT.MARGIN)))
(DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (* ; 
"True if creator set explicit item height or baseline") (TBITEMS POINTER) (* ; 
"List of items in this browser") (TB#ITEMS WORD) (* ; "Number of items") (TB#DELETED WORD) (* ; 
"Number of items marked deleted") (TB#LINESPERITEM WORD) (* ; 
"Number of lines occupied by each item, normally 1 (dunno if any other values work)") (
TBFIRSTSELECTEDITEM WORD) (* ; "Number of first selected item.  If none selected, is > TB#ITEMS") (
TBLASTSELECTEDITEM WORD) (* ; "Number of last selected item.  If none selected, is 0") (TBITEMHEIGHT 
WORD) (* ; "Height of an item, i.e., fontheight*linesperitem") (TBMAXXPOS WORD) (* ; 
"The largest x-position a user printfn has printed to") (TBFONTHEIGHT WORD) (* ; 
"Height, ascent, descent of font") (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (* ; 
"Pointer to the display window.  Need to snap this link when browser is closed") (TBLOCK POINTER) (* ;
 "Monitor lock guarding some browser operations") (TBUSERDATA POINTER) (* ; "Arbitrary user storage") 
(TBFONT POINTER) (* ; "Pointer to font used by display") (TBEXTENT POINTER) (* ; 
"Window's extent, updated as items are added, deleted, or printfn prints farther to right") (
TBUPDATEFROMHERE POINTER) (* ; 
"If changes have occurred while shrunk, this gives the # of first item that needs redisplay") (
TBCOLUMNS POINTER) (* ; "Number of columns--not yet implemented") (TBPRINTFN POINTER) (* ; 
"(Browser Item Window) -- displays Item at current line position in window") (TBCOPYFN POINTER) (* ; 
"(Browser Item) -- copy selects Item") (TBFONTCHANGEFN POINTER) (* ; 
"(Browser Window) -- called when tb.set.font changes the font") (TBCLOSEFN POINTER) (* ; 
"(Browser Window Close/Shrink) -- called when you try to close or shrink window") (TBAFTERCLOSEFN 
POINTER) (* ; "(Browser Window) -- called to cleanup AFTER a closew") (TBTITLEEVENTFN POINTER) (* ; 
"(Window Browser) -- handles button event in browser's title") (TBLINETHICKNESS POINTER) (* ; 
"Thickness of line for deletions (normally 1)") (TBORIGIN POINTER) (* ; 
"Y position of the top of the first item") (TBTAILHINT POINTER) (* ; 
"A tail of TBITEMS, used to speed up TB.NTH.ITEM") (TBHEADINGWINDOW POINTER) (* ; 
"An optional %"header window%" that should be horizontally scrolled in synchrony with this one") (NIL 
POINTER)))
(DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (
TIUNCOPYSELECTABLE FLAG) (TIDATA POINTER) (TI# WORD)))
(/DECLAREDATATYPE (QUOTE TABLEBROWSER) (QUOTE (FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
 POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((TABLEBROWSER 0 (FLAGBITS . 0)) (
TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 POINTER) (TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 
(BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (
TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10
 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 POINTER) (TABLEBROWSER 14 POINTER) (
TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER)
 (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 
POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 
38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (
TABLEBROWSER 46 POINTER))) (QUOTE 48))
(/DECLAREDATATYPE (QUOTE TABLEITEM) (QUOTE (FLAG FLAG FLAG FLAG FLAG POINTER WORD)) (QUOTE ((TABLEITEM
 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS
 . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 2 POINTER) (TABLEITEM 1 (BITS . 15)))) (QUOTE 4))
(RPAQQ TB.LEFT.MARGIN 8)
(CONSTANTS TB.LEFT.MARGIN)
(PUTPROPS TABLEBROWSERDECLS COPYRIGHT ("Venue & Xerox Corporation" 1985 1988 1990 1993 1999))
NIL
\ No newline at end of file
diff --git a/obsolete/library/TBDECLS b/obsolete/library/TBDECLS
deleted file mode 100644
index d9b78084..00000000
--- a/obsolete/library/TBDECLS
+++ /dev/null
@@ -1,150 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED "27-Sep-94 15:03:22" {DSK}<lispcore>library>TBDECLS.;3 7831   
-
-      changes to%:  (RECORDS TABLEBROWSER TABLEITEM)
-
-      previous date%: "20-Jan-93 14:52:38" {DSK}<lispcore>library>TBDECLS.;2)
-
-
-(* ; "
-Copyright (c) 1985, 1988, 1990, 1993, 1994 by Venue.  All rights reserved.
-")
-
-(PRETTYCOMPRINT TBDECLSCOMS)
-
-(RPAQQ TBDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM)
-                        (CONSTANTS TB.LEFT.MARGIN)))
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE TABLEBROWSER ((TBREADY FLAG)
-                            (TBHEIGHTEXPLICIT FLAG)          (* ; 
-                                             "True if creator set explicit item height or baseline")
-                            (NIL 6 FLAG)
-                            (TBITEMS POINTER)                (* ; "List of items in this browser")
-                            (TB#ITEMS WORD)                  (* ; "Number of items")
-                            (TB#DELETED WORD)                (* ; "Number of items marked deleted")
-                            (TB#LINESPERITEM WORD)           (* ; 
-               "Number of lines occupied by each item, normally 1 (dunno if any other values work)")
-                            (TBFIRSTSELECTEDITEM WORD)       (* ; 
-                                  "Number of first selected item.  If none selected, is > TB#ITEMS")
-                            (TBLASTSELECTEDITEM WORD)        (* ; 
-                                            "Number of last selected item.  If none selected, is 0")
-                            (TBITEMHEIGHT WORD)              (* ; 
-                                                 "Height of an item, i.e., fontheight*linesperitem")
-                            (TBMAXXPOS WORD)                 (* ; 
-                                             "The largest x-position a user printfn has printed to")
-                            (TBFONTHEIGHT WORD)              (* ; "Height, ascent, descent of font")
-                            (TBFONTASCENT WORD)
-                            (TBBASELINE WORD)
-                            (TBWINDOW POINTER)               (* ; 
-                    "Pointer to the display window.  Need to snap this link when browser is closed")
-                            (TBLOCK POINTER)                 (* ; 
-                                                    "Monitor lock guarding some browser operations")
-                            (TBUSERDATA POINTER)             (* ; "Arbitrary user storage")
-                            (TBFONT POINTER)                 (* ; "Pointer to font used by display")
-                            (TBEXTENT POINTER)               (* ; 
-         "Window's extent, updated as items are added, deleted, or printfn prints farther to right")
-                            (TBUPDATEFROMHERE POINTER)       (* ; 
-       "If changes have occurred while shrunk, this gives the # of first item that needs redisplay")
-                            (TBCOLUMNS POINTER)              (* ; 
-                                                           "Number of columns--not yet implemented")
-                            (TBPRINTFN POINTER)              (* ; 
-                        "(Browser Item Window) -- displays Item at current line position in window")
-                            (TBCOPYFN POINTER)               (* ; 
-                                                           "(Browser Item) -- copy selects Item")
-                            (TBFONTCHANGEFN POINTER)         (* ; 
-                                     "(Browser Window) -- called when tb.set.font changes the font")
-                            (TBCLOSEFN POINTER)              (* ; 
-                   "(Browser Window Close/Shrink) -- called when you try to close or shrink window")
-                            (TBAFTERCLOSEFN POINTER)         (* ; 
-                                             "(Browser Window) -- called to cleanup AFTER a closew")
-                            (TBTITLEEVENTFN POINTER)         (* ; 
-                                      "(Window Browser) -- handles button event in browser's title")
-                            (TBLINETHICKNESS POINTER)        (* ; 
-                                                     "Thickness of line for deletions (normally 1)")
-                            (TBORIGIN POINTER)               (* ; 
-                                                          "Y position of the top of the first item")
-                            (TBTAILHINT POINTER)             (* ; 
-                                                  "A tail of TBITEMS, used to speed up TB.NTH.ITEM")
-                            (TBHEADINGWINDOW POINTER)        (* ; 
-    "An optional %"header window%" that should be horizontally scrolled in synchrony with this one")
-                            (NIL POINTER)))
-
-(DATATYPE TABLEITEM ((TISELECTED FLAG)
-                         (TIDELETED FLAG)
-                         (TIUNDELETABLE FLAG)
-                         (TIUNSELECTABLE FLAG)
-                         (TIUNCOPYSELECTABLE FLAG)
-                         (NIL 3 FLAG)
-                         (TIDATA POINTER)
-                         (TI# WORD)
-                         (NIL WORD)))
-)
-
-(/DECLAREDATATYPE 'TABLEBROWSER
-       '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD
-              WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-              POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)
-       '((TABLEBROWSER 0 (FLAGBITS . 0))
-         (TABLEBROWSER 0 (FLAGBITS . 16))
-         (TABLEBROWSER 0 (FLAGBITS . 32))
-         (TABLEBROWSER 0 (FLAGBITS . 48))
-         (TABLEBROWSER 0 (FLAGBITS . 64))
-         (TABLEBROWSER 0 (FLAGBITS . 80))
-         (TABLEBROWSER 0 (FLAGBITS . 96))
-         (TABLEBROWSER 0 (FLAGBITS . 112))
-         (TABLEBROWSER 0 POINTER)
-         (TABLEBROWSER 2 (BITS . 15))
-         (TABLEBROWSER 3 (BITS . 15))
-         (TABLEBROWSER 4 (BITS . 15))
-         (TABLEBROWSER 5 (BITS . 15))
-         (TABLEBROWSER 6 (BITS . 15))
-         (TABLEBROWSER 7 (BITS . 15))
-         (TABLEBROWSER 8 (BITS . 15))
-         (TABLEBROWSER 9 (BITS . 15))
-         (TABLEBROWSER 10 (BITS . 15))
-         (TABLEBROWSER 11 (BITS . 15))
-         (TABLEBROWSER 12 POINTER)
-         (TABLEBROWSER 14 POINTER)
-         (TABLEBROWSER 16 POINTER)
-         (TABLEBROWSER 18 POINTER)
-         (TABLEBROWSER 20 POINTER)
-         (TABLEBROWSER 22 POINTER)
-         (TABLEBROWSER 24 POINTER)
-         (TABLEBROWSER 26 POINTER)
-         (TABLEBROWSER 28 POINTER)
-         (TABLEBROWSER 30 POINTER)
-         (TABLEBROWSER 32 POINTER)
-         (TABLEBROWSER 34 POINTER)
-         (TABLEBROWSER 36 POINTER)
-         (TABLEBROWSER 38 POINTER)
-         (TABLEBROWSER 40 POINTER)
-         (TABLEBROWSER 42 POINTER)
-         (TABLEBROWSER 44 POINTER)
-         (TABLEBROWSER 46 POINTER))
-       '48)
-
-(/DECLAREDATATYPE 'TABLEITEM '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD)
-       '((TABLEITEM 0 (FLAGBITS . 0))
-         (TABLEITEM 0 (FLAGBITS . 16))
-         (TABLEITEM 0 (FLAGBITS . 32))
-         (TABLEITEM 0 (FLAGBITS . 48))
-         (TABLEITEM 0 (FLAGBITS . 64))
-         (TABLEITEM 0 (FLAGBITS . 80))
-         (TABLEITEM 0 (FLAGBITS . 96))
-         (TABLEITEM 0 (FLAGBITS . 112))
-         (TABLEITEM 0 POINTER)
-         (TABLEITEM 2 (BITS . 15))
-         (TABLEITEM 3 (BITS . 15)))
-       '4)
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ TB.LEFT.MARGIN 8)
-
-
-(CONSTANTS TB.LEFT.MARGIN)
-)
-(PUTPROPS TBDECLS COPYRIGHT ("Venue" 1985 1988 1990 1993 1994))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
diff --git a/obsolete/library/TBDECLS.LCOM b/obsolete/library/TBDECLS.LCOM
deleted file mode 100644
index 76e1a674..00000000
--- a/obsolete/library/TBDECLS.LCOM
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "16-Aug-95 17:08:48" ("compiled on " {DSK}<lispcore>library>TBDECLS.;3) 
"30-Mar-95 20:33:04" bcompl'd in "Medley 14-Aug-95 ..." dated "14-Aug-95 15:27:48")
(FILECREATED "27-Sep-94 15:03:22" {DSK}<lispcore>library>TBDECLS.;3 7831 changes to%: (RECORDS 
TABLEBROWSER TABLEITEM) previous date%: "20-Jan-93 14:52:38" {DSK}<lispcore>library>TBDECLS.;2)
(PRETTYCOMPRINT TBDECLSCOMS)
(RPAQQ TBDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) (CONSTANTS TB.LEFT.MARGIN)))
(DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (* ; 
"True if creator set explicit item height or baseline") (NIL 6 FLAG) (TBITEMS POINTER) (* ; 
"List of items in this browser") (TB#ITEMS WORD) (* ; "Number of items") (TB#DELETED WORD) (* ; 
"Number of items marked deleted") (TB#LINESPERITEM WORD) (* ; 
"Number of lines occupied by each item, normally 1 (dunno if any other values work)") (
TBFIRSTSELECTEDITEM WORD) (* ; "Number of first selected item.  If none selected, is > TB#ITEMS") (
TBLASTSELECTEDITEM WORD) (* ; "Number of last selected item.  If none selected, is 0") (TBITEMHEIGHT 
WORD) (* ; "Height of an item, i.e., fontheight*linesperitem") (TBMAXXPOS WORD) (* ; 
"The largest x-position a user printfn has printed to") (TBFONTHEIGHT WORD) (* ; 
"Height, ascent, descent of font") (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (* ; 
"Pointer to the display window.  Need to snap this link when browser is closed") (TBLOCK POINTER) (* ;
 "Monitor lock guarding some browser operations") (TBUSERDATA POINTER) (* ; "Arbitrary user storage") 
(TBFONT POINTER) (* ; "Pointer to font used by display") (TBEXTENT POINTER) (* ; 
"Window's extent, updated as items are added, deleted, or printfn prints farther to right") (
TBUPDATEFROMHERE POINTER) (* ; 
"If changes have occurred while shrunk, this gives the # of first item that needs redisplay") (
TBCOLUMNS POINTER) (* ; "Number of columns--not yet implemented") (TBPRINTFN POINTER) (* ; 
"(Browser Item Window) -- displays Item at current line position in window") (TBCOPYFN POINTER) (* ; 
"(Browser Item) -- copy selects Item") (TBFONTCHANGEFN POINTER) (* ; 
"(Browser Window) -- called when tb.set.font changes the font") (TBCLOSEFN POINTER) (* ; 
"(Browser Window Close/Shrink) -- called when you try to close or shrink window") (TBAFTERCLOSEFN 
POINTER) (* ; "(Browser Window) -- called to cleanup AFTER a closew") (TBTITLEEVENTFN POINTER) (* ; 
"(Window Browser) -- handles button event in browser's title") (TBLINETHICKNESS POINTER) (* ; 
"Thickness of line for deletions (normally 1)") (TBORIGIN POINTER) (* ; 
"Y position of the top of the first item") (TBTAILHINT POINTER) (* ; 
"A tail of TBITEMS, used to speed up TB.NTH.ITEM") (TBHEADINGWINDOW POINTER) (* ; 
"An optional %"header window%" that should be horizontally scrolled in synchrony with this one") (NIL 
POINTER)))
(DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (
TIUNCOPYSELECTABLE FLAG) (NIL 3 FLAG) (TIDATA POINTER) (TI# WORD) (NIL WORD)))
(/DECLAREDATATYPE (QUOTE TABLEBROWSER) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((
TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 (FLAGBITS . 32)) (
TABLEBROWSER 0 (FLAGBITS . 48)) (TABLEBROWSER 0 (FLAGBITS . 64)) (TABLEBROWSER 0 (FLAGBITS . 80)) (
TABLEBROWSER 0 (FLAGBITS . 96)) (TABLEBROWSER 0 (FLAGBITS . 112)) (TABLEBROWSER 0 POINTER) (
TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 
(BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (
TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 
12 POINTER) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (
TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER)
 (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 
POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 
42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER))) (QUOTE 48))
(/DECLAREDATATYPE (QUOTE TABLEITEM) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD)
) (QUOTE ((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (
TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 0 (FLAGBITS . 80)) (TABLEITEM 0 
(FLAGBITS . 96)) (TABLEITEM 0 (FLAGBITS . 112)) (TABLEITEM 0 POINTER) (TABLEITEM 2 (BITS . 15)) (
TABLEITEM 3 (BITS . 15)))) (QUOTE 4))
(RPAQQ TB.LEFT.MARGIN 8)
(CONSTANTS TB.LEFT.MARGIN)
(PUTPROPS TBDECLS COPYRIGHT ("Venue" 1985 1988 1990 1993 1994))
NIL
\ No newline at end of file
diff --git a/obsolete/library/UNIXPRINTCOMMAND b/obsolete/library/UNIXPRINTCOMMAND
deleted file mode 100644
index 24fd2e1e..00000000
--- a/obsolete/library/UNIXPRINTCOMMAND
+++ /dev/null
@@ -1,78 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-(FILECREATED "20-May-92 15:34:18" |{DSK}<users>nilsson>UNIXPRINTCOMMAND.;1| 3317   
-
-      |changes| |to:|  (VARS UNIXPRINTCOMMANDCOMS)
-                       (FUNCTIONS FOOT)
-                       (FNS |UnixPrintCommandForHP|))
-
-
-; Copyright (c) 1992 by Venue.  All rights reserved.
-
-(PRETTYCOMPRINT UNIXPRINTCOMMANDCOMS)
-
-(RPAQQ UNIXPRINTCOMMANDCOMS ((FNS |UnixPrintCommand| |UnixPrintCommandForHP|)))
-(DEFINEQ
-
-(|UnixPrintCommand|
-  (LAMBDA (PRINTER COPIES NAME TMPNAME)               (* \; "Edited 20-May-92 14:26 by nilsson")
-
-    (* |;;| "This function is called when the user wants to UNIXPRINT a file. It has to return a string that when sent to a shell prints the file tmpname. In the cub version this should look something like \"/usr/ucb/lpr  tmpname\". The arguments to this function are:")
-
-    (* |;;| " PRINTER - the name of the printer. Usually something like lw or  plw.")
-
-    (* |;;| "COPIES - how many copies of this job to be printed.")
-
-    (* |;;| "NAME - the name of this job. This gets printed on the banner of your job.")
-
-    (* |;;| 
-  "TMPNAME - The name of the temporary file that contains the postscript code for this job. ")
-
-    (* |;;| "Note the clever function UnixShellQuote. It converts any lisp name to a string that is quoted according to /bin/sh syntax")
-
-    (CONCAT "/usr/ucb/lpr " (COND
-                               (PRINTER (CONCAT "-P" (|UnixShellQuote| PRINTER)
-                                               " "))
-                               (T ""))
-           (COND
-              ((AND (FIXP COPIES)
-                    (NEQ COPIES 1))
-               (CONCAT "-#" COPIES " "))
-              (T ""))
-           " -J"
-           (|UnixShellQuote| NAME)
-           " -r -s " TMPNAME)))
-
-(|UnixPrintCommandForHP|
-  (LAMBDA (PRINTER COPIES NAME TMPNAME)               (* \; "Edited 20-May-92 15:33 by nilsson")
-
-    (* |;;| "This function is called when the user wants to UNIXPRINT a file. It has to return a string that when sent to a shell prints the file tmpname. In the cub version this should look something like \"/usr/ucb/lpr  tmpname\". The arguments to this function are:")
-
-    (* |;;| " PRINTER - the name of the printer. Usually something like lw or  plw.")
-
-    (* |;;| "COPIES - how many copies of this job to be printed.")
-
-    (* |;;| "NAME - the name of this job. This gets printed on the banner of your job.")
-
-    (* |;;| 
-  "TMPNAME - The name of the temporary file that contains the postscript code for this job. ")
-
-    (* |;;| "Note the clever function UnixShellQuote. It converts any lisp name to a string that is quoted according to /bin/sh syntax")
-
-    (CONCAT "/usr/ucb/lp "                                   (* \; "HPUX uses lp instead.")
-           (COND
-              (PRINTER (CONCAT "-P" (|UnixShellQuote| PRINTER)
-                              " "))
-              (T ""))
-           (COND
-              ((AND (FIXP COPIES)
-                    (NEQ COPIES 1))
-               (CONCAT "-#" COPIES " "))
-              (T ""))
-           " -J"
-           (|UnixShellQuote| NAME)
-           " -r -s " TMPNAME)))
-)
-(PUTPROPS UNIXPRINTCOMMAND COPYRIGHT ("Venue" 1992))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL (472 3241 (|UnixPrintCommand| 482 . 1843) (|UnixPrintCommandForHP| 1845 . 3239)))))
-STOP
diff --git a/obsolete/library/UNIXPRINTCOMMAND.LCOM b/obsolete/library/UNIXPRINTCOMMAND.LCOM
deleted file mode 100644
index e5fd1c62..00000000
Binary files a/obsolete/library/UNIXPRINTCOMMAND.LCOM and /dev/null differ
diff --git a/obsolete/library/new/PCTREE b/obsolete/library/new/PCTREE
deleted file mode 100644
index b6020cf4..00000000
--- a/obsolete/library/new/PCTREE
+++ /dev/null
@@ -1,572 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "22-Mar-95 18:19:18" {DSK}<lispcore>library>new>PCTREE.;1 28446  
-
-      changes to%:  (FNS \INSERTTREE \DELETETREE \SPLITTREE \TEDIT.UPDATETREE)
-
-      previous date%: " 7-Oct-94 17:44:31" {DSK}<lispcore>library>PCTREE.;5)
-
-
-(* ; "
-Copyright (c) 1990, 1991, 1993, 1994, 1995 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT PCTREECOMS)
-
-(RPAQQ PCTREECOMS
-       [
-        (* ;; "Balanced tree PIECE TABLE supporting functions")
-
-        (FILES TEDITDCL)
-        (DECLARE%: EVAL@COMPILE DONTCOPY 
-
-               (* ;; "\WORDSINBTREEMAIN = # of words in the child-pointers & offsets section of the node -- everything before SPARE5 (the overflow place).")
-
-               
-               (* ;; 
-     "\BTREEMAXCOUNT = number of children in a full node = maximum value for a node's COUNT field.")
-
-               
-               (* ;; "\BTREELASTREALOFFSET = offset of last real space for a child entry in the node ( = \WORDSINBTREEMAIN - 4)")
-
-               (CONSTANTS (\BTREEMAXENTRIES 8)
-                      (\BTREEMAXCOUNT 8)
-                      (\BTREEWORDSPERENTRY 4)
-                      (\WORDSINBTREEMAIN (UNFOLD \BTREEMAXENTRIES 4))
-                      (\BTREELASTREALOFFSET (UNFOLD (SUB1 \BTREEMAXENTRIES)
-                                                   4))
-                      (\BTREETOPHALFOFFSET (UNFOLD (LRSH \BTREEMAXENTRIES 1)
-                                                  4)))
-               (FILES (LOADCOMP)
-                      TEDITDECLS))
-        (FNS UPDATEPCNODES FINDPCNODE \FIRSTNODE \DELETETREE \INSERTTREE \LASTNODE \MATCHPCS 
-             \SPLITTREE \TEDIT.UPDATETREE \TEDIT.PIECE-CHNO \TEDIT.SET-TOTLEN)
-        (FNS DISPTREE TREEGRAPHNODE)
-        (RECORDS BTREENODE)
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA])
-
-
-
-(* ;; "Balanced tree PIECE TABLE supporting functions")
-
-
-(FILESLOAD TEDITDCL)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \BTREEMAXENTRIES 8)
-
-(RPAQQ \BTREEMAXCOUNT 8)
-
-(RPAQQ \BTREEWORDSPERENTRY 4)
-
-(RPAQ \WORDSINBTREEMAIN (UNFOLD \BTREEMAXENTRIES 4))
-
-(RPAQ \BTREELASTREALOFFSET (UNFOLD (SUB1 \BTREEMAXENTRIES)
-                                      4))
-
-(RPAQ \BTREETOPHALFOFFSET (UNFOLD (LRSH \BTREEMAXENTRIES 1)
-                                     4))
-
-
-(CONSTANTS (\BTREEMAXENTRIES 8)
-       (\BTREEMAXCOUNT 8)
-       (\BTREEWORDSPERENTRY 4)
-       (\WORDSINBTREEMAIN (UNFOLD \BTREEMAXENTRIES 4))
-       (\BTREELASTREALOFFSET (UNFOLD (SUB1 \BTREEMAXENTRIES)
-                                    4))
-       (\BTREETOPHALFOFFSET (UNFOLD (LRSH \BTREEMAXENTRIES 1)
-                                   4)))
-)
-
-
-(FILESLOAD (LOADCOMP)
-       TEDITDECLS)
-)
-(DEFINEQ
-
-(UPDATEPCNODES
-  [LAMBDA (PC DELTA)                                     (* ; "Edited 21-Apr-93 16:09 by jds")
-
-    (* ;; "ADD DELTA TO CHNUM IN NEXTALL NODES OF TOPNODE.")
-
-    (LET ((UPWARD (fetch (PIECE PTREENODE) of PC)))
-         (while UPWARD do (for I from 0 by 4 as ITEM from 1
-                                     to (fetch (BTREENODE COUNT) of UPWARD)
-                                     when (EQ PC (\GETBASEPTR UPWARD I))
-                                     do [\PUTBASEFIXP UPWARD (IPLUS I 2)
-                                                   (IPLUS DELTA (\GETBASEFIXP UPWARD (IPLUS I 2]
-                                           (add (fetch (BTREENODE TOTLEN) of UPWARD)
-                                                  DELTA)
-                                           (SETQ PC UPWARD)
-                                           (SETQ UPWARD (fetch (BTREENODE UPWARD) of PC))
-                                           (RETURN) finally (HELP "Piece not in its TREENODE"])
-
-(FINDPCNODE
-  [LAMBDA (PC PCTB)                                      (* ; "Edited 13-Apr-93 15:00 by jds")
-
-    (* ;; "Given a piece and the pctb it's in, return pcnode")
-
-    (fetch (PIECE PTREENODE) of PC])
-
-(\FIRSTNODE
-  [LAMBDA (TREE)                                         (* ; "Edited 14-Apr-93 02:06 by jds")
-    (LET ((COUNT (fetch (BTREENODE COUNT) of TREE))
-          CHILD)
-         (SETQ CHILD (\GETBASEPTR TREE 0))
-         (COND
-            ((type? BTREENODE CHILD)
-             (\FIRSTNODE CHILD))
-            (T TREE])
-
-(\DELETETREE
-  [LAMBDA (OLD PCNODE)                    (* ; 
-                                                "Edited 21-Mar-95 15:29 by sybalsky:mv:envos")
-
-    (* ;; "Removes OLD from PCNODE.  OLD is either a piece or tree node.")
-
-    (UNINTERRUPTABLY
-        (LET* ((OLDLEN (ffetch (BTREENODE TOTLEN) of PCNODE))
-               NEWLEN INCHNO AFTERFLG NODE-COUNT ITEM# BB)
-
-              (* ;; "NEW CODE")
-
-              (SETQ NODE-COUNT (fetch (BTREENODE COUNT) of PCNODE))
-
-              (* ;; "Find OLD, .")
-
-              (for old ITEM# from 0 to (LLSH (SUB1 NODE-COUNT)
-                                                             2) by 4
-                 when (EQ OLD (\GETBASEPTR PCNODE ITEM#)) do (RETURN)
-                 finally (HELP "Piece/node not in PCNODE"))
-
-              (* ;; "Update the previous piece's length, if appropriate:")
-
-              (SETQ BB (\ADDBASE PCNODE ITEM#))
-              (\RPLPTR BB 0 NIL)
-              [for I from 0 to (IDIFFERENCE \BTREELASTREALOFFSET ITEM#) by 4
-                 do (\PUTBASEPTR BB I (\GETBASEPTR BB (IPLUS I 4)))
-                       (\PUTBASEFIXP BB (IPLUS I 2)
-                              (\GETBASEFIXP BB (IPLUS I 6]
-              (\PUTBASEPTR PCNODE \BTREELASTREALOFFSET NIL)  (* ; 
-                   "Because it's been copied, clear the old value before the refcnt-er gets to it.")
-
-              (* ;; " If adding this piece EMPTIES the tree node, DELETE it.")
-
-              (* ;; "FIXMI -- This should coalesce adjacent nodes that are too empty!")
-
-              [COND
-                 ((IEQP NODE-COUNT 1)
-                  (\DELETETREE PCNODE (fetch (BTREENODE UPWARD) of PCNODE)))
-                 (T                                          (* ; 
-                                               "No split, so update upper nodes with delta-length.")
-                    [SETQ NEWLEN
-                     (replace (BTREENODE TOTLEN) of PCNODE
-                        with (for I from 2 to NODE-COUNT as ITEM# from 2
-                                    by 4 sum (\GETBASEFIXP PCNODE ITEM#]
-                    (replace (BTREENODE COUNT) of PCNODE with (SUB1 NODE-COUNT))
-                    (\TEDIT.UPDATETREE PCNODE (IDIFFERENCE NEWLEN OLDLEN]
-
-              (* ;; "END NEW CODE")
-
-              1))])
-
-(\INSERTTREE
-  [LAMBDA (NEW OLD PCNODE NEW-PREVLEN NEW-OLDLEN PREV)
-                                                  (* ; 
-                                                "Edited 22-Mar-95 15:37 by sybalsky:mv:envos")
-
-    (* ;; "inserts NEW in front of OLD in PCNODE.  NEW/OLD are either pieces or tree nodes.")
-
-    (* ;; "If NEWE-PREVLEN is non-NIL, it's a DELTA for updating parents of THE PIECE BEFORE OLD.  This is used by \SPLITPIECE to pass down the new shortened length for the original piece.")
-
-    (UNINTERRUPTABLY
-        (LET* ((OLDLEN (ffetch (BTREENODE TOTLEN) of PCNODE))
-               NEWLEN INCHNO AFTERFLG NODE-COUNT ITEM# BB)
-
-              (* ;; "NEW CODE")
-
-              (SETQ NODE-COUNT (fetch (BTREENODE COUNT) of PCNODE))
-
-              (* ;; "Find OLD, and insert the NEW piece (and length) in front of it.")
-
-              [for old ITEM# from 0 to (LLSH (SUB1 NODE-COUNT)
-                                                             2) by 4
-                 when (EQ OLD (\GETBASEPTR PCNODE ITEM#)) do (RETURN)
-                 finally (COND
-                                (OLD (HELP "Old piece not in this PCNODE."))
-                                (T                           (* ; "INSERTING FIRST PIECE")
-                                   (SETQ ITEM# 0]
-              (OR NEW (HELP "Inserting empty item"))
-
-              (* ;; "Update the previous piece's length, if appropriate:")
-
-              [AND NEW-PREVLEN (COND
-                                  ((ZEROP ITEM#)
-
-                                   (* ;; 
-"The hard way -- the previous piece is in a prior btree node, so we have to go there to update it.")
-
-                                   (LET* ((NODE (fetch (PIECE PTREENODE) of PREV)))
-                                         (UPDATEPCNODES PREV NEW-PREVLEN)))
-                                  (T 
-                                     (* ;; "Easy way -- it's in this node.  Update it in place.")
-
-                                     (\PUTBASEFIXP PCNODE (IDIFFERENCE ITEM# 2)
-                                            (IPLUS NEW-PREVLEN (\GETBASEFIXP PCNODE (IDIFFERENCE
-                                                                                     ITEM# 2]
-              (COND
-                 (NEW-OLDLEN (\PUTBASEFIXP PCNODE (IPLUS ITEM# 2)
-                                    NEW-OLDLEN)))
-              (SETQ BB (\ADDBASE PCNODE ITEM#))
-              (\RPLPTR PCNODE \WORDSINBTREEMAIN NIL)         (* ; 
-                                               "Clean out the slot that's about to be copied over.")
-              (\BLT (\ADDBASE BB 4)
-                    BB
-                    (IDIFFERENCE \WORDSINBTREEMAIN ITEM#))
-              (\PUTBASEPTR PCNODE ITEM# NIL)                 (* ; 
-                   "Because it's been copied, clear the old value before the refcnt-er gets to it.")
-              (\RPLPTR PCNODE ITEM# NEW)
-              (COND
-                 ((type? PIECE NEW)
-                  (\PUTBASEFIXP PCNODE (IPLUS ITEM# 2)
-                         (fetch (PIECE PLEN) of NEW))
-                  (replace (PIECE PTREENODE) of NEW with PCNODE))
-                 ((type? BTREENODE NEW)                  (* ; "Inserting a NODE")
-                  (\PUTBASEFIXP PCNODE (IPLUS ITEM# 2)
-                         (fetch (BTREENODE TOTLEN) of NEW))
-                  (replace (BTREENODE UPWARD) of NEW with PCNODE))
-                 (T (\ILLEGAL.ARG NEW)))
-              [SETQ NEWLEN (replace (BTREENODE TOTLEN) of PCNODE
-                              with (for I from 0 to NODE-COUNT as ITEM#
-                                          from 2 by 4 sum (\GETBASEFIXP PCNODE ITEM#]
-
-              (* ;; " If adding this piece overflows the tree node, split it.")
-
-              [COND
-                 ((IEQP NODE-COUNT \BTREEMAXCOUNT)           (* ; 
-                                                           "Tree node is full, so have to split.")
-                  (\SPLITTREE PCNODE OLD NEW))
-                 (T                                          (* ; 
-                                               "No split, so update upper nodes with delta-length.")
-                    (replace (BTREENODE COUNT) of PCNODE with (ADD1 NODE-COUNT))
-                    (\TEDIT.UPDATETREE PCNODE (IDIFFERENCE NEWLEN OLDLEN]
-
-              (* ;; "END NEW CODE")
-
-              1))])
-
-(\LASTNODE
-  [LAMBDA (TREE)                                         (* ; "Edited 14-Apr-93 16:29 by jds")
-    (LET ((COUNT (fetch (BTREENODE COUNT) of TREE))
-          CHILD)
-         (for ITEM# from (LLSH (IDIFFERENCE COUNT 1)
-                                       2) to 0 by -4 when (SETQ CHILD (\GETBASEPTR TREE 
-                                                                                         ITEM#))
-            do (RETURN (COND
-                              ((type? BTREENODE CHILD)
-                               (\LASTNODE CHILD))
-                              (T TREE])
-
-(\MATCHPCS
-  [LAMBDA (PCNODE)                                       (* ; "Edited  5-May-93 17:57 by jds")
-
-    (* ;; "Make sure that any pieces pointed to this node point back to this node.")
-
-    (bind PC for OFFSET from 0 to \WORDSINBTREEMAIN by 4 as I from 1
-       to (fetch (BTREENODE COUNT) of PCNODE) do (SETQ PC (\GETBASEPTR PCNODE OFFSET)
-                                                                  )
-                                                                (COND
-                                                                   ((type? PIECE PC)
-                                                                    (replace (PIECE PTREENODE)
-                                                                       of PC with PCNODE))
-                                                                   ((type? BTREENODE PC)
-                                                                    (replace (BTREENODE UPWARD)
-                                                                       of PC with PCNODE])
-
-(\SPLITTREE
-  [LAMBDA (PCNODE)                            (* ; 
-                                                "Edited 21-Mar-95 15:26 by sybalsky:mv:envos")
-
-    (* ;; "We're adding piece NEW in front of OLD.  OLD is represented in the B-tree node PCNODE, which is full.")
-
-    (* ;; "Split PCNODE in two and propogate any changes upward.")
-
-    (UNINTERRUPTABLY
-        [LET ((UPWARD (fetch (BTREENODE UPWARD) of PCNODE))
-              COUNT ITEM# NEW1 NEW2)
-             (COND
-                (UPWARD 
-
-                       (* ;; 
-                     "Easy case:  This is not the root node, so split the node and propogate up.")
-
-                       (SETQ NEW1 (create BTREENODE using PCNODE))
-
-                       (* ;; "Clean out upper 3 child entries, leaving only the lower 2.  Have to tell GC about actual child slots being set to NIL (hence \RPLPTRs):")
-
-                       (for OFST from \BTREETOPHALFOFFSET to \WORDSINBTREEMAIN
-                          by 4 do (\RPLPTR NEW1 OFST NIL)
-                                         (\PUTBASEFIXP NEW1 (IPLUS OFST 2)
-                                                0))
-                       (replace (BTREENODE COUNT) of NEW1 with (LRSH \BTREEMAXENTRIES 1))
-                       (\TEDIT.SET-TOTLEN NEW1)
-                       (\MATCHPCS NEW1)
-
-                       (* ;; 
-                     "Now clean up the old piece, to contain only the upper 3 original children:")
-
-                       (for OFST from 0 to (SUB1 \BTREETOPHALFOFFSET) by 4
-                          do                             (* ; 
-                               "For GC, have to tell it we've dropped pointers to first N/2 pieces")
-                                (\RPLPTR PCNODE OFST NIL))
-
-                       (* ;; "Move upper N/2+1 down")
-
-                       [for OFST from 0 to \BTREETOPHALFOFFSET by 4 as UPPEROFST
-                          from \BTREETOPHALFOFFSET by 4
-                          do (\PUTBASEPTR PCNODE OFST (\GETBASEPTR PCNODE UPPEROFST))
-                                (\PUTBASEFIXP PCNODE (IPLUS 2 OFST)
-                                       (\GETBASEFIXP PCNODE (IPLUS 2 UPPEROFST]
-
-                       (* ;; "And clean out upper 2 slots, without the GC seeing it:")
-
-                       (for OFST from (IPLUS \BTREEWORDSPERENTRY \BTREETOPHALFOFFSET)
-                          to \WORDSINBTREEMAIN by \BTREEWORDSPERENTRY
-                          do (\PUTBASEPTR PCNODE OFST NIL)
-                                (\PUTBASEFIXP PCNODE (IPLUS OFST 2)
-                                       0))
-                       (replace (BTREENODE COUNT) of PCNODE with (ADD1 (LRSH 
-                                                                                     \BTREEMAXENTRIES
-                                                                                         1)))
-                       (\TEDIT.SET-TOTLEN PCNODE)
-                       (SETQ COUNT (fetch (BTREENODE COUNT) of UPWARD))
-                       (\INSERTTREE NEW1 PCNODE UPWARD NIL (fetch (BTREENODE TOTLEN)
-                                                                  of PCNODE)))
-                (T 
-                   (* ;; "Hard case:  This is the root node.  We need to create 2 new nodes, put the split parts there, and re-use this node as the root.")
-
-                   (SETQ NEW1 (create BTREENODE using PCNODE))
-                   (for OFST from \BTREETOPHALFOFFSET to \WORDSINBTREEMAIN by 4
-                      do (\RPLPTR NEW1 OFST NIL)
-                            (\PUTBASEFIXP NEW1 (IPLUS OFST 2)
-                                   0))
-                   (replace (BTREENODE UPWARD) of NEW1 with PCNODE)
-                   (replace (BTREENODE COUNT) of NEW1 with (LRSH \BTREEMAXENTRIES 1))
-                   (\TEDIT.SET-TOTLEN NEW1)
-                   (\MATCHPCS NEW1)
-
-                   (* ;; "--")
-
-                   (SETQ NEW2 (create BTREENODE using PCNODE))
-                   (for OFST from 0 to (SUB1 \BTREETOPHALFOFFSET) by 4
-                      do                                 (* ; 
-                               "For GC, have to tell it we've dropped pointers to first N/2 pieces")
-                            (\RPLPTR NEW2 OFST NIL))
-                   [for OFST from 0 to \BTREETOPHALFOFFSET by 4 as UPPEROFST
-                      from \BTREETOPHALFOFFSET by 4
-                      do (\PUTBASEPTR NEW2 OFST (\GETBASEPTR NEW2 UPPEROFST))
-                            (\PUTBASEFIXP NEW2 (IPLUS 2 OFST)
-                                   (\GETBASEFIXP NEW2 (IPLUS 2 UPPEROFST]
-                   (for OFST from (IPLUS \BTREEWORDSPERENTRY \BTREETOPHALFOFFSET)
-                      to \WORDSINBTREEMAIN by \BTREEWORDSPERENTRY
-                      do (\PUTBASEPTR NEW2 OFST NIL)
-                            (\PUTBASEFIXP NEW2 (IPLUS OFST 2)
-                                   0))
-                   (replace (BTREENODE UPWARD) of NEW2 with PCNODE)
-                   (replace (BTREENODE COUNT) of NEW2 with (ADD1 (LRSH \BTREEMAXENTRIES 1
-                                                                                   )))
-                   (\TEDIT.SET-TOTLEN NEW2)
-                   (\MATCHPCS NEW2)
-
-                   (* ;; "Now clean out the top-level node, and fill it in with its new children.")
-
-                   (for OFST from 0 to \WORDSINBTREEMAIN by \BTREEWORDSPERENTRY
-                      do 
-
-                            (* ;; "Clean out the entries in the node, so we don't over-write them by mistake, thus losing refcount sync.")
-
-                            (\RPLPTR PCNODE OFST NIL)
-                            (\PUTBASEFIXP PCNODE (IPLUS 2 OFST)
-                                   0))
-                   (\RPLPTR PCNODE 0 NEW1)                   (* ; "Add first new node")
-                   (\PUTBASEFIXP PCNODE 2 (ffetch (BTREENODE TOTLEN) of NEW1))
-                   (\RPLPTR PCNODE 4 NEW2)                   (* ; "And the second....")
-                   (\PUTBASEFIXP PCNODE 6 (ffetch (BTREENODE TOTLEN) of NEW2))
-                   (freplace (BTREENODE COUNT) of PCNODE with 2)
-                   (freplace (BTREENODE TOTLEN) of PCNODE with (IPLUS (ffetch
-                                                                                   (BTREENODE TOTLEN)
-                                                                                     of NEW1)
-                                                                                  (ffetch
-                                                                                   (BTREENODE TOTLEN)
-                                                                                     of NEW2])])
-
-(\TEDIT.UPDATETREE
-  [LAMBDA (PCNODE DELTA)                      (* ; 
-                                                "Edited 21-Mar-95 14:40 by sybalsky:mv:envos")
-
-    (* ;; "The size of the text represented by PCNODE has grown by DELTA.  Update all of PCNODE's parents to reflect the change in length.")
-
-    (LET ((UPWARD (fetch (BTREENODE UPWARD) of PCNODE)))
-         (while UPWARD do 
-
-                                 (* ;; "Keep going up in the tree til we hit the top.")
-
-                                 (for old ITEM# from 0 by 4 as I from 1
-                                    to (ffetch (BTREENODE COUNT) of UPWARD)
-                                    when (EQ (\GETBASEPTR UPWARD ITEM#)
-                                                 PCNODE)
-                                    do (\PUTBASEFIXP UPWARD (IPLUS ITEM# 2)
-                                                  (IPLUS (\GETBASEFIXP UPWARD (IPLUS ITEM# 2))
-                                                         DELTA))
-                                          (add (fetch (BTREENODE TOTLEN) of UPWARD)
-                                                 DELTA)
-                                          (RETURN) FINALLY (HELP "PCNODE not in upward node."))
-                                 (SETQ PCNODE UPWARD)
-                                 (SETQ UPWARD (fetch (BTREENODE UPWARD) of PCNODE])
-
-(\TEDIT.PIECE-CHNO
-  [LAMBDA (PC)
-    (LET ((PCNODE (fetch (PIECE PTREENODE) of PC))
-          (CHARCOUNT 0))
-         (while PCNODE do [add CHARCOUNT (for OFST from 0 by 4
-                                                        while (NEQ PC (\GETBASEPTR PCNODE OFST))
-                                                        sum (\GETBASEFIXP PCNODE (IPLUS OFST 2]
-                                 (SETQ PC PCNODE)
-                                 (SETQ PCNODE (fetch (BTREENODE UPWARD) of PCNODE)))
-         (ADD1 CHARCOUNT])
-
-(\TEDIT.SET-TOTLEN
-  [LAMBDA (PCNODE)                                       (* ; "Edited  9-May-93 15:40 by jds")
-
-    (* ;; "Fix the TOTLEN field of a node to match the sum of its childrens' lengths")
-
-    (replace (BTREENODE TOTLEN) of PCNODE with (for I from 1
-                                                              to (fetch (BTREENODE COUNT)
-                                                                        of PCNODE) as ITEM#
-                                                              from 2 by 4
-                                                              sum (\GETBASEFIXP PCNODE ITEM#])
-)
-(DEFINEQ
-
-(DISPTREE
-  [LAMBDA (TREE DEPTH)                                   (* ; "Edited 13-Apr-90 15:00 by ON")
-    (LET [(G (TREEGRAPHNODE TREE NIL (OR (NUMBERP DEPTH)
-                                             T]
-         (SHOWGRAPH (LAYOUTGRAPH (CADR G)
-                           (LIST (CAR G))
-                           '(VERTICAL))
-                NIL
-                #'(LAMBDA (X)
-                    (INSPECT (fetch NODEID of X])
-
-(TREEGRAPHNODE
-  [LAMBDA (TREE PARENT DEPTH)                           (* ; "Edited 12-Jun-90 10:33 by mitani")
-    (LET (THISNODE NEWDEPTH NODEID LONODES HINODES BFNODE BFNODEID RANKNODE RANKNODEID)
-         (COND
-            ((ATOM TREE)
-             (LIST [fetch NODEID of (SETQ THISNODE (NODECREATE (CONS)
-                                                                  TREE NIL NIL (LIST PARENT]
-                   (LIST THISNODE)))
-            ((OR (EQ DEPTH T)
-                 (AND (NUMBERP DEPTH)
-                      (>= DEPTH 0)))
-             (SETQ NEWDEPTH (COND
-                               ((NUMBERP DEPTH)
-                                (SUB1 DEPTH))
-                               (T DEPTH)))
-             (SETQ NODEID (fetch (PCTNODE PCE) of TREE))
-             (SETQ LONODES (TREEGRAPHNODE (fetch (PCTNODE LO) of TREE)
-                                  NODEID NEWDEPTH))
-             (SETQ HINODES (TREEGRAPHNODE (fetch (PCTNODE HI) of TREE)
-                                  NODEID NEWDEPTH))
-             (SETQ BFNODE (NODECREATE (SETQ BFNODEID (CONS))
-                                 (fetch (PCTNODE BF) of TREE)
-                                 NIL NIL (LIST NODEID)))
-             (SETQ RANKNODE (NODECREATE (SETQ RANKNODEID (CONS))
-                                   (fetch (PCTNODE RANK) of TREE)
-                                   NIL NIL (LIST NODEID)))
-             [SETQ THISNODE (NODECREATE NODEID (fetch (PCTNODE CHNUM) of TREE)
-                                   NIL
-                                   (LIST (CAR LONODES)
-                                         BFNODEID RANKNODEID (CAR HINODES))
-                                   (AND PARENT (LIST PARENT]
-             (LIST (fetch NODEID of THISNODE)
-                   (APPEND (LIST THISNODE BFNODE RANKNODE)
-                          (CADR LONODES)
-                          (CADR HINODES])
-)
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE BTREENODE (
-                         (* ;; "An order-4 BTREE node for representing the piece table for TEdit.")
-
-                         DOWN1
-                         (DLEN1 FIXP)
-                         DOWN2
-                         (DLEN2 FIXP)
-                         DOWN3
-                         (DLEN3 FIXP)
-                         DOWN4
-                         (DLEN4 FIXP)
-                         DOWN5
-                         (DLEN5 FIXP)
-                         DOWN6
-                         (DLEN6 FIXP)
-                         DOWN7
-                         (DLEN7 FIXP)
-                         DOWN8
-                         (DLEN8 FIXP)
-                         SPARE5                              (* ; 
-                                         "Used only to hold the extra piece when we're overflowing")
-                         (SPARELEN FIXP)                     (* ; "So the code is easy and fast.")
-                         (COUNT BITS 4)                  (* ; "# of children of this node")
-                         (UPWARD XPOINTER)                   (* ; "Parent of this node, if any.")
-                         (TOTLEN FIXP)                       (* ; 
-                                                           "Total length of this tree and subtrees")
-                         ))
-)
-
-(/DECLAREDATATYPE 'BTREENODE
-       '(POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP POINTER FIXP 
-               POINTER FIXP POINTER FIXP (BITS 4)
-               XPOINTER FIXP)
-       '((BTREENODE 0 POINTER)
-         (BTREENODE 2 FIXP)
-         (BTREENODE 4 POINTER)
-         (BTREENODE 6 FIXP)
-         (BTREENODE 8 POINTER)
-         (BTREENODE 10 FIXP)
-         (BTREENODE 12 POINTER)
-         (BTREENODE 14 FIXP)
-         (BTREENODE 16 POINTER)
-         (BTREENODE 18 FIXP)
-         (BTREENODE 20 POINTER)
-         (BTREENODE 22 FIXP)
-         (BTREENODE 24 POINTER)
-         (BTREENODE 26 FIXP)
-         (BTREENODE 28 POINTER)
-         (BTREENODE 30 FIXP)
-         (BTREENODE 32 POINTER)
-         (BTREENODE 34 FIXP)
-         (BTREENODE 32 (BITS . 3))
-         (BTREENODE 36 XPOINTER)
-         (BTREENODE 38 FIXP))
-       '40)
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA )
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA )
-)
-(PUTPROPS PCTREE COPYRIGHT ("Venue & Xerox Corporation" 1990 1991 1993 1994 1995))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (3019 23506 (UPDATEPCNODES 3029 . 4116) (FINDPCNODE 4118 . 4350) (\FIRSTNODE 4352 . 4709
-) (\DELETETREE 4711 . 7192) (\INSERTTREE 7194 . 11815) (\LASTNODE 11817 . 12460) (\MATCHPCS 12462 . 
-13586) (\SPLITTREE 13588 . 20764) (\TEDIT.UPDATETREE 20766 . 22243) (\TEDIT.PIECE-CHNO 22245 . 22824) 
-(\TEDIT.SET-TOTLEN 22826 . 23504)) (23507 25947 (DISPTREE 23517 . 23973) (TREEGRAPHNODE 23975 . 25945)
-))))
-STOP
diff --git a/obsolete/library/new/TEDIT b/obsolete/library/new/TEDIT
deleted file mode 100644
index f05ba869..00000000
--- a/obsolete/library/new/TEDIT
+++ /dev/null
@@ -1,2226 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED " 4-May-95 10:37:05" {DSK}<lispcore>library>new>TEDIT.;5 139939 
-
-      changes to%:  (FNS \TEDIT.INSERT.PIECES TEDIT.COPY TEDIT.MOVE)
-                    (FILES TEDITCOMMAND TEDITFILE TEDITFNKEYS TEDITHISTORY TEDITLOOKS TEDITPAGE 
-                           TEDITWINDOW)
-
-      previous date%: "22-Mar-95 18:17:12" {DSK}<lispcore>library>new>TEDIT.;1)
-
-
-(* ; "
-Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT TEDITCOMS)
-
-(RPAQQ TEDITCOMS
-       [(FILES TEDITDECLS)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
-               (FILES (LOADCOMP)
-                      TEDITDECLS))
-        (FILES PCTREE TEXTOFD TEDITCOMMAND TEDITSCREEN TEDITABBREV TEDITLOOKS)
-        (VARS (TEDIT.TERMSA.FONTS NIL)
-              (TEDIT.TENTATIVE NIL)
-              (TEDIT.DEFAULT.PROPS NIL)
-              (TEDIT.STARTUP.MONITORLOCK (CREATE.MONITORLOCK 'TEDIT.STARTUP))
-              (TEDIT.RESTART.MENU (\CREATE.TEDIT.RESTART.MENU))
-                                                             (* ; 
-                                            "Original was (CREATE MENU ITEMS _ '(NewEditProcess)).")
-                                                             (* ; 
-                                                  "Changed by yabu.fx, for SUNLOADUP without DWIM.")
-              )
-        (GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS)
-        (FNS \TEDIT2 COERCETEXTOBJ TEDIT TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE 
-             TEDIT.DO.BLUEPENDINGDELETE TEDIT.INSERT TEDIT.KILL TEDIT.MAPLINES TEDIT.MAPPIECES 
-             TEDIT.MOVE TEDIT.QUIT TEDIT.STRINGWIDTH TEDIT.\INSERT TEXTOBJ TEXTSTREAM \TEDIT.INCLUDE
-             \TEDIT.INSERT.PIECES \TEDIT.MOVE.PIECEMAPFN \TEDIT.OBJECT.SHOWSEL \TEDIT.RESTARTFN 
-             \TEDIT.CHARDELETE \TEDIT.COPY.PIECEMAPFN \TEDIT.DELETE \TEDIT.DIFFUSE.PARALOOKS 
-             \TEDIT.FOREIGN.COPY? \TEDIT.QUIT \TEDIT.WORDDELETE \TEDIT1)
-        (P (MOVD? 'NILL 'OBJECTOUTOFTEDIT))
-                                                             (* ; 
-                                  "HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.")
-        (COMS (FNS \CREATE.TEDIT.RESTART.MENU))
-                                                             (* ; 
-                                                    "Added by yabu.fx, for SUNLOADUP without DWIM.")
-        (COMS                                                (* ; "Debugging functions")
-              (FNS PLCHAIN PRINTLINE SEEFILE))
-        (COMS                                                (* ; "Object-oriented editing")
-              (FNS TEDIT.INSERT.OBJECT TEDIT.EDIT.OBJECT TEDIT.FIND.OBJECT TEDIT.FIND.OBJECT.SUBTREE
-                   TEDIT.PUT.OBJECT TEDIT.GET.OBJECT TEDIT.OBJECT.CHANGED))
-        (FILES TEDITFIND TEDITHISTORY TEDITFILE TEDITWINDOW TEDITSELECTION IMAGEOBJ TFBRAVO TEDITHCPY
-               TEDITPAGE TEDITMENU TEDITFNKEYS)
-        (COMS                                                (* ; "TEDIT Support information")
-              (E (SETQ TEDITSYSTEMDATE (DATE)))
-              (VARS TEDITSYSTEMDATE (TEDITSUPPORT "TEditSupport.PA"))
-              (FNS MAKETEDITFORM)
-              (P (ADDTOVAR LAFITESPECIALFORMS ("TEdit Report" 'MAKETEDITFORM 
-                                                         "Report a problem with TEdit"))
-                 (SETQ LAFITEFORMSMENU NIL)))
-        (COMS                                                (* ; 
-                         "LISTFILES Interface, so the system can decide if a file is a TEdit file.")
-              (ADDVARS (PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1)
-                                              (EXTENSION (TEDIT])
-
-(FILESLOAD TEDITDECLS)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \SCRATCHLEN 64)
-
-
-(CONSTANTS (\SCRATCHLEN 64))
-)
-
-
-(FILESLOAD (LOADCOMP)
-       TEDITDECLS)
-)
-
-(FILESLOAD PCTREE TEXTOFD TEDITCOMMAND TEDITSCREEN TEDITABBREV TEDITLOOKS)
-
-(RPAQQ TEDIT.TERMSA.FONTS NIL)
-
-(RPAQQ TEDIT.TENTATIVE NIL)
-
-(RPAQQ TEDIT.DEFAULT.PROPS NIL)
-
-(RPAQ TEDIT.STARTUP.MONITORLOCK (CREATE.MONITORLOCK 'TEDIT.STARTUP))
-
-(RPAQ TEDIT.RESTART.MENU (\CREATE.TEDIT.RESTART.MENU))
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS TEDIT.TENTATIVE TEDIT.DEFAULT.PROPS)
-)
-(DEFINEQ
-
-(\TEDIT2
-  [LAMBDA (TEXT WINDOW UNSPAWNED)                       (* ; "Edited 12-Jun-90 17:51 by mitani")
-
-    (* ;; "Does the actual editing work, once TEDIT has OPENTEXTSTREAMed the thing to be edited.")
-
-    (\TEDIT.COMMAND.LOOP (fetch (TEXTSTREAM TEXTOBJ) of TEXT))
-                                                             (* ; "Run the editing engine")
-    (CLOSEW WINDOW)                                          (* ; "Close the edit window")
-    (\TEXTCLOSEF TEXT)                                       (* ; "Close the underlying files")
-    (replace (STREAM ACCESSBITS) of TEXT with BothBits)
-                                                             (* ; 
-                                                           "But leave the stream itself accessible")
-    (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-                'AFTERQUITFN)
-         (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-                        'AFTERQUITFN)
-                WINDOW TEXT))                                (* ; 
-                                             "Apply any post-window-close (and post-QUIT) function")
-    (COND
-       (UNSPAWNED                                            (* ; 
-                    "We're not a distinct process: Send back the edited text in some suitable form")
-              (COND
-                 ((NEQ (fetch (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM
-                                                                                   TEXTOBJ)
-                                                                          of TEXT))
-                       T)
-                  (PROG1 (fetch (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM
-                                                                                     TEXTOBJ)
-                                                                            of TEXT))
-                      (replace (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM
-                                                                                    TEXTOBJ)
-                                                                           of TEXT) with
-                                                                                        NIL)))
-                 ((STRINGP (fetch (TEXTOBJ TXTFILE) of (fetch (TEXTSTREAM TEXTOBJ
-                                                                                     ) of TEXT)))
-                  (COERCETEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-                         'STRINGP))
-                 (T TEXT])
-
-(COERCETEXTOBJ
-  [LAMBDA (STREAM TYPE OUTPUTSTREAM)                     (* ; "Edited 18-Apr-93 23:42 by jds")
-
-    (* ;; "Coerce the contents of the TEXOTBJ to be of the given type.  This is for making a string from a textobj, e.g.")
-
-    (PROG ((TEXTOBJ (COND
-                           ((type? STREAM STREAM)
-                            (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-                           (T STREAM)))
-           OFILE FMTFILE)
-          (OR (type? TEXTOBJ TEXTOBJ)
-              (\ILLEGAL.ARG TEXTOBJ))                        (* ; 
-                                                 "If we haven't got a TEXTOBJ, something is wrong.")
-          (RETURN (SELECTQ TYPE
-                      ((STRINGP STRING) 
-                           (AND (ILEQ (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)
-                                      65535)
-                                (PROG ((STR (ALLOCSTRING (fetch (TEXTOBJ TEXTLEN)
-                                                            of TEXTOBJ)))
-                                       PC
-                                       (CH# 1)
-                                       (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-                                       (DELTA 0)
-                                       PFILE)
-                                      (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB)
-                                                      0))
-                                      [WHILE PC
-                                         do (COND
-                                                   ((ATOM PC)(* ; 
-                                                           "It's the lastpiece atom -- do nothing.")
-                                                    (SETQ PC NIL))
-                                                   ((fetch CLINVISIBLE of (fetch
-                                                                                   (PIECE PLOOKS)
-                                                                                     of PC))
-
-                                 (* ;; "If the characters are invisible, do nothing.  HOWEVER, we have to shrink the final string to account for the characters we ignored.")
-
-                                                    (add DELTA (fetch (PIECE PLEN)
-                                                                      of PC)))
-                                                   ((fetch (PIECE PSTR) of PC)
-                                                    [OR (ZEROP (fetch (PIECE PLEN) of PC))
-                                                        (RPLSTRING STR CH# (SUBSTRING
-                                                                            (fetch (PIECE PSTR)
-                                                                               of PC)
-                                                                            1
-                                                                            (fetch (PIECE PLEN)
-                                                                               of PC]
-                                                    (add CH# (fetch (PIECE PLEN) of
-                                                                                         PC)))
-                                                   ((SETQ PFILE (fetch (PIECE PFILE) of
-                                                                                         PC))
-                                                    [COND
-                                                       ((NOT (OPENP PFILE))
-                                                        (SETQ PFILE (\TEDIT.REOPEN.STREAM STREAM 
-                                                                           PFILE]
-                                                    (SETFILEPTR PFILE (fetch (PIECE PFPOS)
-                                                                         of PC))
-                                                    (for C from CH# as I from 1
-                                                       to (fetch (PIECE PLEN) of PC)
-                                                       do (RPLCHARCODE STR C (BIN PFILE)))
-                                                    (add CH# (fetch (PIECE PLEN) of
-                                                                                         PC)))
-                                                   ((fetch (PIECE POBJ) of PC)
-                                                             (* ; "DO NOTHING FOR OBJECTS")
-                                                    (add CH# (fetch (PIECE PLEN) of
-                                                                                         PC))
-                                                    (add DELTA (fetch (PIECE PLEN)
-                                                                      of PC)))
-                                                   (T (ERROR "CANNOT GET TEXT FROM A 'PIECE.'" PC)))
-                                               (AND PC (SETQ PC (FETCH (PIECE NEXTPIECE)
-                                                                   OF PC]
-                                      [COND
-                                         ((ZEROP DELTA)      (* ; 
-                                                           "No change in the length;  do nothing.")
-                                          )
-                                         (T                  (* ; 
-                            "The string got shortened to account for invisible chars.  Chop it off")
-                                            (SETQ STR (SUBSTRING STR 1 (IDIFFERENCE
-                                                                        (fetch (TEXTOBJ
-                                                                                    TEXTLEN)
-                                                                           of TEXTOBJ)
-                                                                        DELTA]
-                                      (RETURN STR))))
-                      (STREAM (COND
-                                 ((type? STREAM (fetch (TEXTOBJ TXTFILE) of TEXTOBJ))
-                                  (OPENFILE (fetch (STREAM FULLNAME) of (fetch
-                                                                                 (TEXTOBJ TXTFILE
-                                                                                        )
-                                                                                   of TEXTOBJ))
-                                         'INPUT)
-                                  (replace (STREAM ACCESSBITS) of (fetch (TEXTOBJ
-                                                                                      TXTFILE)
-                                                                             of TEXTOBJ)
-                                     with ReadBit)))
-                              (\SETUPGETCH 1 TEXTOBJ)
-                              (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))
-                      (FILE [SETQ OFILE (OR (AND OUTPUTSTREAM (OPENP OUTPUTSTREAM 'OUTPUT))
-                                            (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW]
-                            (TEDIT.PUT.PCTB TEXTOBJ OFILE)
-                            (OR OUTPUTSTREAM (CLOSEF OFILE))
-                            OFILE)
-                      (SPLIT 
-                             (* ;; "I.e., Return 2 files, one with plain text, one with formatting info, such that concatenating them will do the right thing.")
-
-                             (SETQ OFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW))
-                             (SETQ FMTFILE (CAR (TEDIT.PUT.PCTB TEXTOBJ (\GETSTREAM OFILE
-                                                                               'BOTH)
-                                                       NIL T)))
-                             (CLOSEF OFILE)
-                             (CONS OFILE FMTFILE))
-                      NIL])
-
-(TEDIT
-  [LAMBDA (TEXT WINDOW DONTSPAWN PROPS)                  (* ; "Edited  3-Jun-88 14:27 by jds")
-
-    (* ;; "User entry to the text editor.  Takes an optional window to be used for editing")
-
-    (* ;; "DONTSPAWN => Don't try to create a new process for this edit.")
-
-    (PROG (PROC TEDITCREATEDWINDOW)                          (* ; 
-                                                      "Inlcude the default properties in the list.")
-          [COND
-             ((AND TEXT (ATOM TEXT))                         (* ; 
-                                      "Make sure the file exists before trying to open the window.")
-              (SETQ TEXT (OPENFILE TEXT 'INPUT 'OLD]
-          (RESETLST
-              [RESETSAVE NIL `(AND ,WINDOW (WINDOWPROP ,WINDOW 'TEXTOBJ NIL]
-              (WITH.MONITOR TEDIT.STARTUP.MONITORLOCK
-                  (COND
-                     ((NOT WINDOW)
-                      (SETQ TEDITCREATEDWINDOW T)
-                      (SETQ WINDOW (COND
-                                      [(OR (NOT TEDIT.DEFAULT.WINDOW)
-                                           (\TEDIT.ACTIVE.WINDOWP TEDIT.DEFAULT.WINDOW))
-                                       (TEDIT.CREATEW (COND
-                                                         ((AND TEXT (ATOM TEXT))
-                                                          (CONCAT 
-                                                              "Please specify an editing window for "
-                                                                 TEXT))
-                                                         (T 
-                                                    "Please specify a region for the editing window."
-                                                            ))
-                                              TEXT
-                                              (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS]
-                                      (T (\TEDIT.CREATEW.FROM.REGION (WINDOWPROP TEDIT.DEFAULT.WINDOW
-                                                                            'REGION)
-                                                TEXT
-                                                (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS)))
-                                                             (* ; "Replace the old title")
-                                         TEDIT.DEFAULT.WINDOW)))
-                      (WINDOWPROP WINDOW 'TEXTOBJ T)         (* ; 
-               "Mark the newly-created window reserved until the OPENTEXTSTREAM has done its work.")
-                      ))                                     (* ; 
-                    "mark that we created the window so that we know we can update the title, etc.")
-                  ))
-          [SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL (APPEND PROPS '(BEING-EDITED T]
-                                                             (* ; 
-                                                           "Connect the editor to the window")
-          (replace (TEXTOBJ TXTEDITING) of (TEXTOBJ TEXT) with T)
-                                                             (* ; "For the moment, mark the document as actively in edit. (so caret flashes when the window is first brought up.)")
-          [COND
-             (TEDITCREATEDWINDOW (TEXTPROP TEXT 'TEDITCREATEDWINDOW 'T]
-          (COND
-             (DONTSPAWN                                      (* ; 
-                                   "Either no processes running, or specifically not to spawn one.")
-                    (RETURN (\TEDIT2 TEXT WINDOW T)))
-             (T                                              (* ; "Spawn a process to do the edit.")
-                [SETQ PROC (ADD.PROCESS (LIST '\TEDIT2 (KWOTE TEXT)
-                                              WINDOW NIL)
-                                  'NAME
-                                  'TEdit
-                                  'RESTARTABLE
-                                  'HARDRESET
-                                  'RESTARTFORM
-                                  (LIST '\TEDIT.RESTARTFN (KWOTE TEXT)
-                                        WINDOW
-                                        (KWOTE PROPS]
-                (PROCESSPROP PROC 'WINDOW WINDOW)
-                (COND
-                   ((NOT (LISTGET (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS))
-                                'LEAVETTY))                  (* ; 
-                            "Unless he asked us to leave the tty where it is, TEdit should get it.")
-                    (TTY.PROCESS PROC)))
-                (RETURN PROC])
-
-(TEDIT.CHARWIDTH
-  [LAMBDA (CH FONT TERMSA)                                   (* jds "22-OCT-83 19:32")
-          
-          (* Returns the width of CH in FONT printed according to any special printing 
-          instructions in CHARTABLE TERMSA)
-
-    (COND
-       (TERMSA                                               (* There IS a TERMTABLE to account for)
-              (SELECTC (fetch CCECHO of (\SYNCODE TERMSA CH))
-                  (INDICATE.CCE (IPLUS (COND
-                                          ((IGREATERP CH 127)(* META character)
-                                           (SETQ CH (LOGAND CH 127))
-                                           (CHARWIDTH (CHARCODE %#)
-                                                  FONT))
-                                          (T 0))
-                                       (COND
-                                          ((ILESSP CH 32)    (* CONTROL character)
-                                           (SETQ CH (LOGOR CH 64))
-                                           (CHARWIDTH (CHARCODE ^)
-                                                  FONT))
-                                          (T 0))
-                                       (CHARWIDTH CH FONT)))
-                  (SIMULATE.CCE (SELCHARQ CH
-                                     ((EOL CR LF) 
-                                          (IMAX 6 (CHARWIDTH CH FONT)))
-                                     (ESCAPE (CHARWIDTH (CHARCODE $)
-                                                    FONT))
-                                     (BELL 0)
-                                     (TAB 36)
-                                     (CHARWIDTH CH FONT)))
-                  (REAL.CCE (CHARWIDTH CH FONT))
-                  (IGNORE.CCE 0)
-                  (SHOULDNT)))
-       (T (* The usual case is to treat every character as a graphic.)
-          (SELCHARQ CH
-               (CR (IMAX 6 (CHARWIDTH CH FONT)))
-               (TAB 36)
-               (CHARWIDTH CH FONT])
-
-(TEDIT.COPY
-  [LAMBDA (FROM TO)                   (* ; 
-                                                "Edited  2-May-95 12:23 by sybalsky:mv:envos")
-    (SETQ TEDIT.COPY.PENDING NIL)                            (* ; 
-                                                "First, Turn off the global flag that got us here.")
-    (COND
-       ((NOT (AND FROM (fetch (SELECTION SET) of FROM)))
-                                                             (* ; 
-                                                           "There MUST be a source selected first.")
-        (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of TO)
-               "Copy source selection hasn't been set yet." T))
-       ((ZEROP (fetch (SELECTION DCH) of FROM))      (* ; 
-                 "The source is empty.  Just turn off the selection hilite and ignore the request.")
-        (\SHOWSEL FROM NIL NIL))
-       ((fetch (TEXTOBJ TXTREADONLY) of (fetch (SELECTION \TEXTOBJ) of TO))
-                                                             (* ; "The target is read-only.  Don't do anything except turn off the selection highlighting and ignore the request.")
-        (\SHOWSEL FROM NIL NIL))
-       (T (\SHOWSEL FROM NIL NIL)                            (* ; 
-                               "Before all else, make sure the copy source selection is turned off")
-          (replace (SELECTION SET) of FROM with NIL)
-          (COND
-             ((AND TO (fetch (SELECTION SET) of TO)) (* ; 
-                                                   "Can only do copy if there's a target selection")
-              (PROG ((TOOBJ (fetch (SELECTION \TEXTOBJ) of TO))
-                     (FROMOBJ (fetch (SELECTION \TEXTOBJ) of FROM))
-                     (CROSSCOPY (NEQ (fetch (SELECTION \TEXTOBJ) of FROM)
-                                     (fetch (SELECTION \TEXTOBJ) of TO)))
-                     TOLEN LEN INSPC INSPC# PC NPC PCCH NPCCH OPLEN EVENT REPLACING INSERTCH# PCLST 
-                     OBJ COPYFN UNDOCHAIN)
-                    (SETQ PCLST (TEDIT.SELECTED.PIECES FROMOBJ FROM CROSSCOPY (FUNCTION 
-                                                                               \TEDIT.COPY.PIECEMAPFN
-                                                                               )
-                                       FROMOBJ TOOBJ))       (* ; 
-                                                           "Get the list of pieces to be copied")
-                    (SETQ REPLACING (TEDIT.DO.BLUEPENDINGDELETE TO TOOBJ))
-                                                             (* ; "Do any blue-pending-delete")
-                    (SETQ TOLEN (fetch (TEXTOBJ TEXTLEN) of TOOBJ))
-                    (\SHOWSEL TO NIL NIL)                    (* ; 
-                                                           "NOW turn off the target selection.")
-                    [COND
-                       ((EQ (fetch (SELECTION POINT) of TO)
-                            'LEFT)
-                        (SETQ INSERTCH# (fetch (SELECTION CH#) of TO)))
-                       (T (SETQ INSERTCH# (IMIN (fetch (SELECTION CHLIM) of TO)
-                                                (ADD1 TOLEN] (* ; 
-                                                           "Figure out where to do the insertion.")
-                    (COND
-                       ((AND (fetch (TEXTOBJ FORMATTEDP) of FROMOBJ)
-                             (NOT (fetch (TEXTOBJ FORMATTEDP) of TOOBJ)))
-                                                             (* ; 
-                            "The source is formatted and the target isn't.  Give the guy a choice.")
-                                                             (* ; 
-                                                   "For now, convert the target file to formatted.")
-                        (\TEDIT.CONVERT.TO.FORMATTED TOOBJ)))
-                    (SETQ UNDOCHAIN (\TEDIT.INSERT.PIECES TOOBJ INSERTCH# PCLST
-                                           (SETQ LEN (IDIFFERENCE (fetch (SELECTION CHLIM)
-                                                                     of FROM)
-                                                            (fetch (SELECTION CH#) of FROM)))
-                                           NIL NIL CROSSCOPY NIL T))
-                    (bind OBJ AFTERCOPYFN for PC in PCLST
-                       when [AND (SETQ OBJ (fetch (PIECE POBJ) of PC))
-                                     (SETQ AFTERCOPYFN (IMAGEOBJPROP OBJ 'AFTERCOPYFN]
-                       do (APPLY* AFTERCOPYFN OBJ))
-                    (SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TOOBJ))
-                    (\TEDIT.HISTORYADD TOOBJ (create TEDITHISTORYEVENT
-                                                    THACTION _ (COND
-                                                                  (REPLACING 'Replace)
-                                                                  (T 'Copy))
-                                                    THLEN _ LEN
-                                                    THCH# _ INSERTCH#
-                                                    THFIRSTPIECE _ (LIST UNDOCHAIN)
-                                                    THOLDINFO _ (AND REPLACING EVENT)))
-                                                             (* ; 
-                                                          "Make a history-list entry for the COPY.")
-                    (replace (TEXTOBJ \DIRTY) of TOOBJ with T)
-                                                             (* ; "Mark the document changed")
-                    (replace (TEXTOBJ TEXTLEN) of TOOBJ with (IPLUS LEN TOLEN))
-                                                             (* ; "Set the new length")
-                    (\FIXILINES TOOBJ TO INSERTCH# LEN TOLEN)(* ; "Fix LINES and SELs")
-                    [COND
-                       ((EQ (fetch (TEXTOBJ FORMATTEDP) of TOOBJ)
-                            (fetch (TEXTOBJ FORMATTEDP) of FROMOBJ))
-                                                             (* ; 
-                           "Either both of the files are formatted or neither is.  This case is OK")
-                        )
-                       ((fetch (TEXTOBJ FORMATTEDP) of TOOBJ)
-                                                             (* ; 
-                     "The source wasn't formatted, but the target is.  Go convert the copied text.")
-                        (\TEDIT.CONVERT.TO.FORMATTED TOOBJ INSERTCH# (IPLUS INSERTCH# LEN]
-                    (TEDIT.UPDATE.SCREEN TOOBJ)              (* ; "Refresh the display")
-                    (replace (SELECTION CH#) of TO with INSERTCH#)
-                                                             (* ; "Correct the target selection")
-                    (replace (SELECTION CHLIM) of TO with (IPLUS INSERTCH# LEN))
-                    (replace (SELECTION DCH) of TO with LEN)
-                    (replace (SELECTION DX) of TO with 0)
-                    (replace (SELECTION POINT) of TO with 'RIGHT)
-                                                             (* ; 
-                        "(replace CARETLOOKS of TOOBJ with (\TEDIT.GET.INSERT.CHARLOOKS TOOBJ TO))")
-                                                             (* ; 
-                                            "Make any later type-in look like what we just copied.")
-                    (replace (TEXTOBJ \INSERTPCVALID) of TOOBJ with NIL)
-                                                             (* ; 
-           "And make sure that the pieces copied never have their strings smashed by back spacing.")
-                    (replace (TEXTOBJ \INSERTPCVALID) of FROMOBJ with NIL)
-                    (\FIXSEL TO TOOBJ)
-                    (\SHOWSEL TO NIL T)))
-             (T                                              (* ; 
-                                                         "There is no target selection -- complain")
-                (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of FROM)
-                       "Please select a destination for the copy first." T])
-
-(TEDIT.DELETE
-  [LAMBDA (STREAM SEL LEN LEAVECARETLOOKS)              (* ; "Edited 12-Jun-90 17:49 by mitani")
-
-    (* ;; "DELETE THE CHARACTERS SPECIFIED FROM THE MAIN TEXT.")
-
-    (* ;; "If LEAVECARETLOOKS is non-NIL, the selection will NOT be set up to do the right thing with type-in.  This can save time in inner loops.")
-
-    (PROG ((TEXTOBJ (TEXTOBJ STREAM)))
-          [COND
-             ((FIXP SEL)
-              (TEDIT.SETSEL STREAM SEL LEN NIL NIL LEAVECARETLOOKS)
-              (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ]
-          (OR SEL (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)))
-          (\TEDIT.DELETE SEL TEXTOBJ])
-
-(TEDIT.DO.BLUEPENDINGDELETE
-  [LAMBDA (SEL TEXTOBJ)                                  (* ; "Edited 29-May-91 18:21 by jds")
-                                                             (* Check for blue-pending-delete, 
-                                                           and do it if it's there.)
-                                                             (* Return T if the deletion was 
-                                                           made. For people who need to know)
-    (COND
-       ((fetch (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ)
-                                                             (* If he's in a Blue-pending-delete 
-                                                           state, delete the selection.)
-        (PROG1 (fetch (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ)
-            (COND
-               ((NOT (ZEROP (fetch (SELECTION DCH) of SEL)))
-                                                             (* There really IS something to 
-                                                           delete.)
-                (\SHOWSEL SEL NIL NIL)                       (* Turn off the selection)
-                (\DELETECH (fetch (SELECTION CH#) of SEL)
-                       (fetch (SELECTION CHLIM) of SEL)
-                       (fetch (SELECTION DCH) of SEL)
-                       TEXTOBJ)                              (* Delete the characters.)
-                (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ)
-                       SEL
-                       (fetch (SELECTION CH#) of SEL)
-                       (fetch (SELECTION CHLIM) of SEL)
-                       TEXTOBJ)                              (* Fix up any line descriptors to 
-                                                           reflect the deletion.)
-                (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)      (* Make it a normal selection again.)
-                (replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CH#)
-                                                                      of SEL))
-
-         (* Fix up the selection, so that it is 0 wide, where the old text used to be.)
-
-                (replace (SELECTION DCH) of SEL with 0)
-                (replace (SELECTION POINT) of SEL with 'LEFT)
-                (\FIXSEL SEL TEXTOBJ)                        (* Make its line descriptors &c 
-                                                           reflect the new reality)
-                (\SHOWSEL SEL NIL T)                         (* And turn it back on.)
-                )
-               (T                                            (* Don't do it, since it's 
-                                                           zero-width. However, DO turn off the 
-                                                           blue-pendingness of it.)
-                  (TEDIT.RESET.EXTEND.PENDING.DELETE SEL))))])
-
-(TEDIT.INSERT
-  [LAMBDA (STREAM TEXT CH#ORSEL LOOKS DONTSCROLL)        (* ; "Edited 29-May-91 18:21 by jds")
-                                                             (* ; 
-                  "Insert TEXT (character, litatom or string) at the appropriate spot in the text.")
-    (SETQ STREAM (TEXTSTREAM STREAM))
-    [COND
-       ((FIXP CH#ORSEL)                                      (* ; 
-                                                           "He gave us a ch# to insert before")
-        (TEDIT.SETSEL STREAM CH#ORSEL 1 'LEFT]
-    [COND
-       ((LITATOM TEXT)
-        (SETQ TEXT (MKSTRING TEXT]
-    [OR (type? SELECTION CH#ORSEL)
-        (SETQ CH#ORSEL (fetch (TEXTOBJ SEL) of (fetch (TEXTSTREAM TEXTOBJ)
-                                                              of STREAM]
-    (COND
-       ((AND (STRINGP TEXT)
-             (ZEROP (NCHARS TEXT)))                          (* ; 
-                      "Can't insert an empty string sensibly.  It confuses the screen update code.")
-        NIL)
-       [(AND CH#ORSEL (fetch (SELECTION SET) of CH#ORSEL))
-        (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-               CH# LINE XPOINT OTEXTLEN DS LINES CHARS BLANKSEEN CRSEEN)
-              (TEDIT.DO.BLUEPENDINGDELETE CH#ORSEL TEXTOBJ)
-                                                             (* ; 
-                  "If the selected text was for pending delete, delete it before doing the insert.")
-              (COND
-                 (LOOKS                                      (* ; 
-                                         "If looks for this insertion were specified, set them up.")
-                        (TEDIT.CARETLOOKS STREAM LOOKS)))
-              (SETQ OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-                                                             (* ; 
-                               "The PRE-INSERT text length, for starting the screen update process")
-              (COND
-                 ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-
-                  (* ;; "If this text is in a window, move it so the insertion point is on-screen, then turn off the selection highlight")
-
-                  (COND
-                     ((NOT DONTSCROLL)                       (* ; 
-                   "If DONTSCROLL is T, then don't bother scrolling the window to show the change.")
-                      (TEDIT.NORMALIZECARET TEXTOBJ CH#ORSEL)))
-                  (\SHOWSEL CH#ORSEL NIL NIL)))
-              (SETQ CH# (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of CH#ORSEL)
-                                    (LEFT (fetch (SELECTION CH#) of CH#ORSEL))
-                                    (RIGHT (IMIN (fetch (SELECTION CHLIM) of CH#ORSEL)
-                                                 (ADD1 (fetch (TEXTOBJ TEXTLEN) of 
-                                                                                              TEXTOBJ
-                                                              ))))
-                                    NIL)))
-              (SETQ XPOINT (SELECTQ (fetch (SELECTION POINT) of CH#ORSEL)
-                               (LEFT (fetch (SELECTION X0) of CH#ORSEL))
-                               (RIGHT (fetch (SELECTION XLIM) of CH#ORSEL))
-                               NIL))
-              [COND
-                 [(type? STRINGP TEXT)                   (* ; 
-              "It's a string: Count the characters and Insert them one by one into the text stream")
-                  (SETQ CHARS (NCHARS TEXT))
-                  (for ACHAR instring TEXT as NCH# from CH# by 1
-                     do (SELCHARQ ACHAR
-                                 ((CR %#^M 1,CR) 
-                                      (SETQ CRSEEN T)
-                                      (\INSERTCR ACHAR NCH# TEXTOBJ))
-                                 (SPACE (SETQ BLANKSEEN T)
-                                        (\INSERTCH ACHAR NCH# TEXTOBJ))
-                                 (\INSERTCH ACHAR NCH# TEXTOBJ]
-                 (T                                          (* ; 
-                                                         "It's a singe character.  Just insert it.")
-                    (SETQ CHARS 1)
-                    (SELCHARQ TEXT
-                         ((CR %#^M 1,CR) 
-                              (SETQ CRSEEN T)
-                              (\INSERTCR TEXT CH# TEXTOBJ))
-                         (SPACE (SETQ BLANKSEEN T)
-                                (\INSERTCH TEXT CH# TEXTOBJ))
-                         (\INSERTCH TEXT CH# TEXTOBJ]
-              (\FIXILINES TEXTOBJ CH#ORSEL CH# CHARS OTEXTLEN)
-                                                             (* ; 
-                                                   "Fix up the line descriptors and the Selection.")
-              (COND
-                 ((NOT (fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ STREAM)))
-                                                             (* ; "Update the edit window.")
-                  (TEDIT.INSERT.UPDATESCREEN TEXT CH# CHARS XPOINT TEXTOBJ CH#ORSEL OTEXTLEN 
-                         BLANKSEEN CRSEEN DONTSCROLL]
-       ((NOT (fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ STREAM)))
-        (TEDIT.PROMPTPRINT (TEXTOBJ STREAM)
-               "Please select a place for the insertion." T])
-
-(TEDIT.KILL
-  [LAMBDA (STREAM)                                      (* ; "Edited 12-Jun-90 17:49 by mitani")
-                                                             (* Force the edit session supported 
-                                                           by STREAM to terminate, and to 
-                                                           return VALUE)
-    (COND
-       ((type? STREAM STREAM)                            (* If he gave us a textofd, get the 
-                                                           textobj)
-        (SETQ STREAM (fetch (TEXTSTREAM TEXTOBJ) of STREAM)))
-       [(WINDOWP STREAM)                                     (* Take a window, and do the obvious 
-                                                           with it.)
-        (SETQ STREAM (WINDOWPROP STREAM 'TEXTOBJ]
-       ((type? TEXTOBJ STREAM)                           (* A Textobj is just fine)
-        )
-       (T                                                    (* Anything else is ungood, 
-                                                           double-plus)
-          (\ILLEGAL.ARG STREAM)))
-    (replace (TEXTOBJ EDITFINISHEDFLG) of STREAM with T)
-    (PROG (TEDW TEDPROC)
-          (AND (SETQ TEDW (CAR (fetch (TEXTOBJ \WINDOW) of STREAM)))
-               [PROCESSP (SETQ TEDPROC (WINDOWPROP TEDW 'PROCESS]
-               (NEQ TEDPROC (THIS.PROCESS))
-               (DEL.PROCESS TEDPROC)
-               (TEDIT.DEACTIVATE.WINDOW TEDW])
-
-(TEDIT.MAPLINES
-  [LAMBDA (TEXTOBJ FN)                               (* ; "Edited 29-May-91 18:19 by jds")
-
-         (* Go thru the visible lines in a textobj and call a mapping fn on them)
-
-         (* FN has 2 args%: the LINEDESCRIPTOR, and a VISIBLEFLG to say if the line is 
-       visible on the screen.)
-
-    (bind (LINE _ (fetch (LINEDESCRIPTOR NEXTLINE) of (fetch (TEXTOBJ LINES)
-                                                                     of TEXTOBJ)))
-           (BOT _ (fetch (TEXTOBJ WBOTTOM) of TEXTOBJ))
-           [TOP _ (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION (\TEDIT.PRIMARYW TEXTOBJ]
-       while LINE do (COND
-                                ((EQ (APPLY* FN LINE (AND (ILESSP (fetch (LINEDESCRIPTOR YBOT)
-                                                                     of LINE)
-                                                                 TOP)
-                                                          (IGEQ (fetch (LINEDESCRIPTOR YBOT)
-                                                                   of LINE)
-                                                                BOT)))
-                                     'STOP)
-                                 (RETURN)))
-                            (SETQ LINE (fetch (LINEDESCRIPTOR NEXTLINE) of LINE])
-
-(TEDIT.MAPPIECES
-  [LAMBDA (TEXTOBJ FN FNARG)                         (* ; "Edited 22-Apr-93 16:02 by jds")
-
-    (* ;; "Go thru all the pieces in a document, applying a function to them serially")
-
-    (* ;; "FN is a function of 3 args (PIECE CH#-of-1st-char-in-piece PIECE# in table FNARG)")
-
-    (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-           (CH# 1)
-           PCNODE PC)
-          (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB)
-                          0))
-          (OR (ATOM PC)
-              (RETURN (for I from 1 while PC
-                         do [COND
-                                   ((EQ (APPLY* FN CH# PC I FNARG)
-                                        'STOP)
-                                    (RETURN (LIST CH# PC I]
-                               (add CH# (fetch (PIECE PLEN) of PC))
-                               (SETQ PC (fetch (PIECE NEXTPIECE) of PC])
-
-(TEDIT.MOVE
-  [LAMBDA (FROM TO)                   (* ; 
-                                                "Edited  2-May-95 12:24 by sybalsky:mv:envos")
-
-    (* ;; 
-  "Move the text described by the selection FROM to the place described by the selection TO")
-
-    (SETQ TEDIT.MOVE.PENDING NIL)                            (* ; 
-                                                "First, Turn off the global flag that got us here.")
-    (COND
-       ((NOT (AND FROM (fetch (SELECTION SET) of FROM)))
-                                                             (* ; 
-                                                           "There MUST be a source selected first.")
-        (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of TO)
-               "Move source selection hasn't been set yet." T))
-       ((ZEROP (fetch (SELECTION DCH) of FROM))      (* ; 
-                                                "The source selection is empty.  Just turn it off.")
-        (\SHOWSEL FROM NIL NIL))
-       ((fetch (TEXTOBJ TXTREADONLY) of (fetch (SELECTION \TEXTOBJ) of TO))
-                                                             (* ; 
-                                                           "The target is read-only.  Skip it..")
-        (\SHOWSEL FROM NIL NIL))
-       (T (\SHOWSEL FROM NIL NIL)                            (* ; 
-                               "Before all else, make sure the copy source selection is turned off")
-          (COND
-             ((AND TO (fetch (SELECTION SET) of TO)) (* ; 
-                                                   "Can only do copy if there's a target selection")
-              (PROG ((TOOBJ (fetch (SELECTION \TEXTOBJ) of TO))
-                     (FROMOBJ (fetch (SELECTION \TEXTOBJ) of FROM))
-                     (TOLEN (fetch (TEXTOBJ TEXTLEN) of (fetch (SELECTION \TEXTOBJ)
-                                                                       of TO)))
-                     (TOPCTB (fetch (TEXTOBJ PCTB) of (fetch (SELECTION \TEXTOBJ)
-                                                                     of TO)))
-                     (FROMPCTB (fetch (TEXTOBJ PCTB) of (fetch (SELECTION \TEXTOBJ)
-                                                                       of FROM)))
-                     (CROSSCOPY (NEQ (fetch (SELECTION \TEXTOBJ) of FROM)
-                                     (fetch (SELECTION \TEXTOBJ) of TO)))
-                     LEN INSPC INSPC# PC NPC PCCH NPCCH OPLEN EVENT REPLACING INSERTCH# PCLST OBJ 
-                     COPYFN UNDOCHAIN)                       (* ; "Find the insertion point")
-                    (SETQ PCLST (TEDIT.SELECTED.PIECES FROMOBJ FROM CROSSCOPY (FUNCTION 
-                                                                               \TEDIT.MOVE.PIECEMAPFN
-                                                                               )
-                                       FROMOBJ TOOBJ))       (* ; 
-                                                "Grab the pieces that reflect the source selection")
-                    (SETQ REPLACING (TEDIT.DO.BLUEPENDINGDELETE TO TOOBJ))
-                                                             (* ; "Do any blue-pending-delete")
-                    (SETQ TOPCTB (fetch (TEXTOBJ PCTB) of TOOBJ))
-                                                             (* ; 
-                                                           "Get the new PCTB and text length")
-                    (SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TOOBJ))
-                    (SETQ LEN (IDIFFERENCE (fetch (SELECTION CHLIM) of FROM)
-                                     (fetch (SELECTION CH#) of FROM)))
-                    (\DELETECH (fetch (SELECTION CH#) of FROM)
-                           (fetch (SELECTION CHLIM) of FROM)
-                           (fetch (SELECTION DCH) of FROM)
-                           FROMOBJ)                          (* ; 
-                                                           "Now delete the text from its old place")
-                    (\FIXDLINES (fetch (TEXTOBJ LINES) of FROMOBJ)
-                           FROM
-                           (fetch (SELECTION CH#) of FROM)
-                           (fetch (SELECTION CHLIM) of FROM)
-                           FROMOBJ)
-                    (SETQ TOLEN (fetch (TEXTOBJ TEXTLEN) of TOOBJ))
-                    (\SHOWSEL TO NIL NIL)                    (* ; 
-                                                           "NOW turn off the target selection.")
-                    (replace (SELECTION SET) of FROM with NIL)
-                    [COND
-                       ((EQ (fetch (SELECTION POINT) of TO)
-                            'LEFT)
-                        (SETQ INSERTCH# (fetch (SELECTION CH#) of TO)))
-                       (T (SETQ INSERTCH# (fetch (SELECTION CHLIM) of TO]
-                                                             (* ; 
-                                                           "Figure out where to do the insertion.")
-                    (\TEDIT.INSERT.PIECES TOOBJ INSERTCH# PCLST LEN NIL NIL CROSSCOPY)
-                                                             (* ; 
-                               "Get the pieces that actually got inserted, so we can UNDO the move")
-
-               (* ;; "Keep the target from sharing a piece with type-in by accident:")
-
-                    (replace (TEXTOBJ \INSERTPCVALID) of TOOBJ with NIL)
-
-               (* ;; "Keep \DELETECH from playing clever games with the piece if it's new type-in: Don't let it be reclaimed by the deletion:")
-
-                    (replace (TEXTOBJ \INSERTPCVALID) of FROMOBJ with NIL)
-                    (replace (TEXTOBJ \INSERTPC) of FROMOBJ with NIL)
-                    (\TEDIT.HISTORYADD TOOBJ (create TEDITHISTORYEVENT
-                                                    THTEXTOBJ _ TOOBJ
-                                                    THACTION _ (COND
-                                                                  (REPLACING 'ReplaceMove)
-                                                                  (T 'Move))
-                                                    THLEN _ LEN
-                                                    THCH# _ INSERTCH#
-                                                    THFIRSTPIECE _ (LIST PCLST)
-                                                    THAUXINFO _ FROMOBJ
-                                                    THOLDINFO _ (fetch (SELECTION CH#)
-                                                                   of FROM)))
-                                                             (* ; 
-                                                          "Make a history-list entry for the COPY.")
-                    (replace (TEXTOBJ \DIRTY) of TOOBJ with T)
-                                                             (* ; "Mark the document changed")
-                    (replace (TEXTOBJ TEXTLEN) of TOOBJ with (IPLUS LEN TOLEN))
-                                                             (* ; "Set the new length")
-                    (\FIXILINES TOOBJ TO INSERTCH# LEN TOLEN)(* ; "Fix LINES and SELs")
-                    (COND
-                       ((EQ (fetch (TEXTOBJ FORMATTEDP) of TOOBJ)
-                            (fetch (TEXTOBJ FORMATTEDP) of FROMOBJ))
-                                                             (* ; 
-                           "Either both of the files are formatted or neither is.  This case is OK")
-                        )
-                       ((fetch (TEXTOBJ FORMATTEDP) of TOOBJ)
-                                                             (* ; 
-                     "The source wasn't formatted, but the target is.  Go convert the copied text.")
-                        (\TEDIT.CONVERT.TO.FORMATTED TOOBJ INSERTCH# (IPLUS INSERTCH# LEN)))
-                       (T                                    (* ; 
-                            "The source is formatted and the target isn't.  Give the guy a choice.")
-                                                             (* ; 
-                                                   "For now, convert the target file to formatted.")
-                          (\TEDIT.CONVERT.TO.FORMATTED TOOBJ)))
-                    (TEDIT.UPDATE.SCREEN FROMOBJ)
-                    (TEDIT.UPDATE.SCREEN TOOBJ)              (* ; "Refresh the display")
-                    (replace (SELECTION CH#) of TO with INSERTCH#)
-                                                             (* ; "Correct the target selection")
-                    (replace (SELECTION CHLIM) of TO with (IPLUS INSERTCH# LEN))
-                    (replace (SELECTION DCH) of TO with LEN)
-                    (replace (SELECTION DX) of TO with 0)
-                    (replace (SELECTION POINT) of TO with 'RIGHT)
-                    (COND
-                       ((NEQ TO FROM)
-                        (\FIXSEL FROM FROMOBJ)
-                        (\FIXSEL (fetch (TEXTOBJ SEL) of FROMOBJ)
-                               FROMOBJ)))
-                    (\FIXSEL TO TOOBJ)
-                    (\SHOWSEL TO NIL T)))
-             (T                                              (* ; 
-                                                         "There is no target selection -- complain")
-                (TEDIT.PROMPTPRINT (fetch (SELECTION \TEXTOBJ) of FROM)
-                       "Please select a destination for the MOVE first." T])
-
-(TEDIT.QUIT
-  [LAMBDA (STREAM VALUE)                                (* ; "Edited 12-Jun-90 17:49 by mitani")
-
-    (* ;; "Force the edit session supported by STREAM to terminate, and to return VALUE")
-
-    (COND
-       ((type? STREAM STREAM)                            (* ; 
-                                                         "If he gave us a textofd, get the textobj")
-        (SETQ STREAM (fetch (TEXTSTREAM TEXTOBJ) of STREAM)))
-       ((type? TEXTOBJ STREAM)                           (* ; "A Textobj is just fine")
-        )
-       (T                                                    (* ; 
-                                                           "Anything else is ungood, double-plus")
-          (\ILLEGAL.ARG STREAM)))
-    (replace (TEXTOBJ EDITFINISHEDFLG) of STREAM with (OR VALUE T))
-                                                             (* ; 
-                                                  "tell the command loop to stop next time through")
-    (PROG (MAINW)
-          (COND
-             ([AND (fetch (TEXTOBJ \WINDOW) of STREAM)
-                   (NEQ (SETQ MAINW (\TEDIT.PRIMARYW STREAM))
-                        (PROCESSPROP (TTY.PROCESS)
-                               'WINDOW]
-
-              (* ;; "there is a main window of the stream, and it is not the window of the tty process, so give it the tty")
-
-              (TTY.PROCESS (WINDOWPROP MAINW 'PROCESS))
-              (AND (NEQ (TTY.PROCESS)
-                        (THIS.PROCESS))
-                   (until [OR (NOT (WINDOWPROP MAINW 'PROCESS))
-                                  (PROCESS.FINISHEDP (WINDOWPROP MAINW 'PROCESS] do 
-                                                             (* ; 
-                  "Wait until the Edit process has had a chance to go away before continuing here.")
-                                                                                       (DISMISS])
-
-(TEDIT.STRINGWIDTH
-  [LAMBDA (STR FONT TERMSA)                                  (* jds "19-AUG-83 14:40")
-    (COND
-       (TERMSA 
-          
-          (* We have a terminal table to take account of.
-          Do so.)
-
-              (for CH instring STR sum (TEDIT.CHARWIDTH CH FONT TERMSA)))
-       (T                                                    (* Just use the native character 
-                                                             widths)
-          (for CH instring STR sum (SELCHARQ CH
-                                        (TAB 36)
-                                        (CHARWIDTH CH FONT])
-
-(TEDIT.\INSERT
-  [LAMBDA (CH SEL STREAM)                                (* ; "Edited 29-May-91 18:22 by jds")
-                                                             (* Insert the character CH at the 
-                                                           appropriate spot in the text.)
-    (DECLARE (LOCALVARS . T))
-    (PROG [(TEXTOBJ (COND
-                           ((type? STREAM STREAM)        (* If we got a STREAM, change it 
-                                                           into a textobj)
-                            (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-                           (T STREAM]
-          (COND
-             ((NOT (AND SEL (fetch (SELECTION SET) of SEL)))
-              (TEDIT.PROMPTPRINT TEXTOBJ "Please select a place for the insertion." T)
-              (RETURN)))
-          (COND
-             ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-
-         (* There is a window; make sure the insert point is on-screen, and turn off any 
-       highlighted selection)
-
-              (TEDIT.NORMALIZECARET TEXTOBJ SEL)
-              (\SHOWSEL SEL NIL NIL)))
-          (PROG ((CH# (TEDIT.GETPOINT STREAM SEL))
-                 (XPOINT (SELECTQ (fetch (SELECTION POINT) of SEL)
-                             (LEFT (fetch (SELECTION X0) of SEL))
-                             (RIGHT (fetch (SELECTION XLIM) of SEL))
-                             NIL))
-                 (OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)))
-                (SELCHARQ CH
-                     ((CR %#^M 1,CR)                         (* This was a CR. Go do the para 
-                                                           breaking as needed)
-                          (\INSERTCR CH CH# TEXTOBJ))
-                     (\INSERTCH CH CH# TEXTOBJ))
-                (\FIXILINES TEXTOBJ SEL CH# 1 OTEXTLEN)
-                (TEDIT.INSERT.UPDATESCREEN CH CH# 1 XPOINT TEXTOBJ SEL OTEXTLEN NIL NIL NIL T])
-
-(TEXTOBJ
-  [LAMBDA (STREAM)                                           (* jds "11-Jul-85 12:06")
-                                                             (* Convert from a text stream to the 
-                                                             associated textobj)
-    (COND
-       ((type? TEXTOBJ STREAM)                               (* It's already a TEXTOBJ)
-        STREAM)
-       ((AND (type? STREAM STREAM)
-             (fetch (TEXTSTREAM TEXTOBJ) of STREAM)
-             (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)))
-                                                             (* It's a TEXTSTREAM)
-        (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-       ((AND (PROCESSP STREAM)
-             (PROCESS.WINDOW STREAM))                        (* It's an edit PROCESS)
-        (WINDOWPROP (PROCESS.WINDOW STREAM)
-               'TEXTOBJ))
-       [(AND (WINDOWP STREAM)
-             (WINDOWPROP STREAM 'TEXTOBJ]
-       [(AND (DISPLAYSTREAMP STREAM)
-             (WINDOWPROP STREAM 'TEXTOBJ]
-       ((\ILLEGAL.ARG STREAM])
-
-(TEXTSTREAM
-  [LAMBDA (STREAM)                                      (* ; "Edited 12-Jun-90 17:50 by mitani")
-                                                             (* Force a textobj or stream to be a 
-                                                           stream)
-    (COND
-       ((AND (type? STREAM STREAM)
-             (fetch (TEXTSTREAM TEXTOBJ) of STREAM)
-             (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)))
-                                                             (* It's a stream, and is really a 
-                                                           TEXT stream. Just return it.)
-        STREAM)
-       ((type? TEXTOBJ STREAM)                           (* It's a TEXTOBJ, so grab the 
-                                                           stream hint field and return that.)
-        (fetch (TEXTOBJ STREAMHINT) of STREAM))
-       ((AND (PROCESSP STREAM)
-             (PROCESS.WINDOW STREAM))                        (* It's an edit process, so grab the 
-                                                           text stream from the edit window.)
-        (WINDOWPROP (PROCESS.WINDOW STREAM)
-               'TEXTSTREAM))
-       [(AND (WINDOWP STREAM)
-             (WINDOWPROP STREAM 'TEXTSTREAM]
-       [(AND (DISPLAYSTREAMP STREAM)
-             (WINDOWPROP STREAM 'TEXTSTREAM]
-       ((\ILLEGAL.ARG STREAM)                                (* Not a reasonable coercion to the 
-                                                           text stream. Punt.)
-        ])
-
-(\TEDIT.INCLUDE
-  [LAMBDA (TEXTOBJ FILE START END)                   (* ; "Edited 29-May-91 18:22 by jds")
-
-         (* A NATIVE text includer%: Includes part of a file, without checking to see if 
-       it's a bravo file, a TEdit file or whatever.)
-                                                             (* (PROG ((LEN (IDIFFERENCE
-                                                           (OR END (GETEOFPTR FILE))
-                                                           (OR START 0))) (SEL
-                                                           (fetch (TEXTOBJ SEL) of TEXTOBJ)) 
-                                                           NPC) (SETQ NPC (create PIECE PFILE _
-                                                           (\GETOFD FILE (QUOTE INPUT)) PFPOS _
-                                                           (OR START 0) PLEN _ LEN PLOOKS _
-                                                           (\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ 
-                                                           SEL) PPARALOOKS _ NIL))
-                                                           (* Create a PIECE to describe the 
-                                                           text) (\TEDIT.INSERT.PIECES TEXTOBJ
-                                                           (fetch (SELECTION CH#) of SEL) NPC 
-                                                           LEN) (* Insert it in the document)
-                                                           (add (fetch (TEXTOBJ TEXTLEN) of 
-                                                           TEXTOBJ) LEN) (* And update the 
-                                                           document's length)
-                                                           (\TEDIT.MARK.LINES.DIRTY TEXTOBJ
-                                                           (fetch (SELECTION CH#) of SEL)
-                                                           (IPLUS (fetch (SELECTION CH#) of SEL)
-  LEN)) (* Mark the screen dirty, so updating it will find something to do) (replace
-                                                           (SELECTION CHLIM) of SEL with
-                                                           (IPLUS (fetch (SELECTION CH#) of SEL)
-  LEN)) (replace (SELECTION DCH) of SEL with LEN) (replace (SELECTION DX) of SEL with 0)
-                                                           (replace (SELECTION POINT) of SEL 
-                                                           with (QUOTE RIGHT))
-                                                           (replace (SELECTION SELKIND) of SEL 
-                                                           with (QUOTE CHAR))
-                                                           (replace (SELECTION SELOBJ) of SEL 
-                                                           with NIL) (COND ((fetch
-                                                           (TEXTOBJ \WINDOW) of TEXTOBJ)
-                                                           (\SHOWSEL SEL NIL NIL)
-                                                           (TEDIT.UPDATE.SCREEN TEXTOBJ)
-                                                           (\FIXSEL SEL TEXTOBJ)
-                                                           (\SHOWSEL SEL NIL T)))
-                                                           (* Update the screen)
-                                                           (replace (TEXTOBJ \DIRTY) of TEXTOBJ 
-                                                           with T) (\SETUPGETCH
-                                                           (fetch (SELECTION CH#) of SEL) 
-                                                           TEXTOBJ)))
-    (HELP])
-
-(\TEDIT.INSERT.PIECES
-  [LAMBDA (TEXTOBJ CH# FIRSTPIECE %#CHARS INSPC INSPC# CROSSCOPY DONTDIRTY COPYING)
-                                                  (* ; 
-                                                "Edited  4-May-95 08:16 by sybalsky:mv:envos")
-
-    (* ;; "Inserts a series of pieces into TEXTOBJ in front of character CH#.")
-
-    (* ;; "If FIRSTPIECE is a PIECE, this will follow the next-piece pointer chain;  if FIRSTPIECE is a list, it is a list of pieces to insert.")
-
-    (* ;; "If CROSSCOPY is non-NIL, the pieces' contents will be copied, to preserve text in case the original is deleted.")
-
-    (* ;; "INSPC and INSPC# are accelerators for where in the PCTB the new pieces should go.")
-
-    (* ;; "DONTDIRTY is T if this is a change not visible to the user--one that shouldn't %"dirty%" the document.  This is used tor NS-character encoding recognition durint line formatting.")
-
-    (* ;; "COPYING is T if these pieces are being inserted by a COPY operation.  This lets us call the AFTERCOPYFN on image objects.")
-
-    (* ;; "It is the CALLER'S RESPONSIBILITY to make sure the pieces to be inserted are 'safe' --that they are, if necessary, copies of the originals, and can safely be modified.")
-                                                             (* ; 
-                                                           "NB THAT THIS DOES NOT UPDATE TEXTLEN")
-    (COND
-       ((OR DONTDIRTY (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)))
-
-        (* ;; "Only do this if you're allowed to change the document, or it's a TEdit-intertnal fixup change, as for NS char recognition.")
-
-        (LET ((TOLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-              (TOPCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-              (CURCH# CH#)
-              LEN PC PREVPC NPC UNDOCHAIN PSTR SRCPFILE START-OF-PIECE)
-             (DECLARE (SPECVARS START-OF-PIECE))         (* ; 
-                                  "Get a handle on the piece we're to insert within or in front of")
-                                                             (* COND ((ZEROP (fetch
-                                                           (BTREENODE TOTLEN) of TOPCTB))
-                                                           (* ; "PCTB is empty.")
-                                                           (\INSERT.FIRST.PIECE TEXTOBJ)))
-             (SETQ INSPC (\CHTOPC CH# TOPCTB T))             (* ; "And the piece, itself. (Used to be (OR INSPC (\CH...)), but we MUST set START-OF-PIECE, so must make the call to \CHTOPC.")
-             (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; 
-                                                       "Force later insertions to make new pieces.")
-             [COND
-                ((IGREATERP CH# TOLEN)                       (* ; 
-                   "We're inserting at end of file;  leave the piece to insert before as LASTPIECE")
-                 )
-                ((IEQP CH# START-OF-PIECE)                   (* ; 
-                                       "The insertion is IN FRONT of this piece;  just continue on")
-                 )
-                (T (SETQ INSPC (\SPLITPIECE INSPC (- CH# START-OF-PIECE)
-                                      TEXTOBJ]               (* ; 
-                                       "Nope, we're inserting INSIDE this piece.  Split it in two.")
-             (COND
-                ((NEQ INSPC 'LASTPIECE)                      (* ; 
-                                                "Not the last piece, so back up using the pointer.")
-                 (SETQ PREVPC (fetch (PIECE PREVPIECE) of INSPC)))
-                ((NOT (ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)))
-                                                             (* ; 
-                        "If we are at the end, AND there is text before us, find it thru the pctb.")
-                 (SETQ PREVPC (\CHTOPC (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)
-                                     TOPCTB)))
-                (T                                           (* ; 
-                                       "Otherwise, there is no piece before where we're inserting.")
-                   (SETQ PREVPC NIL)))                       (* ; "For pushing para looks in")
-             (bind [PC _ (create PIECE using (COND
-                                                            ((LISTP FIRSTPIECE)
-                                                             (pop FIRSTPIECE))
-                                                            (T FIRSTPIECE]
-                    (LEN _ 0)
-                    (PCCOUNT _ 0) first (SETQ UNDOCHAIN PC)
-                while (AND PC (OR (NOT %#CHARS)
-                                      (ILESSP LEN %#CHARS)))
-                do                                       (* ; 
-                                                  "Now insert the copied pieces into the new place")
-                      (COND
-                         ((AND CROSSCOPY (SETQ SRCPFILE (fetch (PIECE PFILE) of PC)))
-
-                          (* ;; "If this is a cross-document copy, and the text comes from a file, we must REALLY make a copy of the text, lest the source file be deleted.")
-
-                          (* ;; 
-"(replace PSTR of PC with (SETQ PSTR (ALLOCSTRING (fetch PLEN of PC) NIL NIL (fetch PFATP of PC))))")
-
-                          (replace (PIECE PFILE) of PC with (OPENSTREAM '{NODIRCORE}
-                                                                               'BOTH
-                                                                               'NEW))
-                                                             (* ; "Create the holding file")
-                          [COND
-                             ((NOT (OPENP SRCPFILE))         (* ; 
-                                              "The source file was CLOSED -- reopen it, for our us")
-                              (replace (PIECE PFILE) of PC with (SETQ SRCPFILE
-                                                                             (OPENSTREAM SRCPFILE
-                                                                                    'INPUT
-                                                                                    'OLD]
-                          (SETFILEPTR SRCPFILE (fetch (PIECE PFPOS) of PC))
-                          [COPYCHARS SRCPFILE (fetch (PIECE PFILE) of PC)
-                                 (fetch (PIECE PFPOS) of PC)
-                                 (IPLUS (fetch (PIECE PFPOS) of PC)
-                                        (COND
-                                           ((fetch (PIECE PFATP) of PC)
-                                            (LLSH (fetch (PIECE PLEN) of PC)
-                                                  1))
-                                           (T (fetch (PIECE PLEN) of PC]
-                          (replace (PIECE PFPOS) of PC with 0)))
-                      (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                      (fetch (PIECE PLOOKS)
-                                                                         of PC)
-                                                                      TEXTOBJ))
-                      (replace (PIECE PPARALOOKS) of PC with (\TEDIT.UNIQUIFY.PARALOOKS
-                                                                          (fetch (PIECE 
-                                                                                           PPARALOOKS
-                                                                                            )
-                                                                             of PC)
-                                                                          TEXTOBJ)) 
-                                                             (* ; 
-                                      "Assure that the new document knows about this piece's looks")
-                      [COND
-                         ((NULL FIRSTPIECE)
-                          (SETQ NPC NIL))
-                         [(LISTP FIRSTPIECE)                 (* ; 
-                           "If the piece list really IS a list, grab the next piece from the front")
-                          (SETQ NPC (create PIECE using (pop FIRSTPIECE]
-                         (T                                  (* ; 
-                                               "Otherwise, follow the NEXTPIECE chain among pieces")
-                            (SETQ NPC (create PIECE using (fetch (PIECE NEXTPIECE)
-                                                                     of PC]
-                      (\INSERTPIECE PC INSPC TEXTOBJ NIL)    (* ; 
-                                                           "Insert the piece into the new document")
-                      [COND
-                         (COPYING 
-
-                                (* ;; "For objects, call the optional AFTERCOPYFN.")
-
-                                (LET (OBJ AFTERFN)
-                                     (AND (SETQ OBJ (ffetch (PIECE POBJ) of PC))
-                                          (SETQ AFTERFN (IMAGEOBJPROP OBJ 'AFTERCOPYFN))
-                                          (APPLY* AFTERFN OBJ PC CURCH#]
-                      (add CURCH# (fetch (PIECE PLEN) of PC))
-                      (add LEN (fetch (PIECE PLEN) of PC))
-                      (SETQ PC NPC))
-             (\TEDIT.DIFFUSE.PARALOOKS PREVPC INSPC)
-             UNDOCHAIN])
-
-(\TEDIT.MOVE.PIECEMAPFN
-  [LAMBDA (PC TEXTOBJ FROMOBJ TOOBJ)                    (* ; "Edited 12-Jun-90 17:50 by mitani")
-                                                             (* Called by TEDIT.MOVE via 
-                                                           TEDIT.SELECTED.PIECES, to do the 
-                                                           move-operation processing on the 
-                                                           candidate pieces.)
-    (PROG (OBJ MOVEFN)
-          (SETQ PC (create PIECE using PC PNEW _ T)) (* No matter what, we need a fresh 
-                                                           copy.)
-          [COND
-             [(fetch (PIECE POBJ) of PC)             (* This piece describes an object)
-                                                             (* Call its WHENMOVEDFN.)
-              (SETQ OBJ (fetch (PIECE POBJ) of PC))
-              (COND
-                 ((SETQ MOVEFN (IMAGEOBJPROP OBJ 'WHENMOVEDFN))
-                                                             (* If there's an eventfn for moving, 
-                                                           use it.)
-                  (APPLY* MOVEFN OBJ (CAR (fetch (TEXTOBJ \WINDOW) of TOOBJ))
-                         (fetch (TEXTOBJ STREAMHINT) of FROMOBJ)
-                         (fetch (TEXTOBJ STREAMHINT) of TOOBJ]
-             ((fetch (PIECE PSTR) of PC)
-
-         (* If the piece is a string, make our own copy of the string header, even tho 
-       we share characters.)
-
-              (replace (PIECE PSTR) of PC with (SUBSTRING (fetch (PIECE PSTR)
-                                                                         of PC)
-                                                                  1
-                                                                  (fetch (PIECE PLEN)
-                                                                     of PC]
-          (RETURN PC])
-
-(\TEDIT.OBJECT.SHOWSEL
-  [LAMBDA (TEXTOBJ SEL ON SELWINDOW)                (* ; "Edited 12-Jun-90 17:50 by mitani")
-
-    (* ;; "We are hilighting (or dehilighting) a selected object.  Let it know.")
-
-    (LET ((X (fetch (SELECTION X0) of SEL))
-          (Y (fetch (SELECTION Y0) of SEL))
-          (FIRSTLINE (CAR (fetch (SELECTION L1) of SEL)))
-          (OBJ (fetch (SELECTION SELOBJ) of SEL))
-          (WIDTH (fetch (SELECTION DX) of SEL))
-          (XOFFSET (DSPXOFFSET NIL SELWINDOW))
-          (YOFFSET (DSPYOFFSET NIL SELWINDOW))
-          (IMAGEFN (IMAGEOBJPROP (fetch (SELECTION SELOBJ) of SEL)
-                          'WHENOPERATEDONFN))
-          (WWIDTH (WINDOWPROP SELWINDOW 'WIDTH))
-          (WHEIGHT (WINDOWPROP SELWINDOW 'HEIGHT))
-          IMAGEBOX)
-         (COND
-            ((INSIDE? (CREATEREGION 0 0 WWIDTH WHEIGHT)
-                    X Y)                                     (* ; 
-                                                      "Only do this if teh selection is on-screen.")
-             (SETQ IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX)
-                                (APPLY* (IMAGEOBJPROP OBJ 'IMAGEBOXFN)
-                                       OBJ SELWINDOW)))
-             [COND
-                (FIRSTLINE 
-
-                       (* ;; "There's really a line this selection is being displayed on, so we need to use the YBASE of the line- the object's descent, rather than the YBOT, which is what Y0 is.")
-
-                       (SETQ Y (- (fetch (LINEDESCRIPTOR YBASE) of FIRSTLINE)
-                                  (fetch (IMAGEBOX YDESC) of IMAGEBOX]
-             (RESETLST
-                 [RESETSAVE (DSPXOFFSET (IDIFFERENCE (IPLUS X XOFFSET)
-                                               (fetch XKERN of IMAGEBOX))
-                                   SELWINDOW)
-                        (LIST (FUNCTION DSPXOFFSET)
-                              XOFFSET
-                              (WINDOWPROP SELWINDOW 'DSP]
-                 (RESETSAVE (DSPYOFFSET (IPLUS Y YOFFSET)
-                                   SELWINDOW)
-                        (LIST (FUNCTION DSPYOFFSET)
-                              YOFFSET SELWINDOW))
-                 (RESETSAVE (DSPCLIPPINGREGION (create REGION
-                                                      LEFT _ 0
-                                                      BOTTOM _ 0
-                                                      WIDTH _ (IMIN WIDTH (IDIFFERENCE
-                                                                           (fetch (TEXTOBJ
-                                                                                       WRIGHT)
-                                                                              of TEXTOBJ)
-                                                                           X))
-                                                      HEIGHT _ (fetch YSIZE of IMAGEBOX))
-                                   SELWINDOW)
-                        (LIST (FUNCTION DSPCLIPPINGREGION)
-                              (DSPCLIPPINGREGION NIL SELWINDOW)
-                              SELWINDOW))
-                 [AND IMAGEFN (ERSETQ (APPLY* IMAGEFN OBJ SELWINDOW (COND
-                                                                       (ON 'HIGHLIGHTED)
-                                                                       (T 'UNHIGHLIGHTED))
-                                             SEL
-                                             (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ])])
-
-(\TEDIT.RESTARTFN
-  [LAMBDA (TEXT WINDOW PROPS)                           (* ; "Edited 12-Jun-90 17:51 by mitani")
-                                                             (* Restarts a TEdit session.)
-    (replace (TEXTOBJ \WINDOW) of (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-       with NIL)                                         (* Unattach the window, so we do a 
-                                                           redisplay.)
-    (PROG [(ODIRTY (fetch (TEXTOBJ \DIRTY) of (fetch (TEXTSTREAM TEXTOBJ)
-                                                             of TEXT]
-          (SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL PROPS))
-          (replace (TEXTOBJ \DIRTY) of (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-             with ODIRTY))                               (* Now reconnect the world together 
-                                                           again)
-    (\TEDIT.COMMAND.LOOP (fetch (TEXTSTREAM TEXTOBJ) of TEXT))
-                                                             (* Run the editing engine)
-    (CLOSEW WINDOW)                                          (* Close the edit window)
-    (\TEXTCLOSEF TEXT)                                       (* Close the underlying files)
-    (replace (STREAM ACCESSBITS) of TEXT with BothBits)
-                                                             (* But leave the stream itself 
-                                                           accessible)
-    (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-                'AFTERQUITFN)
-         (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-                        'AFTERQUITFN)
-                WINDOW TEXT))                                (* Apply any post-window-close
-                                                           (and post-QUIT) function)
-    ])
-
-(\TEDIT.CHARDELETE
-  [LAMBDA (TEXTOBJ SCRATCHSTRING SEL)                (* ; "Edited 19-Apr-93 10:50 by jds")
-
-    (* ;; "Do character-backspace deletion for TEDIT")
-
-    (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ))
-    (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-           TLEN INSCH# INSPC INSPC# TLOOKS START-OF-PIECE)
-          (COND
-             [NIL [NOT (ZEROP (SETQ TLEN (fetch (STRINGP OFFST) of SCRATCHSTRING]
-                                                             (* ; 
-                "If we didn't really insert the text yet, just remove from the text to be inserted")
-                  (replace (STRINGP OFFST) of SCRATCHSTRING with (SUB1 TLEN))
-                  (replace (STRINGP LENGTH) of SCRATCHSTRING
-                     with (ADD1 (fetch (STRINGP LENGTH) of SCRATCHSTRING]
-             (T                                              (* ; 
-                                        "Delete the character just before the current insertpoint.")
-                (SELECTQ (fetch (SELECTION POINT) of SEL)
-                    (LEFT (SETQ INSCH# (SUB1 (fetch (SELECTION CH#) of SEL))))
-                    (RIGHT (SETQ INSCH# (SUB1 (fetch (SELECTION CHLIM) of SEL))))
-                    NIL)
-                (COND
-                   ((ILEQ INSCH# 0)                          (* ; 
-                                                           "Can't backspace past start of document")
-                    (RETURN)))
-
-                (* ;; "(SETQ INSPC (\EDITELT PCTB (ADD1 (SETQ INSPC# (\CHTOPCNO INSCH# PCTB)))))")
-
-                (SETQ INSPC (\CHTOPC INSCH# PCTB T))
-                (SETQ TLOOKS (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) of INSPC)
-                                    INSPC TEXTOBJ))
-                [while (AND INSPC (fetch CLINVISIBLE of TLOOKS))
-                   do                                    (* ; 
-                                  "Back over any invisible text, which we're no allowed to delete.")
-                         (SETQ INSPC (fetch (PIECE PREVPIECE) of INSPC))
-                         (SETQ INSCH# (SUB1 START-OF-PIECE))
-                         (add START-OF-PIECE (IMINUS (fetch (PIECE PLEN) of INSPC)))
-                         (COND
-                            (INSPC (SETQ TLOOKS (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS)
-                                                                        of INSPC)
-                                                       INSPC TEXTOBJ]
-                (COND
-                   ((ILEQ INSCH# 0)                          (* ; 
-                                 "We backed up to the start of the document.  Can't go no further.")
-                    (RETURN))
-                   ((NOT (fetch CLPROTECTED of TLOOKS))
-                                                             (* ; 
-                                            "Can only backspace if the char to go isn't protected.")
-                    (replace (SELECTION CHLIM) of SEL
-                       with (ADD1 (replace (SELECTION CH#) of SEL with INSCH#)))
-                                                             (* ; 
-                           "Set up the selection to point to the character which is to be deleted.")
-                    (replace (SELECTION DCH) of SEL with 1)
-                    (\SHOWSEL SEL NIL NIL)                   (* ; 
-                                         "Turn off the underlining, if any, so there's no garbage.")
-                    (\FIXSEL SEL TEXTOBJ)                    (* ; 
-                                      "Fix the selection up so it points to the right line and all")
-                    (\TEDIT.DELETE SEL TEXTOBJ T)        (* ; "And delete it.")
-                    ])
-
-(\TEDIT.COPY.PIECEMAPFN
-  [LAMBDA (PC TEXTOBJ FROMOBJ TOOBJ)                    (* ; "Edited 12-Jun-90 17:50 by mitani")
-                                                             (* Called by TEDIT.COPY via 
-                                                           TEDIT.SELECTED.PIECES, to do the 
-                                                           copy-operation processing on the 
-                                                           candidate pieces.)
-    (PROG (OBJ NEWOBJ COPYFN)
-          (SETQ PC (create PIECE using PC PNEW _ T)) (* No matter what, we need a fresh 
-                                                           copy.)
-          [COND
-             ((fetch (PIECE POBJ) of PC)             (* This piece describes an object)
-              (SETQ OBJ (fetch (PIECE POBJ) of PC))
-              [COND
-                 [(SETQ COPYFN (IMAGEOBJPROP OBJ 'COPYFN))
-                  (SETQ NEWOBJ (APPLY* COPYFN OBJ (fetch (TEXTOBJ STREAMHINT) of FROMOBJ)
-                                      (fetch (TEXTOBJ STREAMHINT) of TOOBJ)))
-                  (COND
-                     ((EQ NEWOBJ 'DON'T)                     (* He said not to copy this piece --
-                                                           abort the whole copy.)
-                      (TEDIT.PROMPTPRINT TEXTOBJ "COPY of this object not allowed." T)
-                      (RETFROM 'TEDIT.COPY))
-                     (NEWOBJ (replace (PIECE POBJ) of PC with NEWOBJ))
-                     (T (replace (PIECE POBJ) of PC with (COPYALL OBJ]
-                 (OBJ                                        (* No copy fn; just strike off a 
-                                                           copy of our own)
-                      (replace (PIECE POBJ) of PC with (COPYALL OBJ]
-              (COND
-                 ((SETQ COPYFN (IMAGEOBJPROP OBJ 'WHENCOPIEDFN))
-                                                             (* If there's an eventfn for 
-                                                           copying, use it.)
-                  (APPLY* COPYFN OBJ (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of TOOBJ))
-                                            'DSP)
-                         (fetch (TEXTOBJ STREAMHINT) of FROMOBJ)
-                         (fetch (TEXTOBJ STREAMHINT) of TOOBJ]
-          [COND
-             ((fetch CLPROTECTED of (fetch (PIECE PLOOKS) of PC))
-                                                             (* The source text was protected;
-                                                           unprotect the copy.)
-              (replace (PIECE PLOOKS) of PC
-                 with (\TEDIT.UNIQUIFY.CHARLOOKS (create CHARLOOKS
-                                                        using (fetch (PIECE PLOOKS)
-                                                                     of PC)
-                                                              CLPROTECTED _ NIL CLSELHERE _ NIL)
-                                 TOOBJ]
-          (RETURN PC])
-
-(\TEDIT.DELETE
-  [LAMBDA (SEL STREAM SELOFF)                            (* ; "Edited 29-May-91 18:22 by jds")
-                                                             (* ; 
-                                              "DELETE THE CHARACTERS SPECIFIED FROM THE MAIN TEXT.")
-                                                             (* ; 
-                                                   "SELOFF => The selection is already turned off.")
-    (LET*
-     ((TEXTOBJ (TEXTOBJ STREAM))
-      (CH# (fetch (SELECTION CH#) of SEL))
-      (CHLIM (fetch (SELECTION CHLIM) of SEL))
-      (LINES (fetch (TEXTOBJ LINES) of TEXTOBJ))
-      (WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))
-      (HEIGHTCHANGED NIL)
-      (NLINE1 NIL)
-      (CRFLAG NIL)
-      (LINES\DELETED NIL)
-      OLINE1 OLINEN LEN NEXTLINE NL OLINE DX OCHLIM OXLIM OLHEIGHT OLASCENT OLDESCENT DY PREVLINE 
-      TEXTLEN OCR\END SAVEWIDTH IMAGECACHE)
-     [SETQ LEN (COND
-                  ((IGREATERP CH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-                                                             (* ; 
-                                                           "Past end of text, so don't delete any")
-                   0)
-                  ((IGEQ CH# CHLIM)                          (* ; 
-                                                          "Start is past end, so don't delete any.")
-                   0)
-                  ((ZEROP (fetch (SELECTION DCH) of SEL))
-                                                             (* ; 
-                                       "Just a caret--no text really selected--so don't delete any")
-                   0)
-                  ((ZEROP CHLIM)                             (* ; 
-                                               "CHLIM is before start of text, so don't delete any")
-                   0)
-                  (T                                         (* ; "The normal case.")
-                     (IDIFFERENCE CHLIM CH#]                 (* ; "# of characters to be deleted")
-     (COND
-        ((OR (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)
-             (NOT (fetch (SELECTION SET) of SEL))
-             (ZEROP LEN))                                    (* ; "If the selection isn't set, OR the document is read-only, OR the selection contains no characters, don't do anything.")
-         )
-        (T (AND WINDOW (TEDIT.NORMALIZECARET TEXTOBJ SEL))   (* ; 
-                               "If the text appears in a window, move the deletion point on-screen")
-           (SETQ OLINE1 (fetch (SELECTION L1) of SEL))
-           (SETQ OLINEN (fetch (SELECTION LN) of SEL))
-           (\TEDIT.SHOWSELS TEXTOBJ NIL NIL)                 (* ; 
-                                                           "Turn off the selection's highlighting")
-           (AND LINES (\FIXDLINES LINES SEL CH# CHLIM TEXTOBJ))
-                                                             (* ; 
-                                          "Update the line descriptors to account for the deletion")
-           (\DELETECH CH# CHLIM LEN TEXTOBJ)                 (* ; 
-                                                           "Do the actual deletion of characters")
-           (replace THPOINT of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)
-              with (fetch (SELECTION POINT) of SEL))
-                                                             (* ; 
-                         "Remember which side of the selection we were on, in case it gets undone.")
-           (replace (SELECTION CH#) of SEL with (IMAX 1 CH#))
-           (replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CH#) of
-                                                                                         SEL))
-           (replace (SELECTION POINT) of SEL with 'LEFT)
-           (replace (SELECTION DCH) of SEL with 0)
-           (COND
-              (WINDOW                                        (* ; 
-                                                     "If there's no window to update, don't bother")
-               (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-                                                             (* ; "The new text length")
-               (for OLINE1 inside (fetch (SELECTION L1) of SEL) as OLINEN
-                  inside (fetch (SELECTION LN) of SEL) as TOPLINE
-                  inside (fetch (TEXTOBJ LINES) of TEXTOBJ) as THISW inside
-                                                                                         WINDOW
-                  do (SETQ LINES\DELETED
-                          (\TEDIT.CLOSEUPLINES
-                           TEXTOBJ
-                           (OR (AND OLINE1 (COND
-                                              ((fetch (LINEDESCRIPTOR DELETED) of OLINE1)
-                                               (fetch (LINEDESCRIPTOR PREVLINE) of OLINE1))
-                                              (T OLINE1)))
-                               (COND
-                                  ([AND (fetch (LINEDESCRIPTOR NEXTLINE) of TOPLINE)
-                                        (OR (IGEQ (fetch (LINEDESCRIPTOR CHAR1)
-                                                     of (fetch (LINEDESCRIPTOR NEXTLINE)
-                                                               of TOPLINE))
-                                                  (fetch (SELECTION CHLIM) of SEL))
-                                            (ILESSP (fetch (LINEDESCRIPTOR CHARLIM)
-                                                       of (fetch (LINEDESCRIPTOR NEXTLINE)
-                                                                 of TOPLINE))
-                                                   (fetch (SELECTION CH#) of SEL]
-                                                             (* ; 
-      "The first line on the screen is already past where we're to delete.  DON'T delete any lines")
-                                   NIL)
-                                  (T TOPLINE)))
-                           (AND OLINEN (COND
-                                          ((fetch (LINEDESCRIPTOR DELETED) of OLINEN)
-                                           (fetch (LINEDESCRIPTOR NEXTLINE) of OLINEN))
-                                          (T OLINEN)))
-                           NIL THISW)))                      (* ; 
-                                                  "Remove any lines which were completely deleted.")
-
-               (* ;; "This line must needs be reformatted the hard way--it isn't a left ragged line or one of the lines is off-screen.")
-
-               (replace (SELECTION DX) of SEL with 0)
-               (TEDIT.UPDATE.SCREEN TEXTOBJ NIL T)           (* ; 
-                                                        "Correct the text that's displayed already")
-               (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ)
-                      TEXTOBJ)                               (* ; 
-                                                           "Then fix up the selection as needed.")
-               (\TEDIT.SHOWSELS TEXTOBJ NIL T])
-
-(\TEDIT.DIFFUSE.PARALOOKS
-  [LAMBDA (PRIORPC SUCCEEDINGPC)                        (* ; "Edited 12-Jun-90 17:48 by mitani")
-
-         (* Given a discontinuity in paragraph looks, caused by an insertion or by a 
-       deletion%: Diffuse the existing paragraph looks across the discontinuity, so 
-       that all the pieces in a single paragraph have consistent looks.
-       Give preference to diffusion toward the END of the document.
-       This means that if you delete a CR between paragraphs, the second para is 
-       absorbed into the first.)
-
-         (* PRIORPC and SUCCEEDINGPC are the PIECEs that bound the area of potential 
-       discontinuity%: the change will occur at one boundary or the other....)
-
-    [COND
-       ((AND PRIORPC (NOT (fetch (PIECE PPARALAST) of PRIORPC)))
-                                                             (* The discontinuity is inside a 
-                                                           paragraph. Must copy para looks 
-                                                           forward into the text.)
-        (bind (PPLOOKS _ (fetch (PIECE PPARALOOKS) of PRIORPC))
-               (PC _ (fetch (PIECE NEXTPIECE) of PRIORPC)) while PC
-           do                                            (* Copy para looks info in from the 
-                                                           left, up the the first para break.)
-                 (replace (PIECE PPARALOOKS) of PC with PPLOOKS)
-                 (COND
-                    ((fetch (PIECE PPARALAST) of PC) (* If this piece ends a paragraph, 
-                                                           we're done.)
-                     (RETURN)))
-                 (SETQ PC (fetch (PIECE NEXTPIECE) of PC]
-    (COND
-       ((AND SUCCEEDINGPC (NEQ SUCCEEDINGPC 'LASTPIECE))
-
-         (* Only copy para looks in from the right if there is text to the right.)
-
-        (bind (PPLOOKS _ (fetch (PIECE PPARALOOKS) of SUCCEEDINGPC))
-               (PC _ (fetch (PIECE PREVPIECE) of SUCCEEDINGPC)) while (NEQ PC PRIORPC)
-           do                                            (* Copy para looks in from the 
-                                                           right, up to the first para break)
-                 (COND
-                    ((fetch (PIECE PPARALAST) of PC) (* If this piece ends a paragraph, 
-                                                           we're done.)
-                     (RETURN)))
-                 (replace (PIECE PPARALOOKS) of PC with PPLOOKS)
-                 (SETQ PC (fetch (PIECE PREVPIECE) of PC])
-
-(\TEDIT.FOREIGN.COPY?
-  [LAMBDA (SEL)                                          (* ; "Edited 21-Jan-93 11:46 by jds")
-
-    (* ;; "IF the current process's window isn't a TEdit window, do a 'Copy' by BKSYSBUFing the selected text.  Then turn off all the various indicators.")
-
-    (PROG (PROCW (SOURCE.TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-                 CH STREAM DEST.TEDIT? DEST.TEXTOBJ)
-          [SETQ DEST.TEDIT? (AND (SETQ PROCW (PROCESSPROP (TTY.PROCESS)
-                                                    'WINDOW))
-                                 (SETQ DEST.TEXTOBJ (WINDOWPROP PROCW 'TEXTOBJ))
-                                 (NOT (TEXTPROP DEST.TEXTOBJ 'COPYBYBKSYSBUF]
-                                                             (* ; "Treat the destination specially if (1) the recipient process has a window, and (2) it's a TEdit window, and (3) the TEdit isn't declining special treatment by having COPYBYBKSYSBUF set in its props.")
-          (COND
-             ((ZEROP (fetch (SELECTION DCH) of SEL)) (* ; 
-                                       "Nothing to copy (0 characters in selection); don't bother.")
-              (SETQ TEDIT.COPY.PENDING NIL))
-             ((IGREATERP (fetch (SELECTION CH#) of SEL)
-                     (FETCH (TEXTOBJ TEXTLEN) OF SOURCE.TEXTOBJ))
-                                                             (* ; 
-                                 "Trying to copy from beyond the end of the document; don't bother")
-              (SETQ TEDIT.COPY.PENDING NIL))
-             ((OR (NOT DEST.TEDIT?)
-                  (AND PROCW DEST.TEXTOBJ (NEQ SOURCE.TEXTOBJ DEST.TEXTOBJ)
-                       (fetch (TEXTOBJ EDITOPACTIVE) of DEST.TEXTOBJ)))
-                                                             (* ; 
-                                                 "OK -- receiver isn't TEdit.  Do it the hard way.")
-              [COND
-                 [(AND (WINDOWPROP [OR PROCW (WFROMDS (PROCESS.TTY (TTY.PROCESS]
-                              'COPYINSERTFN)
-                       (PROGN                                (* ; 
-                                                       "This is the exit for looked-string objects")
-                              (OBJECTOUTOFTEDIT SOURCE.TEXTOBJ SEL]
-                 (T                                          (* ; 
-                       "Old tedit method, run if OBJECTOUTOFTEDIT is NILL (ie., not installed yet)")
-
-                    (* ;; "Still used because COPYINSERT does (PRIN2 BKSYSBUF) if there's no insertfn, which cretes undesired string quotes.")
-
-                    (\SETUPGETCH (fetch (SELECTION CH#) of SEL)
-                           SOURCE.TEXTOBJ)                   (* ; 
-                                                           "Go to the first character to be copied")
-                    (SETQ STREAM (fetch (TEXTOBJ STREAMHINT) of SOURCE.TEXTOBJ))
-                    (for I from 1 to (fetch (SELECTION DCH) of SEL)
-                       do 
-
-                             (* ;; "Run thru the selected text, copying only those items that really ARE characters--IMAGEOBJs don't get copied by this route.")
-
-                             (COND
-                                ((FIXP (SETQ CH (\BIN STREAM)))
-                                 (BKSYSBUF (CHARACTER CH)))
-                                (T (COPYINSERT CH]
-              (\SHOWSEL SEL NIL NIL)                         (* ; 
-                                                           "Then reset the copy-pending flags.")
-              (SETQ TEDIT.COPY.PENDING NIL])
-
-(\TEDIT.QUIT
-  [LAMBDA (W NOFORCE)                                   (* ; "Edited 12-Jun-90 17:50 by mitani")
-                                                             (* Called by the default 
-                                                           TEDIT.DEFAULT.MENUFN to perform the 
-                                                           QUIT command.)
-    (PROG* ((TEXTOBJ (WINDOWPROP W 'TEXTOBJ))
-            (QUITFNS (TEXTPROP TEXTOBJ 'QUITFN))
-            QUITFLG RESP)
-           [for QUITFN inside QUITFNS while (AND (NEQ QUITFLG 'DON'T)
-                                                             (NEQ QUITFLG T))
-              do (COND
-                        ((EQ QUITFN T)
-                         (SETQ QUITFLG T))
-                        (T (AND QUITFN (NEQ QUITFN T)
-                                (SETQ QUITFLG (APPLY* QUITFN W (fetch (TEXTOBJ STREAMHINT)
-                                                                  of TEXTOBJ)
-                                                     TEXTOBJ
-                                                     (fetch (TEXTOBJ EDITPROPS) of 
-                                                                                              TEXTOBJ
-                                                            ]
-           (COND
-              ((EQ QUITFLG 'DON'T)
-
-         (* The user supplied a QUITFN, and it returned "DON'T" %, so just ignore all 
-       this Fooferaw and keep editing.)
-
-               (RETURN))
-              [(AND (fetch (TEXTOBJ \DIRTY) of TEXTOBJ)
-                    (NOT (fetch (TEXTOBJ MENUFLG) of TEXTOBJ))
-                    (NEQ QUITFNS T)
-                    (NEQ QUITFLG T))
-
-         (* If this document has changed, check with the user to make sure he really 
-       wants to do it.)
-
-               (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ
-                  with (MOUSECONFIRM "Not saved yet; LEFT to Quit anyway." T (fetch
-                                                                                  (TEXTOBJ 
-                                                                                         PROMPTWINDOW
-                                                                                         )
-                                                                                    of TEXTOBJ]
-              (T                                             (* Go ahead and quit the next time 
-                                                           we see the main command loop.)
-                 (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ with T)))
-           [AND (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-                (NOT NOFORCE)
-                (NEQ (\TEDIT.PRIMARYW TEXTOBJ)
-                     (PROCESSPROP (TTY.PROCESS)
-                            'WINDOW))
-                (TTY.PROCESS (WINDOWPROP (\TEDIT.PRIMARYW TEXTOBJ)
-                                    'PROCESS]
-           (RETURN (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ])
-
-(\TEDIT.WORDDELETE
-  [LAMBDA (TEXTOBJ)                                  (* ; "Edited 29-May-91 18:22 by jds")
-
-    (* ;; "Delete the word to the left of the caret.")
-
-    (* ;; "Back word.")
-
-    (* ;; "THIS FUNCTION IS FRAUGHT WITH FENCEPOST PROBLEM POTENTIAL, AND THE WHILE vs FOR LOGIC IS CONVOLUTED.  CAUTION, CAUTION.")
-
-    (LET* ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-           (STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))
-           (READSA (fetch READSA of (OR (fetch (TEXTOBJ TXTWTBL) of TEXTOBJ)
-                                                TEDIT.WORDBOUND.READTABLE)))
-           (INSCH# (SELECTQ (fetch (SELECTION POINT) of SEL)
-                       (LEFT (SUB1 (fetch (SELECTION CH#) of SEL)))
-                       (RIGHT (SUB1 (fetch (SELECTION CHLIM) of SEL)))
-                       NIL))
-           CH CHNO)
-
-          (* ;; "INSCH# is the final (i.e., highest-numbered) character to be deleted.")
-
-          (COND
-             ((IGREATERP INSCH# 0)                           (* ; 
-                                                         "Don't try to back up past start of file.")
-              (\SETUPGETCH INSCH# TEXTOBJ)
-              (SETQ CH (\BIN STREAM))
-              (for old CHNO from INSCH# to 1 by -1
-                 while [AND (SELECTC (COND
-                                            ((FIXP CH)
-                                             (\SYNCODE READSA CH))
-                                            (T               (* ; "It's an object!")
-                                               TEXT.TTC))
-                                    (TEXT.TTC NIL)
-                                    T)
-                                (NOT (fetch CLPROTECTED of (fetch (PIECE PLOOKS)
-                                                                      of (fetch (TEXTSTREAM
-                                                                                         PIECE)
-                                                                                of STREAM]
-                 do 
-
-                       (* ;; "Skip over any initial separator characters")
-
-                       (SETQ CH (\GETCHB TEXTOBJ)))
-
-              (* ;; "At this point, CH is the first non-separator character, and CHNO is the character number of the character BEFORE that one.")
-
-              (for old CHNO from CHNO to 1 by -1
-                 while [AND (SELECTC (COND
-                                            ((FIXP CH)
-                                             (\SYNCODE READSA CH))
-                                            (T               (* ; "It's an object!")
-                                               TEXT.TTC))
-                                    (TEXT.TTC T)
-                                    NIL)
-                                (NOT (fetch CLPROTECTED of (fetch (PIECE PLOOKS)
-                                                                      of (fetch (TEXTSTREAM
-                                                                                         PIECE)
-                                                                                of STREAM]
-                 do 
-
-                       (* ;; "Skip over the next group of non-separators (= a 'word')")
-
-                       (SETQ CH (\GETCHB TEXTOBJ)))
-
-              (* ;; "At this point, CH is the first separator character you encountered, and CHNO is the character number of the character BEFORE the separator, or 0 if you hit the front of the document.")
-
-              (\SHOWSEL SEL NIL NIL)
-
-              (* ;; "First character to delete:")
-
-              [replace (SELECTION CH#) of SEL with (COND
-                                                                  ((ILESSP CHNO 1)
-                                                             (* ; 
-                                                 "Front of document, so start deleting at char # 1")
-                                                                   1)
-                                                                  (T 
-                                                             (* ; 
-"Otherwise, we need to start 1 later than the separator we hit, which is 2 higher than CHNO is now.")
-                                                                     (IPLUS 2 CHNO]
-              (replace (SELECTION CHLIM) of SEL with (ADD1 INSCH#))
-              (replace (SELECTION DCH) of SEL with (IDIFFERENCE INSCH# CHNO))
-              (\FIXSEL SEL TEXTOBJ)
-              (\SHOWSEL SEL NIL T)
-              (\TEDIT.DELETE SEL TEXTOBJ])
-
-(\TEDIT1
-  [LAMBDA (TEXT WINDOW UNSPAWNED PROPS)                 (* ; "Edited 12-Jun-90 17:50 by mitani")
-
-         (* Does the actual editing work, and re-coercion or process kill when done.
-       Called by TEDIT directly, or ADD.PROCESSed by it.)
-
-    (SETQ TEXT (OPENTEXTSTREAM TEXT WINDOW NIL NIL PROPS))   (* Open the text for editing)
-    (\TEDIT.COMMAND.LOOP (fetch (TEXTSTREAM TEXTOBJ) of TEXT))
-                                                             (* Run the editing engine)
-    (CLOSEW WINDOW)
-    (replace (TEXTOBJ \WINDOW) of (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-       with NIL)
-    (AND (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-                'AFTERQUITFN)
-         (APPLY* (TEXTPROP (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-                        'AFTERQUITFN)
-                WINDOW TEXT))                                (* Apply any post-window-close
-                                                           (and post-QUIT) function)
-    (COND
-       (UNSPAWNED                                            (* We're not a distinct process%: 
-                                                           Send back the edited text in some 
-                                                           suitable form)
-              (COND
-                 ((NEQ (fetch (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM
-                                                                                   TEXTOBJ)
-                                                                          of TEXT))
-                       T)
-                  (PROG1 (fetch (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM
-                                                                                     TEXTOBJ)
-                                                                            of TEXT))
-                      (replace (TEXTOBJ EDITFINISHEDFLG) of (fetch (TEXTSTREAM
-                                                                                    TEXTOBJ)
-                                                                           of TEXT) with
-                                                                                        NIL)))
-                 ((STRINGP (fetch (TEXTOBJ TXTFILE) of (fetch (TEXTSTREAM TEXTOBJ
-                                                                                     ) of TEXT)))
-                  (COERCETEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-                         'STRINGP))
-                 (T TEXT])
-)
-
-(MOVD? 'NILL 'OBJECTOUTOFTEDIT)
-
-
-
-(* ; "HOOK for looked-string copy, etc. Used in \TEDIT.FOREIGN.COPY?.")
-
-(DEFINEQ
-
-(\CREATE.TEDIT.RESTART.MENU
-  [LAMBDA NIL
-    (CREATE MENU
-           ITEMS _ '(NewEditProcess])
-)
-
-
-
-(* ; "Added by yabu.fx, for SUNLOADUP without DWIM.")
-
-
-
-
-(* ; "Debugging functions")
-
-(DEFINEQ
-
-(PLCHAIN
-  [LAMBDA (LN)                                           (* ; "Edited 29-May-91 18:20 by jds")
-    (PRINTLINE LN)
-    (COND
-       ((fetch (LINEDESCRIPTOR NEXTLINE) of LN)
-        (PLCHAIN (fetch (LINEDESCRIPTOR NEXTLINE) of LN])
-
-(PRINTLINE
-  [LAMBDA (LN)                                           (* ; "Edited 29-May-91 18:20 by jds")
-                                                             (* Print out a line descriptor in a 
-                                                           reasonable form.)
-    (printout T "-----" T LN "  Bot: " (fetch (LINEDESCRIPTOR YBOT) of LN)
-           "  Base: "
-           (fetch (LINEDESCRIPTOR YBASE) of LN)
-           "  Height: "
-           (fetch (LINEDESCRIPTOR LHEIGHT) of LN)
-           "  Ascent: "
-           (fetch (LINEDESCRIPTOR ASCENT) of LN)
-           "  Descent: "
-           (fetch (LINEDESCRIPTOR DESCENT) of LN)
-           T "Char1: " (fetch (LINEDESCRIPTOR CHAR1) of LN)
-           "  Lim: "
-           (fetch (LINEDESCRIPTOR CHARLIM) of LN)
-           "  Top: "
-           (fetch (LINEDESCRIPTOR CHARTOP) of LN))
-    (COND
-       ((fetch (LINEDESCRIPTOR DIRTY) of LN)
-        (PRIN1 "  DIRTY")))
-    (COND
-       ((fetch (LINEDESCRIPTOR CR\END) of LN)
-        (PRIN1 "  CR-at-end")))
-    (COND
-       ((fetch (LINEDESCRIPTOR DELETED) of LN)
-        (PRIN1 "  DELETED")))
-    (COND
-       ((fetch (LINEDESCRIPTOR LHASPROT) of LN)
-        (PRIN1 "  [Protected text]")))
-    (COND
-       ((fetch (LINEDESCRIPTOR LHASTABS) of LN)
-        (PRIN1 "  Has Tabs")))
-    (PRIN1 ".
-")
-    (printout T "RMar: " (fetch (LINEDESCRIPTOR RIGHTMARGIN) of LN)
-           "  XLim: "
-           (fetch (LINEDESCRIPTOR LXLIM) of LN)
-           "  Left: "
-           (fetch (LINEDESCRIPTOR SPACELEFT) of LN)
-           T "Prev:  " (fetch (LINEDESCRIPTOR PREVLINE) of LN)
-           T "Next:  " (fetch (LINEDESCRIPTOR NEXTLINE) of LN)
-           T)
-    (COND
-       ((AND (IGEQ (fetch (LINEDESCRIPTOR CHAR1) of LN)
-                   1)
-             (ILEQ (fetch (LINEDESCRIPTOR CHAR1) of LN)
-                   (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)))
-                                                             (* The line is real --
-                                                           print it.)
-        (\SETUPGETCH (fetch (LINEDESCRIPTOR CHAR1) of LN)
-               TEXTOBJ)
-        (PRIN1 "|")
-        [bind CH for CHNO from (fetch (LINEDESCRIPTOR CHAR1) of LN)
-           to (IMIN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)
-                        (fetch (LINEDESCRIPTOR CHARLIM) of LN))
-           do (SETQ CH (\GETCH TEXTOBJ))
-                 (COND
-                    ((SMALLP CH)
-                     (PRIN1 (CHARACTER CH)))
-                    (T (PRINT CH]
-        (PRIN1 "|
-"])
-
-(SEEFILE
-  [LAMBDA (FILE ST ND)                                       (* jds " 4-NOV-83 20:21")
-    (PROG (CH)
-          [SETQ FILE (OR (OPENP FILE)
-                         (OPENSTREAM FILE 'INPUT]
-          (SETFILEPTR FILE (OR ST 0))
-          (for I from (OR ST 0) to (OR ND (SUB1 (GETEOFPTR FILE)))
-             do (printout T I 5 (SETQ CH (BIN FILE))
-                       9
-                       (COND
-                          [(ILEQ CH (CHARCODE ^Z))
-                           (CONCAT "^" (CHARACTER (IPLUS CH (CHARCODE @]
-                          (T (CHARACTER CH)))
-                       T])
-)
-
-
-
-(* ; "Object-oriented editing")
-
-(DEFINEQ
-
-(TEDIT.INSERT.OBJECT
-  [LAMBDA (OBJECT STREAM CH#)                            (* ; "Edited 21-Apr-93 00:52 by jds")
-
-    (* ;; "Inserts the Image-object OBJECT into text STREAM in front of character CH.")
-
-    (LET* ((TEXTOBJ (TEXTOBJ STREAM))
-           (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-           SUBSTREAM START-OF-PIECE)
-          (TEDIT.DO.BLUEPENDINGDELETE SEL TEXTOBJ)       (* ; 
-                                                          "Do the pending delete, if there is one.")
-          (COND
-             ((NULL CH#)                                     (* ; 
-                                                    "Omitted CH# means put it at the current spot.")
-              (SETQ CH# SEL)))
-          [COND
-             ((type? SELECTION CH#)
-
-              (* ;; "If the CH# passed in was a selection (or we set it because he defaulted CH#), then compute the REAL CH#.")
-
-              (SETQ CH# (SELECTQ (fetch (SELECTION POINT) of CH#)
-                            (LEFT (fetch (SELECTION CH#) of CH#))
-                            (RIGHT (fetch (SELECTION CHLIM) of CH#))
-                            (SHOULDNT]
-          (PROG ((PCTB (ffetch (TEXTOBJ PCTB) of TEXTOBJ))
-                 TEXTLEN PC PCNO CHNO NEWPC PREVPC INSERTFN)
-                (COND
-                   ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)
-
-                    (* ;; 
-                  "If no changes are allowed to this TEdit, bail out without doing anything.")
-
-                    (RETURN)))
-                (\SHOWSEL SEL NIL NIL)                       (* ; "Turn off the selection for now")
-                (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-                (SETQ CH# (IMIN CH# (ADD1 TEXTLEN)))         (* ; 
-                                                 "CH# we're to insert these characters in front of")
-                (freplace (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ with -1)
-                [SETQ PC (COND
-                            ((ILEQ CH# TEXTLEN)
-                             (\CHTOPC CH# PCTB T))
-                            (T 'LASTPIECE]                   (* ; 
-                                                      "Piece we're to insert in front of or inside")
-                (SETQ NEWPC (create PIECE
-                                   PSTR _ NIL
-                                   PFILE _ NIL
-                                   POBJ _ OBJECT
-                                   PLEN _ 1))                (* ; "The new piece we're inserting")
-                [COND
-                   ((SETQ SUBSTREAM (IMAGEOBJPROP OBJECT 'SUBSTREAM))
-                                                             (* ; 
-                                                "If this is computed text in bulk, fix the length.")
-                    (replace (PIECE PLEN) of NEWPC with (fetch (TEXTOBJ TEXTLEN)
-                                                                       of (fetch (
-                                                                                        TEXTSTREAM
-                                                                                          TEXTOBJ)
-                                                                                 of SUBSTREAM]
-                (COND
-                   ((OR (IGREATERP CH# TEXTLEN)
-                        (IEQP CH# START-OF-PIECE))           (* ; 
-                      "We're inserting on a piece boundary;  do it, then remember the prior piece.")
-                    (\INSERTPIECE NEWPC PC TEXTOBJ))
-                   (T                                        (* ; 
-                          "Not on a piece boundary;  split the piece we're inside of, then insert.")
-                      (\INSERTPIECE NEWPC (\SPLITPIECE PC (IDIFFERENCE CH# START-OF-PIECE)
-                                                 TEXTOBJ)
-                             TEXTOBJ)))
-                (COND
-                   ((SETQ INSERTFN (IMAGEOBJPROP OBJECT 'WHENINSERTEDFN))
-                                                             (* ; 
-                                                          "If there is a WHENINSERTEDFN, apply it.")
-                    (APPLY* INSERTFN OBJECT (AND (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ
-                                                             ))
-                                                 (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW)
-                                                                     of TEXTOBJ))
-                                                        'DSP))
-                           NIL STREAM)))
-                (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-                (SETQ PREVPC (fetch (PIECE PREVPIECE) of NEWPC))
-                                                             (* ; "Fill in the para looks")
-                [COND
-                   [PREVPC (COND
-                              [(AND (fetch (PIECE PPARALAST) of PREVPC)
-                                    (fetch (PIECE NEXTPIECE) of NEWPC))
-                               (replace (PIECE PPARALOOKS) of NEWPC
-                                  with (fetch (PIECE PPARALOOKS) of (fetch
-                                                                                 (PIECE NEXTPIECE)
-                                                                                   of NEWPC]
-                              (T (replace (PIECE PPARALOOKS) of NEWPC
-                                    with (fetch (PIECE PPARALOOKS) of PREVPC]
-                   (T (COND
-                         ((SETQ PREVPC (fetch (PIECE NEXTPIECE) of NEWPC))
-                          (replace (PIECE PPARALOOKS) of NEWPC with (fetch
-                                                                                 (PIECE PPARALOOKS)
-                                                                                   of PREVPC)))
-                         (T (replace (PIECE PPARALOOKS) of NEWPC with (fetch
-                                                                                   (TEXTOBJ
-                                                                                    FMTSPEC)
-                                                                                     of TEXTOBJ]
-                (replace (PIECE PLOOKS) of NEWPC with (fetch (TEXTOBJ CARETLOOKS)
-                                                                     of TEXTOBJ))
-                (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT
-                                                  THACTION _ 'Insert
-                                                  THCH# _ CH#
-                                                  THLEN _ 1
-                                                  THFIRSTPIECE _ NEWPC))
-                (SETQ TEXTLEN (freplace (TEXTOBJ TEXTLEN) of TEXTOBJ
-                                 with (IPLUS (fetch (PIECE PLEN) of NEWPC)
-                                                 TEXTLEN)))
-                (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; 
-  "Since adding an IMAGEOBJ creates a new piece, the old insertion cache piece is no longer valid.")
-                (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T)
-                (replace (THISLINE DESC) of (fetch (TEXTOBJ THISLINE) of TEXTOBJ)
-                   with NIL)
-                (replace (SELECTION SELKIND) of SEL with 'CHAR)
-                (COND
-                   ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-                    (\FIXILINES TEXTOBJ SEL CH# (fetch (PIECE PLEN) of NEWPC)
-                           (SUB1 TEXTLEN))
-                    (replace (SELECTION DCH) of SEL with 0)
-                    (replace (SELECTION DX) of SEL with 0)
-                    (TEDIT.UPDATE.SCREEN TEXTOBJ)
-                    (\FIXSEL SEL TEXTOBJ)
-                    (\SHOWSEL SEL NIL T))
-                   (T [replace (SELECTION CHLIM) of SEL
-                         with (replace (SELECTION CH#) of SEL
-                                     with (IPLUS CH# (fetch (PIECE PLEN) of NEWPC]
-                      (replace (SELECTION DCH) of SEL with 0)
-                      (replace (SELECTION DX) of SEL with 0)
-                      (replace (SELECTION POINT) of SEL with 'LEFT)
-                      (replace (THISLINE DESC) of (fetch (TEXTOBJ THISLINE)
-                                                             of TEXTOBJ) with NIL)))
-                (\COPYSEL SEL TEDIT.SELECTION])
-
-(TEDIT.EDIT.OBJECT
-  [LAMBDA (STREAM OBJ)                                   (* ; "Edited 29-May-91 18:23 by jds")
-    (PROG ([TEXTOBJ (COND
-                           ((type? TEXTOBJ STREAM)
-                            STREAM)
-                           ((type? STREAM STREAM)
-                            (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-                           ((SHOULDNT]
-           SEL LL CH# SELOBJ EDITFN)
-          [COND
-             [(AND OBJ (IMAGEOBJP OBJ))
-              (SETQ CH# (TEDIT.FIND.OBJECT TEXTOBJ OBJ))
-              (COND
-                 (CH# (SETQ SEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-                      (replace (SELECTION CH#) of SEL with CH#)
-                      (replace (SELECTION CHLIM) of SEL with (ADD1 CH#))
-                      (SETQ SELOBJ OBJ)
-                      (replace (SELECTION DCH) of SEL with 1)
-                      (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ)
-                      (\FIXSEL SEL TEXTOBJ))
-                 (T (TEDIT.PROMPTPRINT TEXTOBJ "Can't find specified object." T]
-             (T (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-                (SETQ OBJ (fetch (SELECTION SELOBJ) of SEL]
-          (COND
-             [OBJ                                            (* OK There's an object selected.
-                                                           Edit it.)
-                  (SETQ EDITFN (IMAGEOBJPROP OBJ 'EDITFN))
-                  (COND
-                     ((AND EDITFN (APPLY* EDITFN OBJ))       (* If the editfn makes a change, 
-                                                           update the screen.)
-                      (for LINE inside (fetch (SELECTION L1) of SEL)
-                         do (replace (LINEDESCRIPTOR DIRTY) of LINE with T))
-                      (replace (TEXTOBJ TXTNEEDSUPDATE) of TEXTOBJ with T)
-                      (TEDIT.UPDATE.SCREEN TEXTOBJ]
-             (T                                              (* No object selected.)
-                (TEDIT.PROMPTPRINT TEXTOBJ "Please select an editable object first." T])
-
-(TEDIT.FIND.OBJECT
-  [LAMBDA (TEXTOBJ OBJ)                              (* ; "Edited  3-May-93 12:52 by jds")
-                                                             (* ; 
-                                   "Find OBJ, if it's in TEXTOBJ, and return CH#.  Else return nil")
-    (SETQ TEXTOBJ (TEXTOBJ TEXTOBJ))
-    (LET ((PC (\GETBASEPTR (\FIRSTNODE (fetch PCTB of TEXTOBJ))
-                     0))
-          (CH 1))
-         (while PC do (COND
-                                 ((AND (NOT (ATOM PC))
-                                       (EQ (fetch (PIECE POBJ) of PC)
-                                           OBJ))
-                                  (RETURN CH))
-                                 (T (add CH (ffetch (PIECE PLEN) of PC))
-                                    (SETQ PC (fetch (PIECE NEXTPIECE) of PC])
-
-(TEDIT.FIND.OBJECT.SUBTREE
-  [LAMBDA (PCTB OBJ)                                    (* ; "Edited 12-Jun-90 17:52 by mitani")
-    (COND
-       ((NULL PCTB)
-        NIL)
-       ((ATOM (fetch (PCTNODE PCE) of PCTB))
-        (OR (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE LO) of PCTB)
-                   OBJ)
-            (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE HI) of PCTB)
-                   OBJ)))
-       ((EQ (fetch (PIECE POBJ) of (fetch (PCTNODE PCE) of PCTB))
-            OBJ)
-        (fetch (PCTNODE CHNUM) of PCTB))
-       (T (OR (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE LO) of PCTB)
-                     OBJ)
-              (TEDIT.FIND.OBJECT.SUBTREE (fetch (PCTNODE HI) of PCTB)
-                     OBJ])
-
-(TEDIT.PUT.OBJECT
-  [LAMBDA (PIECE OFILE FONTFILE CURCH#)                 (* ; "Edited 12-Jun-90 17:49 by mitani")
-                                                             (* Given a piece which describes an 
-                                                           object, put the object out there.)
-    (PROG ((OBJECT (fetch (PIECE POBJ) of PIECE))
-           (FONTCH# (GETFILEPTR FONTFILE))
-           TOFILE LEN)
-          (\DWOUT FONTFILE 0)                                (* Placeholder for length of the 
-                                                           object's description)
-          (\SMALLPOUT FONTFILE \PieceDescriptorOBJECT)       (* Mark this as setting the piece's 
-                                                           looks)
-          (\ATMOUT FONTFILE (IMAGEOBJPROP OBJECT 'GETFN))    (* The FN to apply to reconstruct 
-                                                           the object)
-          (APPLY* (IMAGEOBJPROP OBJECT 'PUTFN)
-                 OBJECT OFILE)
-          (SETFILEPTR FONTFILE FONTCH#)
-
-         (* Now go back and fill in the length of the text description of the object.)
-
-          [\DWOUT FONTFILE (SETQ LEN (ADD1 (IDIFFERENCE (GETEOFPTR OFILE)
-                                                  CURCH#]
-          (SETFILEPTR FONTFILE -1)                           (* Make sure we're at the end of the 
-                                                           font file)
-          (AND (RANDACCESSP OFILE)
-               (SETFILEPTR OFILE -1))                        (* And the text part of the file)
-          (RETURN LEN])
-
-(TEDIT.GET.OBJECT
-  [LAMBDA (STREAM PIECE FILE CURCH#)                    (* ; "Edited 12-Jun-90 17:50 by mitani")
-                                                             (* ; "Get an object from the file")
-                                                             (* ; 
-             "CURCH# = fileptr within the text section of the file where the object's text starts.")
-    (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-           FILEPTRSAVE NAMELEN GETFN OBJ NBYTES)
-
-     (* ;; "rrb 10-AUG-87 --- calculate the length of the image object's data.  This assumes that the file is currently pointed at the end of the data which is where the GETFN is written {I think}")
-
-          (SETQ NBYTES (DIFFERENCE (GETFILEPTR FILE)
-                              CURCH#))
-          (SETQ GETFN (\ATMIN FILE))                         (* ; 
-                                                           "The GETFN for this kind of IMAGEOBJ")
-          (SETQ FILEPTRSAVE (GETFILEPTR FILE))               (* ; 
-                                           "Save our file location thru the building of the object")
-          (SETFILEPTR FILE CURCH#)
-          (SETQ OBJ (READIMAGEOBJ FILE GETFN NIL NBYTES))
-          (COND
-             ((IMAGEOBJPROP OBJ 'UNKNOWNGETFN)               (* ; 
-    "If the object has an unknown getfn property, then it's an encapsulated object.  Warn the user")
-              (TEDIT.PROMPTPRINT STREAM "WARNING: Document contains unknown image objects." T)))
-          (SETFILEPTR FILE FILEPTRSAVE)
-          (replace (PIECE POBJ) of PIECE with OBJ)
-          (replace (PIECE PFILE) of PIECE with NIL)
-          (replace (PIECE PSTR) of PIECE with NIL)
-          [replace (PIECE PLOOKS) of PIECE with (COND
-                                                               ((fetch (PIECE PREVPIECE)
-                                                                   of PIECE)
-                                                                (fetch (PIECE PLOOKS)
-                                                                   of (fetch (PIECE PREVPIECE
-                                                                                            )
-                                                                             of PIECE)))
-                                                               (T (OR (fetch (TEXTOBJ 
-                                                                                     DEFAULTCHARLOOKS
-                                                                                        )
-                                                                         of TEXTOBJ)
-                                                                      (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                       (CHARLOOKS.FROM.FONT 
-                                                                              DEFAULTFONT)
-                                                                       TEXTOBJ]
-          (RETURN (fetch (PIECE POBJ) of PIECE])
-
-(TEDIT.OBJECT.CHANGED
-  [LAMBDA (STREAM OBJECT)                               (* ; "Edited 12-Jun-90 17:51 by mitani")
-
-         (* Notify TEdit that an object has changed, and the display may need to be 
-       updated.)
-
-    (PROG ((TEXTOBJ (TEXTOBJ STREAM))
-           (LINES (fetch (TEXTOBJ LINES) of (TEXTOBJ STREAM)))
-           PCINFO CHANGED CHANGEDCH#)
-          (SETQ PCINFO (TEDIT.MAPPIECES TEXTOBJ [FUNCTION (LAMBDA (CH# PC PCNO OBJ)
-                                                                (AND (EQ OBJ (fetch (PIECE POBJ)
-                                                                                of PC))
-                                                                     'STOP]
-                              OBJECT))                       (* Find the piece containing this 
-                                                           object)
-          (OR PCINFO (HELP "Changed OBJECT not found!?"))
-          (SETQ CHANGEDCH# (CAR PCINFO))                     (* Get the CH# of the changed object)
-          (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CHANGEDCH# CHANGEDCH#)
-                                                             (* Mark affected lines)
-          (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T)
-                                                             (* And mark the document dirty.)
-          (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ)
-                 NIL NIL)
-          (TEDIT.UPDATE.SCREEN TEXTOBJ)
-          (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ)
-                 TEXTOBJ)
-          (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ)
-                 NIL T])
-)
-
-(FILESLOAD TEDITFIND TEDITHISTORY TEDITFILE TEDITWINDOW TEDITSELECTION IMAGEOBJ TFBRAVO TEDITHCPY 
-       TEDITPAGE TEDITMENU TEDITFNKEYS)
-
-
-
-(* ; "TEDIT Support information")
-
-
-(RPAQQ TEDITSYSTEMDATE " 4-May-95 10:37:23")
-
-(RPAQ TEDITSUPPORT "TEditSupport.PA")
-(DEFINEQ
-
-(MAKETEDITFORM
-  [LAMBDA NIL                                                (* jds "12-Mar-85 04:00")
-                                                             (* Builds a trouble-report form for 
-                                                             TEdit.)
-    (MAKEXXXSUPPORTFORM "TEdit" TEDITSUPPORT TEDITSYSTEMDATE])
-)
-
-(ADDTOVAR LAFITESPECIALFORMS ("TEdit Report" 'MAKETEDITFORM "Report a problem with TEdit"))
-
-(SETQ LAFITEFORMSMENU NIL)
-
-
-
-(* ; "LISTFILES Interface, so the system can decide if a file is a TEdit file.")
-
-
-(ADDTOVAR PRINTFILETYPES (TEDIT (TEST \TEDIT.FORMATTEDP1)
-                                    (EXTENSION (TEDIT))))
-(PUTPROPS TEDIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 
-1992 1993 1995))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (4494 115122 (\TEDIT2 4504 . 7255) (COERCETEXTOBJ 7257 . 15584) (TEDIT 15586 . 20255) (
-TEDIT.CHARWIDTH 20257 . 22281) (TEDIT.COPY 22283 . 30881) (TEDIT.DELETE 30883 . 31573) (
-TEDIT.DO.BLUEPENDINGDELETE 31575 . 34642) (TEDIT.INSERT 34644 . 40174) (TEDIT.KILL 40176 . 41733) (
-TEDIT.MAPLINES 41735 . 43134) (TEDIT.MAPPIECES 43136 . 44092) (TEDIT.MOVE 44094 . 54143) (TEDIT.QUIT 
-54145 . 56145) (TEDIT.STRINGWIDTH 56147 . 56818) (TEDIT.\INSERT 56820 . 58845) (TEXTOBJ 58847 . 59972)
- (TEXTSTREAM 59974 . 61589) (\TEDIT.INCLUDE 61591 . 65491) (\TEDIT.INSERT.PIECES 65493 . 75524) (
-\TEDIT.MOVE.PIECEMAPFN 75526 . 77605) (\TEDIT.OBJECT.SHOWSEL 77607 . 81236) (\TEDIT.RESTARTFN 81238 . 
-83233) (\TEDIT.CHARDELETE 83235 . 87197) (\TEDIT.COPY.PIECEMAPFN 87199 . 90424) (\TEDIT.DELETE 90426
- . 97944) (\TEDIT.DIFFUSE.PARALOOKS 97946 . 100710) (\TEDIT.FOREIGN.COPY? 100712 . 104439) (
-\TEDIT.QUIT 104441 . 107587) (\TEDIT.WORDDELETE 107589 . 112422) (\TEDIT1 112424 . 115120)) (115236 
-115352 (\CREATE.TEDIT.RESTART.MENU 115246 . 115350)) (115451 119140 (PLCHAIN 115461 . 115735) (
-PRINTLINE 115737 . 118501) (SEEFILE 118503 . 119138)) (119181 138824 (TEDIT.INSERT.OBJECT 119191 . 
-128268) (TEDIT.EDIT.OBJECT 128270 . 130526) (TEDIT.FIND.OBJECT 130528 . 131421) (
-TEDIT.FIND.OBJECT.SUBTREE 131423 . 132229) (TEDIT.PUT.OBJECT 132231 . 133890) (TEDIT.GET.OBJECT 133892
- . 137091) (TEDIT.OBJECT.CHANGED 137093 . 138822)) (139100 139463 (MAKETEDITFORM 139110 . 139461)))))
-STOP
diff --git a/obsolete/library/new/TEDIT.LCOM b/obsolete/library/new/TEDIT.LCOM
deleted file mode 100644
index 4a95300d..00000000
Binary files a/obsolete/library/new/TEDIT.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITABBREV.LCOM b/obsolete/library/new/TEDITABBREV.LCOM
deleted file mode 100644
index 82262191..00000000
Binary files a/obsolete/library/new/TEDITABBREV.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITCOMMAND.LCOM b/obsolete/library/new/TEDITCOMMAND.LCOM
deleted file mode 100644
index 386f05df..00000000
Binary files a/obsolete/library/new/TEDITCOMMAND.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITDCL b/obsolete/library/new/TEDITDCL
deleted file mode 100644
index f2d63f6f..00000000
--- a/obsolete/library/new/TEDITDCL
+++ /dev/null
@@ -1,1654 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED "22-Mar-95 18:05:53" {DSK}<lispcore>library>new>TEDITDCL.;1 86457  
-
-      changes to%:  (RECORDS PIECE)
-
-      previous date%: "25-Aug-94 10:53:00" {DSK}<lispcore>library>TEDITDCL.;2)
-
-
-(* ; "
-Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1995 by Venue.  All rights reserved.
-")
-
-(PRETTYCOMPRINT TEDITDCLCOMS)
-
-(RPAQQ TEDITDCLCOMS
-       [
-
-(* ;;; "This file is the collected record declarations and compile-time necessities for TEDIT.")
-
-        
-        (* ;; "FROM TEDIT")
-
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)))
-        
-        (* ;; "FROM TEDITSELECTION")
-
-        (RECORDS SELECTION)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (COPYSELSHADE 30583)
-                                                (COPYLOOKSSELSHADE 30583)
-                                                (EDITMOVESHADE -1)
-                                                (EDITGRAY 32800)))
-        (VARS TEDITFILES)
-        
-        (* ;; "FROM TEDITSCREEN")
-
-        (RECORDS THISLINE LINEDESCRIPTOR LINECACHE)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (LMInvisibleRun 401)
-                                                (LMLooksChange 400)))
-        
-        (* ;; "FROM TEXTOFD")
-
-        (RECORDS EDITMARK)
-        (RECORDS PIECE TEXTOBJ TEXTIMAGEDATA TEXTSTREAM)
-        (OPTIMIZERS TEXTPROP)
-        (COMS 
-              (* ;; "Private data structures and constants FROM TEXTOFD")
-
-              (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\PCTBFreePieces 0)
-                                                      (\PCTBLastPieceOffset 1)
-                                                      (\FirstPieceOffset 2)
-                                                      (\SecondPieceOffset 4)
-                                                      (\EltsPerPiece 2))
-                     (MACROS \EDITELT \GETCH \GETCHB \EDITSETA \WORDSETA)
-                     (GLOBALVARS \TEXTIMAGEOPS \TEXTOFD \TEXTFDEV)))
-        
-
-(* ;;; "FROM TEDITPAGE")
-
-        (RECORDS PAGEFORMATTINGSTATE PAGEREGION)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITPAPERSIZE)
-               (FUNCTIONS \NEW-COLUMN-START \FIRST-COLUMN-START))
-        
-        (* ;; "FROM TEDITFIND")
-
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\AlphaNumericFlag 256)
-                                                (\AlphaFlag 512)
-                                                (\OneCharPattern 1024)
-                                                (\AnyStringPattern 1025)
-                                                (\OneAlphaPattern 1026)
-                                                (\AnyAlphaPattern 1027)
-                                                (\OneNonAlphaPattern 1028)
-                                                (\AnyNonAlphaPattern 1029)
-                                                (\LeftBracketPattern 1030)
-                                                (\RightBracketPattern 1031)
-                                                (\SpecialPattern 1024)))
-        
-        (* ;; " FROM TEDITLOOKS")
-
-        (RECORDS CHARLOOKS FMTSPEC PENDINGTAB)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \SMALLPIN \SMALLPOUT ONOFF))
-        
-        (* ;; "FROM TEDITMENU")
-
-        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MBUTTON))
-        (INITRECORDS MBUTTON)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS NWAYBUTTON))
-        (INITRECORDS NWAYBUTTON)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MARGINBAR))
-        (INITRECORDS MARGINBAR)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TAB))
-        (RECORDS MB.3STATE MB.BUTTON MB.INSERT MB.MARGINBAR MB.NWAY MB.TEXT MB.TOGGLE)
-        (FUNCTIONS WITHOUT-UPDATES)
-        
-        (* ;; "FROM TEDITHISTORY")
-
-        (RECORDS TEDITHISTORYEVENT)
-        
-        (* ;; "FROM TEDITFILE")
-
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\PieceDescriptorLOOKS 0)
-                                                (\PieceDescriptorOBJECT 1)
-                                                (\PieceDescriptorPARA 2)
-                                                (\PieceDescriptorPAGEFRAME 3)
-                                                (\PieceDescriptorCHARLOOKSLIST 4)
-                                                (\PieceDescriptorPARALOOKSLIST 5)
-                                                (\PieceDescriptorSAFEOBJECT 6)))
-        
-        (* ;; "FROM TEDITCOMMAND")
-
-        (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \INSERT\TTY\BUFFER \TEDIT.MOUSESTATE \TEDIT.CHECK))
-        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITTERMCODE))
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NONE.TTC 0)
-                                                (CHARDELETE.TTC 1)
-                                                (WORDDELETE.TTC 2)
-                                                (DELETE.TTC 3)
-                                                (FUNCTIONCALL.TTC 4)
-                                                (REDO.TTC 5)
-                                                (UNDO.TTC 6)
-                                                (CMD.TTC 7)
-                                                (NEXT.TTC 8)
-                                                (EXPAND.TTC 9)
-                                                (PUNCT.TTC 20)
-                                                (TEXT.TTC 21)
-                                                (WHITESPACE.TTC 22)))
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MSPACE 153)
-                                                (NSPACE 152)
-                                                (THINSPACE 159)
-                                                (FIGSPACE 154)))
-        
-        (* ;; "FROM TEDITWINDOW")
-
-        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITCARET))
-        (INITRECORDS TEDITCARET)
-        
-        (* ;; "FROM PCTREE added by Nakamura")
-
-        (RECORDS PCTNODE)
-        
-
-(* ;;; "THE END")
-
-        (COMS 
-              (* ;; "Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character ")
-
-              (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NOTBEFORE.LB 1)
-                                                             (* ; 
-                                 "Must not break before this character (e.g. Japanese right-paren)")
-                                                      (NOTAFTER.LB 2)
-                                                             (* ; 
-                                   "Must not break after this character (e.g. Japanese open-quote)")
-                                                      (BEFORE.LB 4)
-                                                             (* ; "OK to break before this character, provided it's OK to break after the prior char (true of most non-white-space)")
-                                                      (AFTER.LB 8)
-                                                             (* ; 
-  "OK to break after this char, if it's OK to break before the next one (true of most white space)")
-                                                      (DISAPPEAR-IF-NOT-SPLIT.LB 16)
-                                                             (* ; "This character shouldn't be rendered if it isn't the last char on the line (non-breaking hyphen has this)")
-                                                      (NEWCHAR-IF-SPLIT.LB 32)
-                                                             (* ; "Look this char up in *TEDIT-SPLITCHAR-HASH* if this IS the last character on a line, and render it as the char we found.")
-                                                      ])
-
-
-
-(* ;;; "This file is the collected record declarations and compile-time necessities for TEDIT.")
-
-
-
-
-(* ;; "FROM TEDIT")
-
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \SCRATCHLEN 64)
-
-
-(CONSTANTS (\SCRATCHLEN 64))
-)
-)
-
-
-
-(* ;; "FROM TEDITSELECTION")
-
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE SELECTION 
-          (
-           (* ;; "Description of a piece of selected text for TEdit.  Text has to be selected before it can be operated on by the user.")
-
-           Y0                                                (* ; 
-                                                           "Y value of topmost line of selection")
-           X0                                                (* ; 
-                                                           "X value of left edge of selection")
-           DX                                                (* ; 
-                                                     "Width of the selection, if it's on one line.")
-           CH#                                               (* ; 
-                                                           "CH# of the first selected character")
-           XLIM                                              (* ; 
-                                                 "X value of right edge of last selected character")
-           CHLIM                                             (* ; 
-                                                       "CH# of the last character in the selection")
-           DCH                                               (* ; 
-                                     "# of characters selected (can be zero, for point selection.)")
-           L1                                                (* ; 
-                            "-> line descriptor for the line where the first selected character is")
-           LN                                                (* ; 
-                          "-> line descriptor for the line which contains the end of the selection")
-           YLIM                                              (* ; 
-                                        "Y value of the bottom of the line that ends the selection")
-           POINT                                             (* ; 
-                                           "Which end should the caret appear at?  (LEFT or RIGHT)")
-           (SET FLAG)                                        (* ; 
-                                                         "T if this selection is real;  NIL if not")
-           (\TEXTOBJ FULLXPOINTER)                           (* ; 
-                                                         "TEXTOBJ that describes the selected text")
-           SELKIND                                           (* ; 
-                                            "What kind of selection?  CHAR or WORD or LINE or PARA")
-           HOW                                               (* ; 
-                                                           "SHADE used to highlight this selection")
-           HOWHEIGHT                                         (* ; 
-                           "Height of the highlight (1 usually, full line for delete selection...)")
-           (HASCARET FLAG)                                   (* ; 
-                                                  "T if there should be a caret for this selection")
-           SELOBJ                                            (* ; 
-                                             "If this selection is inside an object, which object?")
-           (ONFLG FLAG)                                      (* ; 
-                                        "T if the selection is highlighted on the screen, else NIL")
-           SELOBJINFO                                        (* ; 
-                       "A Place for the selected object to put info about selection inside itself.")
-           )
-          SET _ NIL HOW _ BLACKSHADE HOWHEIGHT _ 1 HASCARET _ T Y0 _ 0 X0 _ 0 POINT _ 'LEFT L1 _
-          (LIST NIL)
-          LN _ (LIST NIL))
-)
-
-(/DECLAREDATATYPE 'SELECTION
-       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG
-               FULLXPOINTER POINTER POINTER POINTER FLAG POINTER FLAG POINTER)
-       '((SELECTION 0 POINTER)
-         (SELECTION 2 POINTER)
-         (SELECTION 4 POINTER)
-         (SELECTION 6 POINTER)
-         (SELECTION 8 POINTER)
-         (SELECTION 10 POINTER)
-         (SELECTION 12 POINTER)
-         (SELECTION 14 POINTER)
-         (SELECTION 16 POINTER)
-         (SELECTION 18 POINTER)
-         (SELECTION 20 POINTER)
-         (SELECTION 20 (FLAGBITS . 0))
-         (SELECTION 22 FULLXPOINTER)
-         (SELECTION 24 POINTER)
-         (SELECTION 26 POINTER)
-         (SELECTION 28 POINTER)
-         (SELECTION 28 (FLAGBITS . 0))
-         (SELECTION 30 POINTER)
-         (SELECTION 30 (FLAGBITS . 0))
-         (SELECTION 32 POINTER))
-       '34)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ COPYSELSHADE 30583)
-
-(RPAQQ COPYLOOKSSELSHADE 30583)
-
-(RPAQQ EDITMOVESHADE -1)
-
-(RPAQQ EDITGRAY 32800)
-
-
-(CONSTANTS (COPYSELSHADE 30583)
-       (COPYLOOKSSELSHADE 30583)
-       (EDITMOVESHADE -1)
-       (EDITGRAY 32800))
-)
-)
-
-(RPAQQ TEDITFILES (PCTREE TEXTOFD TEDIT TEDITABBREV TEDITCOMMAND TEDITDCL TEDITFILE TEDITFIND 
-                             TEDITFNKEYS TEDITHCPY TEDITHISTORY TEDITLOOKS TEDITMENU TEDITPAGE 
-                             TEDITSCREEN TEDITSELECTION TEDITWINDOW))
-
-
-
-(* ;; "FROM TEDITSCREEN")
-
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE THISLINE (
-                        (* ;; 
-      "Cache for line-related character location info, for selection and line-display code to use.")
-
-                        (DESC FULLXPOINTER)                  (* ; 
-                                                  "Line descriptor for the line this describes now")
-                        LEN                                  (* ; 
-                                                           "Length of the line in characters")
-                        CHARS
-
-                        (* ;; "Array of character codes (or objects) on the line (charcode of 400 => dummy entry for looks change--go get next entry in LOOKS)")
-
-                        WIDTHS                               (* ; 
-                                                        "Array of each character's width in points")
-                        LOOKS                                (* ; 
-   "Array of any looks changes within the line.  LOOKS (0) = starting character looks for the line")
-                        TLSPACEFACTOR                        (* ; 
-                                                 "The SPACEFACTOR to be used in printing this line")
-                        TLFIRSTSPACE                         (* ; "The first space to which SPACEFACTOR is to apply.  This is used so that spaces to the left of a TAB have their default width.")
-                        )
-                       LEN _ 0 CHARS _ (ARRAY 512 'POINTER 0 0)
-                       WIDTHS _ (ARRAY 512 'POINTER 0 0)
-                       LOOKS _ (ARRAY 512 'POINTER NIL 0)
-                       TLFIRSTSPACE _ 0)
-
-(DATATYPE LINEDESCRIPTOR 
-          (
-           (* ;; 
-     "Description of a single line of formatted text, either on the display or for a printed page.")
-
-           YBOT                                              (* ; 
-                                           "Y value for the bottom of the line (below the descent)")
-           YBASE                                             (* ; 
-                                                   "Yvalue for the base line the characters sit on")
-           LEFTMARGIN                                        (* ; "Left margin, in screen points")
-           RIGHTMARGIN                                       (* ; "Right margin, in screen points")
-           LXLIM                                             (* ; "X value of right edge of rightmost character on the line (may exceed right margin, if char is a space.)")
-           SPACELEFT                                         (* ; 
-                                          "Space left on the line, ignoring trailing blanks & CRs.")
-           LHEIGHT                                           (* ; 
-                                                        "Total height of hte line, Ascent+Descent.")
-           ASCENT                                            (* ; "Ascent of the line above YBASE")
-           DESCENT                                           (* ; 
-                                                           "How far line descends below YBASE")
-           LTRUEDESCENT                                      (* ; 
-                                     "The TRUE DESCENT for this line, unadjusted for line leading.")
-           LTRUEASCENT                                       (* ; 
-                             "The TRUE ASCENT for this line, unadjusted for pre-paragraph leading.")
-           CHAR1                                             (* ; 
-                                                          "CH# of the first character on the line.")
-           CHARLIM                                           (* ; 
-                                                           "CH# of the last character on the line")
-           CHARTOP                                           (* ; 
-                            "CH# of the character which forced the line break (may exceed CHARLIM)")
-           NEXTLINE                                          (* ; "Next line chain pointer")
-           (PREVLINE FULLXPOINTER)                           (* ; "Previous line chain pointer")
-           LMARK                                             (* ; "One of SOLID, GREY, NIL.  Tells what kind of special-line marker should be put in the left margin for this paragraph.  (For hardcopy, can also be an indicator for special processing?)")
-           LTEXTOBJ                                          (* ; "A cached TEXTOBJ that this line took its text from.  Used in hardcopy to disambiguate when chno's should be updated...")
-           CACHE                                             (* ; "A cached THISLINE, for keeping hardcopy info around while we crunch with the line descriptors to make things fit.")
-           LDOBJ                                             (* ; 
-                               "The object which lies behind this line of text, for updating, etc.")
-           LFMTSPEC                                          (* ; 
-                                           "The format spec for this line's paragraph (eventually)")
-           (DIRTY FLAG)                                      (* ; 
-                                          "T if this line has changed since it was last formatted.")
-           (CR\END FLAG)                                     (* ; "T if this line ends with a CR.")
-           (DELETED FLAG)                                    (* ; "T if this line has been completely deleted since it was last formatted or displayed.  (Used by deletion routines to detect garbage lines)")
-           (LHASPROT FLAG)                                   (* ; 
-                                                           "This line contains protected text.")
-           (LHASTABS FLAG)                                   (* ; "If this line has a tab in it, this is the line-relative ch# of the final tab.  This is to let us punt properly with tabs in a line.")
-           (1STLN FLAG)                                      (* ; 
-                                                       "This line is the first line in a paragraph")
-           (LSTLN FLAG)                                      (* ; 
-                                                           "This is the last line in a paragraph")
-           )
-          CHARLIM _ 1000000 NEXTLINE _ NIL PREVLINE _ NIL DIRTY _ NIL YBOT _ 0 YBASE _ 0 LEFTMARGIN _
-          0 DELETED _ NIL)
-
-(DATATYPE LINECACHE (
-                         (* ;; "Image cache for display lines.")
-
-                         LCBITMAP                            (* ; 
-                                       "The bitmap that will be used by this instance of the cache")
-                         (LCNEXTCACHE FULLXPOINTER)          (* ; 
-                                                 "The next cache in the chain, for screen updates.")
-                         ))
-)
-
-(/DECLAREDATATYPE 'THISLINE '(FULLXPOINTER POINTER POINTER POINTER POINTER POINTER POINTER)
-       '((THISLINE 0 FULLXPOINTER)
-         (THISLINE 2 POINTER)
-         (THISLINE 4 POINTER)
-         (THISLINE 6 POINTER)
-         (THISLINE 8 POINTER)
-         (THISLINE 10 POINTER)
-         (THISLINE 12 POINTER))
-       '14)
-
-(/DECLAREDATATYPE 'LINEDESCRIPTOR
-       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-               POINTER POINTER POINTER POINTER FULLXPOINTER POINTER POINTER POINTER POINTER POINTER 
-               FLAG FLAG FLAG FLAG FLAG FLAG FLAG)
-       '((LINEDESCRIPTOR 0 POINTER)
-         (LINEDESCRIPTOR 2 POINTER)
-         (LINEDESCRIPTOR 4 POINTER)
-         (LINEDESCRIPTOR 6 POINTER)
-         (LINEDESCRIPTOR 8 POINTER)
-         (LINEDESCRIPTOR 10 POINTER)
-         (LINEDESCRIPTOR 12 POINTER)
-         (LINEDESCRIPTOR 14 POINTER)
-         (LINEDESCRIPTOR 16 POINTER)
-         (LINEDESCRIPTOR 18 POINTER)
-         (LINEDESCRIPTOR 20 POINTER)
-         (LINEDESCRIPTOR 22 POINTER)
-         (LINEDESCRIPTOR 24 POINTER)
-         (LINEDESCRIPTOR 26 POINTER)
-         (LINEDESCRIPTOR 28 POINTER)
-         (LINEDESCRIPTOR 30 FULLXPOINTER)
-         (LINEDESCRIPTOR 32 POINTER)
-         (LINEDESCRIPTOR 34 POINTER)
-         (LINEDESCRIPTOR 36 POINTER)
-         (LINEDESCRIPTOR 38 POINTER)
-         (LINEDESCRIPTOR 40 POINTER)
-         (LINEDESCRIPTOR 40 (FLAGBITS . 0))
-         (LINEDESCRIPTOR 40 (FLAGBITS . 16))
-         (LINEDESCRIPTOR 40 (FLAGBITS . 32))
-         (LINEDESCRIPTOR 40 (FLAGBITS . 48))
-         (LINEDESCRIPTOR 38 (FLAGBITS . 0))
-         (LINEDESCRIPTOR 38 (FLAGBITS . 16))
-         (LINEDESCRIPTOR 38 (FLAGBITS . 32)))
-       '42)
-
-(/DECLAREDATATYPE 'LINECACHE '(POINTER FULLXPOINTER)
-       '((LINECACHE 0 POINTER)
-         (LINECACHE 2 FULLXPOINTER))
-       '4)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ LMInvisibleRun 401)
-
-(RPAQQ LMLooksChange 400)
-
-
-(CONSTANTS (LMInvisibleRun 401)
-       (LMLooksChange 400))
-)
-)
-
-
-
-(* ;; "FROM TEXTOFD")
-
-(DECLARE%: EVAL@COMPILE
-
-(RECORD EDITMARK (
-                      (* ;; "Used for fast access to a given place in the text--a %"Marker%".   It consists of the piece, and the offset within the piece, and the piece number within the piece table.  That's everything that's needed to set a text stream up quickly to start reading from a given place.")
-
-                      PC PCOFF . PCNO))
-)
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE PIECE 
-          (                                                  (* ; 
-               "The piece describes either a string or part of a file.  , or a generalized OBJECT.")
-           PSTR                                              (* ; 
-                                               "The string where this piece's text resides, or NIL")
-           PFILE                                             (* ; 
-                                                "The file which contains this piece's text, or NIL")
-           (PFPOS FIXP)                                      (* ; 
-                                                "The FILEPTR of the start of the piece in the file")
-           (PLEN FIXP)                                       (* ; 
-                                                           "Length of the piece, in characters.")
-           (NEXTPIECE FULLXPOINTER)                          (* ; "-> Next piece in this textobj.")
-           (PREVPIECE FULLXPOINTER)                          (* ; 
-                                                           "-> Prior piece in this text object.")
-           PLOOKS                                            (* ; 
-                                              "Formatting info and formatting events in this piece")
-           POBJ                                              (* ; "The OBJECT this piece describes")
-           (PPARALAST FLAG)                                  (* ; 
-                                                           "This piece contains a paragraph break")
-           PPARALOOKS                                        (* ; "Paragraph looks for this piece")
-           (PNEW FLAG)                                       (* ; 
-           "This text is new here;  used by the tentative edit system, and anyone else interested.")
-           (PFATP FLAG)                                      (* ; 
-                             "T if the characters in this piece are FAT -- i.e., are 16 bits each.")
-           (PTREENODE XPOINTER)                              (* ; 
-                                           "Points to the PCTB tree-node that contains this piece.")
-           )
-          PSTR _ NIL PFILE _ NIL PFPOS _ 0 PLEN _ 0 PPARALOOKS _ TEDIT.DEFAULT.FMTSPEC PTREENODE _ 
-          NIL)
-
-(DATATYPE TEXTOBJ 
-          (
-           (* ;; 
- "This is where TEdit stores its state information, and internal data about the text being edited.")
-
-           PCTB                                              (* ; "The piece table")
-           TEXTLEN                                           (* ; "# of chars in the text")
-           \INSERTPC                                         (* ; "Piece to hold type-in")
-           \INSERTPCNO                                       (* ; "Piece # of the input piece")
-           \INSERTNEXTCH                                     (* ; 
-                                                 "CH# of next char which is typed into that piece.")
-           \INSERTLEFT                                       (* ; "Space left in the type-in piece")
-           \INSERTLEN                                        (* ; 
-                                                           "# of characters already in the piece.")
-           \INSERTSTRING                                     (* ; 
-                                                           "The string which the piece describes.")
-           \INSERTFIRSTCH                                    (* ; "CH# of first char in the piece.")
-           (\INSERTPCVALID FLAG)                             (* ; "T if it's OK to use the cached piece.  Set to NIL by people who require that the next insertion/deletion use a different piece.")
-           \WINDOW                                           (* ; 
-                                                    "The window<s> where this textobj is displayed")
-           MOUSEREGION                                       (* ; 
-                                                           "Section of the window the mouse is in.")
-           LINES                                             (* ; 
-                                        "-> to top of chain of line descriptors for displayed text")
-           DS                                                (* ; 
-                                                   "Display stream where this textobj is displayed")
-           SEL                                               (* ; 
-                                                           "The current selection within the text")
-           SCRATCHSEL                                        (* ; 
-                                                           "Scratch space for the selection code")
-           MOVESEL                                           (* ; 
-                                                           "Source for the next MOVE of text")
-           SHIFTEDSEL                                        (* ; "Source for the next COPY")
-           DELETESEL                                         (* ; "Text to be deleted imminently")
-           WRIGHT                                            (* ; 
-                                  "Right edge of the window (or subregion) where this is displayed")
-           WTOP                                              (* ; "Top of the window/region")
-           WBOTTOM                                           (* ; "Bottom of the window/region")
-           WLEFT                                             (* ; "Left edge of the window/region")
-           TXTFILE                                           (* ; 
-                                                           "The original text file we're editing")
-           (\XDIRTY FLAG)                                    (* ; "T => changed since last saved.")
-           (STREAMHINT FULLXPOINTER)                         (* ; 
-                                         "-> the TEXTOFD stream which gives access to this textobj")
-           EDITFINISHEDFLG                                   (* ; 
-                                                      "T => The guy has asked the editor to go way")
-           CARET                                             (* ; 
-                                              "Describes the flashing caret for the editing window")
-           CARETLOOKS                                        (* ; 
-                                                           "Font to be used for inserted text.")
-           WINDOWTITLE                                       (* ; 
-                                                "Original title for this window, of there was one.")
-           THISLINE                                          (* ; 
-                                             "Cache of line-related info, to speed up selection &c")
-           (MENUFLG FLAG)                                    (* ; 
-                                                          "T if this TEXTOBJ is a tedit-style menu")
-           FMTSPEC                                           (* ; 
-                                    "Default Formatting Spec to be used when formatting paragraphs")
-           (FORMATTEDP FLAG)                                 (* ; 
-"Flag for paragraph formatting.  T if this document is to contain paragraph formatting information.")
-           (TXTREADONLY FLAG)                                (* ; 
-                                                      "This is only available for shift selection.")
-           (TXTEDITING FLAG)                                 (* ; "T => This document is in a window and there is an edit process behind it.  For example, it only makes sense to have a caret show up if you are editing.")
-           (TXTNONSCHARS FLAG)                               (* ; "T => If TEdit rns into a 255, it won't attempt to convert to NS characters.  Used for REALLY plain-text manipulation.")
-           TXTTERMSA                                         (* ; 
-                                     "Special instructions for displaying characters on the screen")
-           EDITOPACTIVE                                      (* ; 
-                "T if there is an editing operation in progress.  Used to interlock the TEdit menu")
-           DEFAULTCHARLOOKS                                  (* ; "The default character looks -- if any -- to be applied to characters coming into the file from outside.")
-           TXTRTBL                                           (* ; 
-                                "The READTABLE to be used by the command loop for command dispatch")
-           TXTWTBL                                           (* ; 
-                                                "The READTABLE to be used to decide on word breaks")
-           EDITPROPS                                         (* ; 
-                                                "The PROPS that were passed into this edit session")
-           (BLUEPENDINGDELETE FLAG)                          (* ; "T if the next insertion in this document is to be preceded by a deletion of the then-current selection")
-           TXTHISTORY                                        (* ; 
-                                                          "The history list for this edit session.")
-           (SELWINDOW FULLXPOINTER)                          (* ; "The window in which the last 'real' selection got made for this edit;  used to control caret placement")
-           PROMPTWINDOW                                      (* ; 
- "A window to be used for unscheduled interactions;  normally a small window above the edit window")
-           DISPLAYCACHE                                      (* ; 
-                              "The bitmap to be used when building the image of a line for display")
-           DISPLAYCACHEDS                                    (* ; 
-                                              "The DISPLAYSTREAM that is used to build line images")
-           DISPLAYHCPYDS                                     (* ; "The DISPLAYSTREAM used to build line images of lines that are displayed in 'hardcopy' simulation mode")
-           TXTPAGEFRAMES                                     (* ; 
-                            "A tree of page frames, specifying how the document is to be laid out.")
-           TXTCHARLOOKSLIST                                  (* ; 
-                           "List of all the CHARLOOKSs in the document, so they can be kept unique")
-           TXTPARALOOKSLIST                                  (* ; 
-                             "List of all the FMTSPECs in the document, so they can be kept unique")
-           (TXTNEEDSUPDATE FLAG)                             (* ; 
-                                                         "T => Screen invalid, need to run updater")
-           (TXTDON'TUPDATE FLAG)                             (* ; "T if we're holding off on screen updates until later.  Used, e.g., by the menu-SHOW code so that you don't get piecemeal updates, but only one at the end of the SHOW.")
-           TXTRAWINCLUDESTREAM                               (* ; 
-                     "NODIRCORE stream used to cache RAW includes (and maybe later, all includes?)")
-           DOCPROPS                                          (* ; 
-                             "Document properties that are stored with the document (not used yet)")
-           TXTSTYLESHEET                                     (* ; 
-                    "Style sheet local to this document.  Not currently saved as part of the file.")
-           )
-          [ACCESSFNS TEXTOBJ ((\DIRTY (ffetch (TEXTOBJ \XDIRTY) of DATUM)
-                                     (PROGN (IF (NEQ (FETCH (TEXTOBJ \XDIRTY) OF DATUM)
-                                                         NEWVALUE)
-                                                THEN     (* ; 
-                                                           "update the title to reflect the change")
-                                                      (\TEDIT.WINDOW.TITLE DATUM
-                                                             (\TEDIT.ORIGINAL.WINDOW.TITLE
-                                                              (ffetch (TEXTOBJ TXTFILE)
-                                                                 of DATUM)
-                                                              NEWVALUE)))
-                                            (freplace \XDIRTY OF DATUM WITH NEWVALUE]
-          SEL _ (create SELECTION)
-          SCRATCHSEL _ (create SELECTION)
-          MOVESEL _ (create SELECTION
-                           HOWHEIGHT _ 32767
-                           HASCARET _ NIL)
-          SHIFTEDSEL _ (create SELECTION
-                              HASCARET _ NIL)
-          DELETESEL _ (create SELECTION
-                             HOWHEIGHT _ 32767
-                             HASCARET _ NIL)
-          \INSERTNEXTCH _ -1 \INSERTPC _ NIL \INSERTLEFT _ 0 \INSERTLEN _ 0 \INSERTSTRING _ NIL 
-          \INSERTFIRSTCH _ 1000000 TEXTLEN _ 0 WRIGHT _ 0 WTOP _ 0 WLEFT _ 0 WBOTTOM _ 0 TXTFILE _ 
-          NIL \XDIRTY _ NIL MOUSEREGION _ 'TEXT THISLINE _ (create THISLINE)
-          MENUFLG _ NIL FMTSPEC _ TEDIT.DEFAULT.FMTSPEC FORMATTEDP _ NIL)
-
-(DATATYPE TEXTIMAGEDATA (
-                             (* ;; "Fills the IMAGEDATA field of text streams.")
-
-                             TICURPARALOOKS                  (* ; "The current paragraph looks")
-                             TICURIMAGESTREAM                (* ; 
-                                                  "The image stream for this hardcopy transduction")
-                             TILOOKSUPDATEFN                 (* ; 
-                                             "The function to call to update looks for this stream")
-                             TIPCOFFSET                      (* ; 
-                                    "The offset into the current piece, as of the last page cross.")
-                             ))
-
-(ACCESSFNS TEXTSTREAM (
-                           (* ;; 
-        "Overlay for the STREAM record to allow mnemonic access to stream fields for Text streams.")
-
-                           (REALFILE (fetch F1 of DATUM)
-                                  (REPLACE F1 OF DATUM WITH NEWVALUE))
-                                                             (* ; 
-                                               "The real, underlying file behind the current piece")
-                           (CHARSLEFT (fetch F2 of DATUM)
-                                  (REPLACE F2 OF DATUM WITH NEWVALUE))
-
-                           (* ;; "The # of characters that will be left in the current piece the next time its file crosses a page boundary")
-
-                           (TEXTOBJ (fetch F3 of DATUM)
-                                  (REPLACE F3 OF DATUM WITH NEWVALUE))
-                                                             (* ; 
-                                                           "The TEXTOBJ that is editing this text")
-                           (PIECE (fetch F5 of DATUM)
-                                  (REPLACE F5 OF DATUM WITH NEWVALUE))
-                                                             (* ; 
-                                 "The PIECE we're currently fetching chars from/putting chars into")
-                           (PCNO (fetch FW8 of DATUM)
-                                 (REPLACE FW8 OF DATUM WITH NEWVALUE))
-                                                             (* ; 
-                                                    "The position of that piece in the piece table")
-                           (PCSTARTPG (fetch FW6 of DATUM)
-                                  (REPLACE FW6 OF DATUM WITH NEWVALUE))
-                                                             (* ; 
-                                              "The underlying file page# that this piece starts on")
-                           (PCSTARTCH (fetch FW7 of DATUM)
-                                  (REPLACE FW7 OF DATUM WITH NEWVALUE))
-                                                             (* ; 
-        "The char within page of the underlying file that this piece starts on -- for backbin & co")
-                           (PCOFFSET (fetch TIPCOFFSET of (fetch IMAGEDATA of DATUM))
-                                  (REPLACE TIPCOFFSET OF (fetch IMAGEDATA of DATUM)
-                                     with NEWVALUE))     (* ; 
-                                    "The offset into the current piece, as of the last page cross.")
-                           (CURRENTLOOKS (fetch F10 of DATUM)
-                                  (replace F10 of DATUM with NEWVALUE))
-                                                             (* ; 
-           "The CHARLOOKS that are currently applicable to characters being taken from the stream.")
-                           (CURRENTPARALOOKS (fetch TICURPARALOOKS of (fetch IMAGEDATA
-                                                                                 of DATUM))
-                                  (REPLACE TICURPARALOOKS OF (fetch IMAGEDATA
-                                                                        of DATUM) with 
-                                                                                            NEWVALUE)
-                                  )                          (* ; 
-              "The FMTSPEC that is currently applicable to characters being taken from the stream.")
-                           (CURRENTIMAGESTREAM (fetch TICURIMAGESTREAM
-                                                  of (fetch IMAGEDATA of DATUM))
-                                  (REPLACE TICURIMAGESTREAM OF (fetch IMAGEDATA
-                                                                          of DATUM) with
-                                                                                        NEWVALUE)
-                                                             (* ; 
-                   "The image stream that this text is being put onto;  used for scaling decisions")
-                                  )
-                           (LOOKSUPDATEFN (fetch TILOOKSUPDATEFN of (fetch IMAGEDATA
-                                                                               of DATUM))
-                                  (REPLACE TILOOKSUPDATEFN OF (fetch IMAGEDATA
-                                                                         of DATUM) with
-                                                                                       NEWVALUE))
-                                                             (* ; 
-                                          "Function to be called each time character looks change.")
-                           (FATSTREAMP (fetch F4 of DATUM)
-                                  (REPLACE F4 OF DATUM WITH NEWVALUE))
-                                                             (* ; 
-                                                     "T if the current piece is 16 bit characters.")
-                           )
-                          (CREATE (create STREAM using \TEXTOFD IMAGEDATA _ (create
-                                                                                         
-                                                                                        TEXTIMAGEDATA
-                                                                                         ))))
-)
-
-(/DECLAREDATATYPE 'PIECE '(POINTER POINTER FIXP FIXP FULLXPOINTER FULLXPOINTER POINTER POINTER FLAG 
-                                 POINTER FLAG FLAG XPOINTER)
-       '((PIECE 0 POINTER)
-         (PIECE 2 POINTER)
-         (PIECE 4 FIXP)
-         (PIECE 6 FIXP)
-         (PIECE 8 FULLXPOINTER)
-         (PIECE 10 FULLXPOINTER)
-         (PIECE 12 POINTER)
-         (PIECE 14 POINTER)
-         (PIECE 14 (FLAGBITS . 0))
-         (PIECE 16 POINTER)
-         (PIECE 16 (FLAGBITS . 0))
-         (PIECE 16 (FLAGBITS . 16))
-         (PIECE 18 XPOINTER))
-       '20)
-
-(/DECLAREDATATYPE 'TEXTOBJ
-       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER
-               POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-               POINTER POINTER FLAG FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER
-               FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER 
-               FULLXPOINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG POINTER
-               POINTER POINTER)
-       '((TEXTOBJ 0 POINTER)
-         (TEXTOBJ 2 POINTER)
-         (TEXTOBJ 4 POINTER)
-         (TEXTOBJ 6 POINTER)
-         (TEXTOBJ 8 POINTER)
-         (TEXTOBJ 10 POINTER)
-         (TEXTOBJ 12 POINTER)
-         (TEXTOBJ 14 POINTER)
-         (TEXTOBJ 16 POINTER)
-         (TEXTOBJ 16 (FLAGBITS . 0))
-         (TEXTOBJ 18 POINTER)
-         (TEXTOBJ 20 POINTER)
-         (TEXTOBJ 22 POINTER)
-         (TEXTOBJ 24 POINTER)
-         (TEXTOBJ 26 POINTER)
-         (TEXTOBJ 28 POINTER)
-         (TEXTOBJ 30 POINTER)
-         (TEXTOBJ 32 POINTER)
-         (TEXTOBJ 34 POINTER)
-         (TEXTOBJ 36 POINTER)
-         (TEXTOBJ 38 POINTER)
-         (TEXTOBJ 40 POINTER)
-         (TEXTOBJ 42 POINTER)
-         (TEXTOBJ 44 POINTER)
-         (TEXTOBJ 44 (FLAGBITS . 0))
-         (TEXTOBJ 46 FULLXPOINTER)
-         (TEXTOBJ 48 POINTER)
-         (TEXTOBJ 50 POINTER)
-         (TEXTOBJ 52 POINTER)
-         (TEXTOBJ 54 POINTER)
-         (TEXTOBJ 56 POINTER)
-         (TEXTOBJ 56 (FLAGBITS . 0))
-         (TEXTOBJ 58 POINTER)
-         (TEXTOBJ 58 (FLAGBITS . 0))
-         (TEXTOBJ 58 (FLAGBITS . 16))
-         (TEXTOBJ 58 (FLAGBITS . 32))
-         (TEXTOBJ 58 (FLAGBITS . 48))
-         (TEXTOBJ 60 POINTER)
-         (TEXTOBJ 62 POINTER)
-         (TEXTOBJ 64 POINTER)
-         (TEXTOBJ 66 POINTER)
-         (TEXTOBJ 68 POINTER)
-         (TEXTOBJ 70 POINTER)
-         (TEXTOBJ 70 (FLAGBITS . 0))
-         (TEXTOBJ 72 POINTER)
-         (TEXTOBJ 74 FULLXPOINTER)
-         (TEXTOBJ 76 POINTER)
-         (TEXTOBJ 78 POINTER)
-         (TEXTOBJ 80 POINTER)
-         (TEXTOBJ 82 POINTER)
-         (TEXTOBJ 84 POINTER)
-         (TEXTOBJ 86 POINTER)
-         (TEXTOBJ 88 POINTER)
-         (TEXTOBJ 88 (FLAGBITS . 0))
-         (TEXTOBJ 88 (FLAGBITS . 16))
-         (TEXTOBJ 90 POINTER)
-         (TEXTOBJ 92 POINTER)
-         (TEXTOBJ 94 POINTER))
-       '96)
-
-(/DECLAREDATATYPE 'TEXTIMAGEDATA '(POINTER POINTER POINTER POINTER)
-       '((TEXTIMAGEDATA 0 POINTER)
-         (TEXTIMAGEDATA 2 POINTER)
-         (TEXTIMAGEDATA 4 POINTER)
-         (TEXTIMAGEDATA 6 POINTER))
-       '8)
-
-(DEFOPTIMIZER TEXTPROP (TEXTOBJ PROP &OPTIONAL (VAL NIL WRITING))
-
-                           (* ;; "compiles calls to TEXTPROP")
-
-                           [COND
-                              ((NOT (LISTP PROP))            (* ; "property is not quoted.")
-                               'IGNOREMACRO)
-                              ((NOT (EQ (CAR PROP)
-                                        'QUOTE))             (* ; "property is not quoted.")
-                               'IGNOREMACRO)
-                              [(NOT WRITING)                 (* ; "fetching a TEXTPROP property.")
-                               (SELECTQ (CADR PROP)
-                                   ((READONLY READ-ONLY) 
-                                        `(fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ
-                                                                                  ,TEXTOBJ)))
-                                   ((BEING-EDITED ACTIVE) 
-                                        `(fetch (TEXTOBJ TXTEDITING) of (TEXTOBJ ,TEXTOBJ)))
-                                   ((NO-NS-CHARS NONSCHARS NO-NSCHARS) 
-                                        `(fetch (TEXTOBJ TXTNONSCHARS) of (TEXTOBJ
-                                                                                   ,TEXTOBJ)))
-                                   `(LISTGET (fetch (TEXTOBJ EDITPROPS)
-                                                of (TEXTOBJ ,TEXTOBJ))
-                                           ,PROP]
-                              (T                             (* ; "storing a window property")
-                                 (SELECTQ (CADR PROP)
-                                     ((READONLY READ-ONLY) 
-                                          `(REPLACE (TEXTOBJ TXTREADONLY)
-                                              OF (TEXTOBJ ,TEXTOBJ) WITH ,VAL))
-                                     ((BEING-EDITED ACTIVE) 
-                                          `(REPLACE (TEXTOBJ TXTEDITING)
-                                              OF (TEXTOBJ ,TEXTOBJ) WITH ,VAL))
-                                     ((NO-NS-CHARS NONSCHARS NO-NSCHARS) 
-                                          `(REPLACE (TEXTOBJ TXTNONSCHARS)
-                                              OF (TEXTOBJ ,TEXTOBJ) WITH ,VAL))
-                                     `(LET* (($$TEXTOBJ$$ (TEXTOBJ ,TEXTOBJ))
-                                             ($$PROPLST$$ (FETCH EDITPROPS OF $$TEXTOBJ$$)))
-                                            (COND
-                                               ($$PROPLST$$ (LISTPUT $$PROPLST$$ ,PROP ,VAL))
-                                               (T (REPLACE EDITPROPS OF $$TEXTOBJ$$
-                                                     WITH (LIST ,PROP ,VAL])
-
-
-
-(* ;; "Private data structures and constants FROM TEXTOFD")
-
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \PCTBFreePieces 0)
-
-(RPAQQ \PCTBLastPieceOffset 1)
-
-(RPAQQ \FirstPieceOffset 2)
-
-(RPAQQ \SecondPieceOffset 4)
-
-(RPAQQ \EltsPerPiece 2)
-
-
-(CONSTANTS (\PCTBFreePieces 0)
-       (\PCTBLastPieceOffset 1)
-       (\FirstPieceOffset 2)
-       (\SecondPieceOffset 4)
-       (\EltsPerPiece 2))
-)
-
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \EDITELT DMACRO (OPENLAMBDA (ARR NO)
-
-         (* This is equivalent to ELT, but bypasses the checking, since we "know" that 
-       ARR is an array. Hence, much faster.)
-
-                                         (GETBASEPTR (\ADDBASE2 (fetch (ARRAYP BASE) of
-                                                                                         ARR)
-                                                            NO)
-                                                0)))
-
-(PUTPROPS \GETCH MACRO ((TEXTOBJ)                (* jds "23-FEB-82 08:56")
-                                                             (* Get the next available character 
-                                                           from the text being edited.)
-                                (\BIN (fetch STREAMHINT of TEXTOBJ))))
-
-(PUTPROPS \GETCHB MACRO ((TEXTOBJ)                   (* Get the next prior character in 
-                                                           the text being edited.)
-                                 (\BACKBIN (fetch STREAMHINT of TEXTOBJ))))
-
-(PUTPROPS \EDITSETA DMACRO (OPENLAMBDA (ARR N VAL)
-
-         (* Equivalent to SETA (for pointer-type arrays)%, but bypasses the bounds and 
-       type checking. Hence MUCH faster.)
-
-                                          (\RPLPTR (\ADDBASE2 (fetch (ARRAYP BASE) of ARR)
-                                                          N)
-                                                 0 VAL)))
-
-(PUTPROPS \WORDSETA DMACRO (OPENLAMBDA (A J V)
-                                          [CHECK (AND (ARRAYP A)
-                                                      (ZEROP (fetch (ARRAYP ORIG) of A))
-                                                      (EQ \ST.POS16 (fetch (ARRAYP TYP)
-                                                                       of A]
-                                          (CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A)
-                                                        J))
-                                          (\PUTBASE (fetch (ARRAYP BASE) of A)
-                                                 (IPLUS (fetch (ARRAYP OFFST) of A)
-                                                        J)
-                                                 V)))
-)
-
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \TEXTIMAGEOPS \TEXTOFD \TEXTFDEV)
-)
-)
-
-
-
-(* ;;; "FROM TEDITPAGE")
-
-(DECLARE%: EVAL@COMPILE
-
-(RECORD PAGEFORMATTINGSTATE (
-                                 (* ;; "Contains the state for a TEdit page-formatting job.")
-
-                                 PAGE#                       (* ; 
-                                                         "The current page number.  Counted from 1")
-                                 FIRSTPAGE
-
-                                 (* ;; "T if the current page is the 'first page' .  Is set initially, and can be set again by the user at will.  Gets reset after each page image is printed.")
-
-                                 MINPAGE#                    (* ; 
-                                               "The page # of the first page to be printed, or NIL")
-                                 MAXPAGE#                    (* ; 
-                                                "The page # of the last page to be printed, or NIL")
-                                 STATE                       (* ; "One of FORMATTING or SEARCHING.")
-                                 REQUIREDREGIONTYPE          (* ; "If STATE is SEARCHING, the kind of box we're looking for.  If STATE is :SEARCHING-FOR-EQUIVALENT-PAGE, this is the page count for the matching page.")
-                                 MAINSTREAM                  (* ; 
-                                                           "The principal textobj/stream source")
-                                 CHNO                        (* ; "Our position in that stream")
-                                 PRESSREGION                 (* ; "The press code's REGION info.")
-                                 PAGEHEADINGS                (* ; 
-                                "The list of current values to be printed, indexed by heading type")
-                                 PAGE#GENERATOR              (* ; "List of page numbers;  later, maybe, a function to generate page numbers.  Used to fill in PAGE#TEXT, below")
-                                 PAGE#TEXT                   (* ; "If special page numbers are in use, this is the place to take them from.  PAGE# is still used for recto/verso decisions &c")
-                                 PAGEISRECTO                 (* ; 
-                                             "T if this is a recto page, NIL if it's a VERSO page.")
-                                 PAGEFOOTNOTELINES           (* ; 
-                       "A list of extant footnote lines that should appear at the next opportunity")
-                                 PAGEFLOATINGTOPLINES        (* ; 
-                         "A list of lines that should float to the top of the next available place")
-                                 PAGECOUNT                   (* ; 
-                                                      "The number of pages we've formatted so far.")
-                                 PAGELINECACHE               (* ; "A cache for pre-created LINEDESCRIPTOR/THISLINE sets, to avoid the overhead of re-allocating them all the time")
-                                 NEWPAGELAYOUT               (* ; "If we switch page layouts in mid-document, this is where the new layout gets cached until we get started again.")
-                                 )
-                                PAGECOUNT _ 0)
-
-(DATATYPE PAGEREGION (
-                          (* ;; 
-          "Describe a part of a page for page formatting.  Can be made into compound descriptions.")
-
-                          REGIONFILLMETHOD                   (* ; 
-                                  "What kind of a region this is -- TEXT, FOLIO, PAGEHEADING, etc.")
-                          REGIONSPEC                         (* ; 
-                                                           "The page-relative region this occupies")
-                          REGIONLOCALINFO                    (* ; "A PLIST for local information")
-                          (REGIONPARENT FULLXPOINTER)        (* ; 
-                                                      "The parent node for this box, for sub-boxes")
-                          REGIONSUBBOXES                     (* ; "The sub-regions of this region")
-                          REGIONTYPE                         (* ; "A user-settable region type")
-                          ))
-)
-
-(/DECLAREDATATYPE 'PAGEREGION '(POINTER POINTER POINTER FULLXPOINTER POINTER POINTER)
-       '((PAGEREGION 0 POINTER)
-         (PAGEREGION 2 POINTER)
-         (PAGEREGION 4 POINTER)
-         (PAGEREGION 6 FULLXPOINTER)
-         (PAGEREGION 8 POINTER)
-         (PAGEREGION 10 POINTER))
-       '12)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(RECORD TEDITPAPERSIZE (
-                            (* ;; 
-                      "Describe the size of a sheet of paper (in points), given a paper size-name.")
-
-                            TPSNAME                          (* ; "The name, as a litatom")
-                            TPSWIDTH                         (* ; "Paper width, in points")
-                            TPSHEIGHT                        (* ; "Paper Height, in points")
-                            TPSLANDSCAPE?                    (* ; 
-                                       "T if we have to rotate things to print them on this paper.")
-                            ))
-)
-
-
-(DEFMACRO \NEW-COLUMN-START (LINE FMTSPEC)
-   `(AND (FFETCH (LINEDESCRIPTOR 1STLN) OF ,LINE)
-         (EQ (FFETCH (FMTSPEC FMTCOLUMN) OF ,FMTSPEC)
-             'NEXT)))
-
-(DEFMACRO \FIRST-COLUMN-START (LINE FMTSPEC)
-   `(AND (FFETCH (LINEDESCRIPTOR 1STLN) OF ,LINE)
-         (EQ (FFETCH (FMTSPEC FMTCOLUMN) OF ,FMTSPEC)
-             'FIRST)))
-)
-
-
-
-(* ;; "FROM TEDITFIND")
-
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \AlphaNumericFlag 256)
-
-(RPAQQ \AlphaFlag 512)
-
-(RPAQQ \OneCharPattern 1024)
-
-(RPAQQ \AnyStringPattern 1025)
-
-(RPAQQ \OneAlphaPattern 1026)
-
-(RPAQQ \AnyAlphaPattern 1027)
-
-(RPAQQ \OneNonAlphaPattern 1028)
-
-(RPAQQ \AnyNonAlphaPattern 1029)
-
-(RPAQQ \LeftBracketPattern 1030)
-
-(RPAQQ \RightBracketPattern 1031)
-
-(RPAQQ \SpecialPattern 1024)
-
-
-(CONSTANTS (\AlphaNumericFlag 256)
-       (\AlphaFlag 512)
-       (\OneCharPattern 1024)
-       (\AnyStringPattern 1025)
-       (\OneAlphaPattern 1026)
-       (\AnyAlphaPattern 1027)
-       (\OneNonAlphaPattern 1028)
-       (\AnyNonAlphaPattern 1029)
-       (\LeftBracketPattern 1030)
-       (\RightBracketPattern 1031)
-       (\SpecialPattern 1024))
-)
-)
-
-
-
-(* ;; " FROM TEDITLOOKS")
-
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE CHARLOOKS (
-                         (* ;; 
-                       "Describes the appearance (%"Looks%") of characters in a TEdit document.")
-
-                         CLFONT                              (* ; 
-                                                         "The font descriptor for these characters")
-                         CLNAME
-
-                         (* ;; "Name of the font (e.g., HELVETICA) THIS FIELD IS A HINT, OR FOR USE IN CHARLOOKS-BUILDING CODE.  USE FONTPROP TO GET THE RIGHT VALUE FROM CLFONT.")
-
-                         CLSIZE                              (* ; "Font size, in points")
-                         (CLITAL FLAG)                       (* ; 
-                                                         "T if the characters are italic, else NIL")
-                         (CLBOLD FLAG)                       (* ; 
-                                                           "T if the characters are bold, else NIL")
-                         (CLULINE FLAG)                      (* ; 
-                                              "T if the characters are to be underscored, else NIL")
-                         (CLOLINE FLAG)                      (* ; 
-                                               "T if the characters are to be overscored, else NIL")
-                         (CLSTRIKE FLAG)                     (* ; 
-                                             "T if the characters are to be struck thru, else nil.")
-                         CLOFFSET                            (* ; 
-                       "A superscripting offset in points (?) else NIL (SUBSCRIPTING IF NEGATIVE.)")
-                         (CLSMALLCAP FLAG)                   (* ; "T if small caps, else NIL")
-                         (CLINVERTED FLAG)                   (* ; 
-                                               "T if the characters are to be shown white-on-black")
-                         (CLPROTECTED FLAG)                  (* ; 
-                                                           "T if chars can't be selected, else NIL")
-                         (CLINVISIBLE FLAG)                  (* ; 
-                                                   "T if TEDIT is to ignore these chars;  else NIL")
-                         (CLSELHERE FLAG)
-
-                         (* ;; "T if TEDIT can put selection after this char (for menu blanks) else NIL;  anything typed after this char will NOT BE PROTECTED.")
-
-                         (CLCANCOPY FLAG)
-
-                         (* ;; "T if this text can be selected for copying, even tho protected (it will become unprotected after the copy;  for Dribble/TTY interface)")
-
-                         CLSTYLE                             (* ; 
-                "The style to be used in marking these characters;  overridden by the other fields")
-                         CLUSERINFO                          (* ; 
-                                                "Any information that an outsider wants to include")
-                         CLLEADER                            (* ; 
-                                                    "For creating dotted and other kinds of leader")
-                         CLRULES
-
-                         (* ;; "For arbitrarily-places horizontal rules.  List of pairs, of (widthinpts  . offsetfrombaselineinpts).  Should be taken account of in ascent/descent calcs.")
-
-                         (CLMARK FLAG)
-
-                         (* ;; "Used for a mark-&-sweep of looks at PUT time -- T means this set of looks really IS in use in the document")
-
-                         )
-                        CLOFFSET _ 0)
-
-(DATATYPE FMTSPEC (
-                       (* ;; 
-                     "Describe the paragraph formatting for a paragraph in a TEdit document.")
-
-                       1STLEFTMAR                            (* ; 
-                                                   "Left margin of the first line of the paragraph")
-                       LEFTMAR                               (* ; 
-                                            "Left margin of the rest of the lines in the paragraph")
-                       RIGHTMAR                              (* ; "Right margin for the paragraph")
-                       LEADBEFORE                            (* ; 
-                                              "Leading above the paragraph's first line, in points")
-                       LEADAFTER                             (* ; 
-                          "Leading below the paragraph's bottom line, in points.  NOT IMPLEMENTED.")
-                       LINELEAD                              (* ; 
-    "Leading between lines, in points.  Actually, this space is added BELOW each line in the para.")
-                       FMTBASETOBASE                         (* ; 
-"The baseline-to-baseline spacing between lines in this paragraph.  THIS OVERRIDES THE LINE LEADING")
-                       TABSPEC                               (* ; 
-                       "The list of tabs for this paragraph, including CAR for a default tab width")
-                       QUAD                                  (* ; 
-                               "How the para is formatted: one of LEFT, RIGHT, CENTERED, JUSTIFIED")
-                       FMTSTYLE                              (* ; 
-                                              "The STYLE that controls this paragraph's appearance")
-                       FMTCHARSTYLES                         (* ; "The characterstyles that control the appearance of characters in this para (maybe?  may be part of the fmtstyle.)")
-                       FMTUSERINFO                           (* ; "Space for a PLIST of user info")
-                       FMTSPECIALX                           (* ; 
-                                 "A special horizontal location on the printed page for this para.")
-                       FMTSPECIALY                           (* ; 
-                                            "A special vertical location on the page for this para")
-                       (FMTHEADINGKEEP FLAG)                 (* ; 
-                              "This para should be kept with the top line or so of the next para..")
-                       FMTPARATYPE                           (* ; 
-                                           "What kind of para this is: TEXT, PAGEHEADING, whatever")
-                       FMTPARASUBTYPE                        (* ; 
-                                   "Sub type of the type, e.g., what KIND of page heading this is.")
-                       FMTNEWPAGEBEFORE                      (* ; "Start a new box (if T) or back up the page formatting tree to make a new box of the type named in the value -- by going the least distance back up the tree, then back down until you find that kind of box.")
-                       FMTNEWPAGEAFTER                       (* ; "Similarly")
-                       FMTKEEP                               (* ; 
-                    "For information about how this paragraph is to be kept with other paragraphs.")
-                       FMTCOLUMN                             (* ; 
-                                         "For setting up side-by-side paragraphs easily ala BravoX")
-                       FMTVERTRULES                          (* ; 
-                                                     "For Keeping track of vertical rules in force")
-                       (FMTMARK FLAG)                        (* ; "Used to keep track of which PARALOOKSs are really being used -- a mark & collect is done just before a PUT, so that only 'real' PARALOOKSs make it into the file")
-                                                             (* ; "Used for a mark&sweep of para looks at PUT time -- T means this looks really IS in use in the document, so it makes sense to save it on the file.")
-                       (FMTHARDCOPY FLAG)                    (* ; 
-                                       "T if this paragraph is to be displayed in hardcopy-format.")
-                       FMTREVISED                            (* ; "T (or perhaps a revision level or revision-mark spec??) if this paragraph is to be marked as changed on output.")
-                       )
-                      TABSPEC _ (CONS NIL NIL))
-
-(DATATYPE PENDINGTAB (
-                          (* ;; "The data structure for a tab, within the line formatter, that we haven't finished dealing with yet, e.g. a centered tab where you need to wait for AFTER the centered text to do the formatting.")
-
-                          PTNEWTX
-
-                          (* ;; "An updated TX, being passed back to the line formatter.  This results from the resolution of an old RIGHT, CENTERED, or DECIMAL tab, which changed the width of a prior tab.")
-
-                          PTOLDTAB                           (* ; "The pending tab")
-                          PTTYPE                             (* ; "Its tab type")
-                          PTTABX                             (* ; "Its nominal X position")
-                          (PTWBASE FULLXPOINTER)             (* ; 
-          "The WBASE for its width, for updating when we've figured out how wide the tab really is")
-                          PTOLDTX                            (* ; 
-                                                       "The TX as of when the tab was encountered.")
-                          ))
-)
-
-(/DECLAREDATATYPE 'CHARLOOKS
-       '(POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG FLAG FLAG 
-               POINTER POINTER POINTER POINTER FLAG)
-       '((CHARLOOKS 0 POINTER)
-         (CHARLOOKS 2 POINTER)
-         (CHARLOOKS 4 POINTER)
-         (CHARLOOKS 4 (FLAGBITS . 0))
-         (CHARLOOKS 4 (FLAGBITS . 16))
-         (CHARLOOKS 4 (FLAGBITS . 32))
-         (CHARLOOKS 4 (FLAGBITS . 48))
-         (CHARLOOKS 2 (FLAGBITS . 0))
-         (CHARLOOKS 6 POINTER)
-         (CHARLOOKS 6 (FLAGBITS . 0))
-         (CHARLOOKS 6 (FLAGBITS . 16))
-         (CHARLOOKS 6 (FLAGBITS . 32))
-         (CHARLOOKS 6 (FLAGBITS . 48))
-         (CHARLOOKS 2 (FLAGBITS . 16))
-         (CHARLOOKS 2 (FLAGBITS . 32))
-         (CHARLOOKS 8 POINTER)
-         (CHARLOOKS 10 POINTER)
-         (CHARLOOKS 12 POINTER)
-         (CHARLOOKS 14 POINTER)
-         (CHARLOOKS 14 (FLAGBITS . 0)))
-       '16)
-
-(/DECLAREDATATYPE 'FMTSPEC
-       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-               POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-               FLAG FLAG POINTER)
-       '((FMTSPEC 0 POINTER)
-         (FMTSPEC 2 POINTER)
-         (FMTSPEC 4 POINTER)
-         (FMTSPEC 6 POINTER)
-         (FMTSPEC 8 POINTER)
-         (FMTSPEC 10 POINTER)
-         (FMTSPEC 12 POINTER)
-         (FMTSPEC 14 POINTER)
-         (FMTSPEC 16 POINTER)
-         (FMTSPEC 18 POINTER)
-         (FMTSPEC 20 POINTER)
-         (FMTSPEC 22 POINTER)
-         (FMTSPEC 24 POINTER)
-         (FMTSPEC 26 POINTER)
-         (FMTSPEC 26 (FLAGBITS . 0))
-         (FMTSPEC 28 POINTER)
-         (FMTSPEC 30 POINTER)
-         (FMTSPEC 32 POINTER)
-         (FMTSPEC 34 POINTER)
-         (FMTSPEC 36 POINTER)
-         (FMTSPEC 38 POINTER)
-         (FMTSPEC 40 POINTER)
-         (FMTSPEC 40 (FLAGBITS . 0))
-         (FMTSPEC 40 (FLAGBITS . 16))
-         (FMTSPEC 42 POINTER))
-       '44)
-
-(/DECLAREDATATYPE 'PENDINGTAB '(POINTER POINTER POINTER POINTER FULLXPOINTER POINTER)
-       '((PENDINGTAB 0 POINTER)
-         (PENDINGTAB 2 POINTER)
-         (PENDINGTAB 4 POINTER)
-         (PENDINGTAB 6 POINTER)
-         (PENDINGTAB 8 FULLXPOINTER)
-         (PENDINGTAB 10 POINTER))
-       '12)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \SMALLPIN MACRO (OPENLAMBDA (STREAM)
-                                         (SIGNED (create WORD
-                                                        HIBYTE _ (\BIN STREAM)
-                                                        LOBYTE _ (\BIN STREAM))
-                                                BITSPERWORD)))
-
-(PUTPROPS \SMALLPOUT MACRO (OPENLAMBDA (STREAM W)
-                                          (\BOUT STREAM (LOGAND 255 (LRSH W 8)))
-                                          (\BOUT STREAM (LOGAND W 255))))
-
-(PUTPROPS ONOFF MACRO [OPENLAMBDA (VAL)
-                                     (COND
-                                        (VAL 'ON)
-                                        (T 'OFF])
-)
-)
-
-
-
-(* ;; "FROM TEDITMENU")
-
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(RECORD MBUTTON NIL [TYPE? (AND (IMAGEOBJP DATUM)
-                                        (OR (EQ (IMAGEOBJPROP DATUM 'DISPLAYFN)
-                                                'MB.DISPLAY)
-                                            (EQ (IMAGEOBJPROP DATUM 'DISPLAYFN)
-                                                'MB.THREESTATE.DISPLAY)
-                                            (EQ (IMAGEOBJPROP DATUM 'DISPLAYFN)
-                                                '\TEXTMENU.TOGGLE.DISPLAY])
-)
-)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(RECORD NWAYBUTTON NIL [TYPE? (AND (IMAGEOBJP DATUM)
-                                           (EQ (IMAGEOBJPROP DATUM 'DISPLAYFN)
-                                               'MB.NB.DISPLAYFN])
-)
-)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(RECORD MARGINBAR (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE)
-                      [TYPE? (AND (IMAGEOBJP DATUM)
-                                      (EQ (IMAGEOBJPROP DATUM 'DISPLAYFN)
-                                          'MB.MARGINBAR.DISPLAYFN])
-)
-)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(RECORD TAB (TABX . TABKIND))
-)
-)
-(DECLARE%: EVAL@COMPILE
-
-(TYPERECORD MB.3STATE (
-                           (* ;; "Describes a 3-state menu button.")
-
-                           MBLABEL                           (* ; 
-                                                           "Label for the button on the screen")
-                           MBFONT                            (* ; 
-                                                           "Font the label text should appear in")
-                           MBCHANGESTATEFN                   (* ; 
-                                                 "Function to call when the button's state changes")
-                           MBINITSTATE                       (* ; "Button's initial state.")
-                           )
-                          MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD))
-
-(TYPERECORD MB.BUTTON (MBLABEL MBBUTTONEVENTFN MBFONT)
-                          MBBUTTONEVENTFN _ 'MB.DEFAULTBUTTON.FN MBFONT _ (FONTCREATE 'HELVETICA 8
-                                                                                 'BOLD))
-
-(TYPERECORD MB.INSERT (MBINITENTRY))
-
-(TYPERECORD MB.MARGINBAR (ignoredfield))
-
-(TYPERECORD MB.NWAY (MBBUTTONS MBFONT MBCHANGESTATEFN MBINITSTATE MBMAXITEMSPERLINE)
-                        MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD))
-
-(TYPERECORD MB.TEXT (MBSTRING MBFONT))
-
-(TYPERECORD MB.TOGGLE (MBTEXT MBFONT MBCHANGESTATEFN MBINITSTATE)
-                          MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD))
-)
-
-(DEFMACRO WITHOUT-UPDATES (TEXTOBJ SCRATCHSEL &BODY BODY)
-
-   (* ;; "For TEdit windows, run BODY without updating the edit window for TEXTOBJ.  This is useful if you're making a log of changes to a document at one time, where the changes are in essence atomic, and you don't need to see intermediate results.  It's also a good bit faster than constant updating.")
-
-   (* ;; "TEXTOBJ is the TEXTOBJ for the document you'll be modifying.")
-
-   (* ;; "SCRATCHSEL should be the scratch selection (often used in this work)")
-
-   `[LET [(OLD-UNWIND-FLAG (FETCH (TEXTOBJ TXTDON'TUPDATE) OF ,TEXTOBJ]
-         (CL:UNWIND-PROTECT
-             (PROGN (replace (TEXTOBJ TXTDON'TUPDATE) of ,TEXTOBJ with T)
-                    ,@BODY)
-             (\SHOWSEL ,SCRATCHSEL NIL NIL)
-             (replace SET of ,SCRATCHSEL with NIL)
-             (\TEDIT.MARK.LINES.DIRTY ,TEXTOBJ 1 (fetch (TEXTOBJ TEXTLEN) of ,TEXTOBJ))
-             (replace (TEXTOBJ TXTDON'TUPDATE) of ,TEXTOBJ with OLD-UNWIND-FLAG)
-             (TEDIT.UPDATE.SCREEN ,TEXTOBJ))])
-
-
-
-(* ;; "FROM TEDITHISTORY")
-
-(DECLARE%: EVAL@COMPILE
-
-(RECORD TEDITHISTORYEVENT (
-                               (* ;; "Describes one event on the TEdit edit history list.")
-
-                               THACTION                      (* ; 
-                                                         "A LITATOM, specifying what the event was")
-                               THPOINT                       (* ; 
-                                                          "Was the selection to the left or right?")
-                               THLEN                         (* ; "The # of chars involved")
-                               THCH#                         (* ; "The starting ch#")
-                               THFIRSTPIECE                  (* ; "First piece involved")
-                               THOLDINFO                     (* ; "Old info, for undo")
-                               THAUXINFO                     (* ; 
-                                               "Auxiliary info about the event, primarily for redo")
-                               THTEXTOBJ
-
-                               (* ;; "Place to remember a second textobj, for those like MOVE who need to remember both a source and a destination.")
-
-                               )
-                              THPOINT _ 'LEFT)
-)
-
-
-
-(* ;; "FROM TEDITFILE")
-
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \PieceDescriptorLOOKS 0)
-
-(RPAQQ \PieceDescriptorOBJECT 1)
-
-(RPAQQ \PieceDescriptorPARA 2)
-
-(RPAQQ \PieceDescriptorPAGEFRAME 3)
-
-(RPAQQ \PieceDescriptorCHARLOOKSLIST 4)
-
-(RPAQQ \PieceDescriptorPARALOOKSLIST 5)
-
-(RPAQQ \PieceDescriptorSAFEOBJECT 6)
-
-
-(CONSTANTS (\PieceDescriptorLOOKS 0)
-       (\PieceDescriptorOBJECT 1)
-       (\PieceDescriptorPARA 2)
-       (\PieceDescriptorPAGEFRAME 3)
-       (\PieceDescriptorCHARLOOKSLIST 4)
-       (\PieceDescriptorPARALOOKSLIST 5)
-       (\PieceDescriptorSAFEOBJECT 6))
-)
-)
-
-
-
-(* ;; "FROM TEDITCOMMAND")
-
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \INSERT\TTY\BUFFER MACRO (NIL (\TEDIT.INSERT.TTY.BUFFER ISCRSTRING IPASSSTRING 
-                                                       TEXTOBJ SEL)))
-
-(PUTPROPS \TEDIT.MOUSESTATE MACRO (BUTTON 
-
-         (* Test to see if only the specified mouse button is down.
-       DOES NOT call GETMOUSESTATE, so the mouse-button info is the same as the last 
-       time it WAS called.)
-
-                                                 (SELECTQ (CAR BUTTON)
-                                                     (LEFT '(IEQP LASTMOUSEBUTTONS 4))
-                                                     (MIDDLE '(IEQP LASTMOUSEBUTTONS 1))
-                                                     (RIGHT '(IEQP LASTMOUSEBUTTONS 2))
-                                                     (SHOULDNT))))
-
-(PUTPROPS \TEDIT.CHECK MACRO
-          [ARGS (COND
-                   [(AND (BOUNDP 'CHECK)
-                         CHECK)
-                    (CONS 'PROGN (for I in ARGS as J on ARGS
-                                    when (NOT (STRINGP I))
-                                    collect (LIST 'OR I (LIST 'HELP 
-                                            "TEdit consistency-check failure [RETURN to continue]:  "
-                                                                  (COND
-                                                                     ((STRINGP (CADR J)))
-                                                                     (T (KWOTE I]
-                   (T (CONS COMMENTFLG ARGS])
-)
-)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(ACCESSFNS TEDITTERMCODE ((TTCLASS (LOGAND DATUM 224))
-                              (TTDECODE (LOGAND DATUM 31))))
-)
-)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ NONE.TTC 0)
-
-(RPAQQ CHARDELETE.TTC 1)
-
-(RPAQQ WORDDELETE.TTC 2)
-
-(RPAQQ DELETE.TTC 3)
-
-(RPAQQ FUNCTIONCALL.TTC 4)
-
-(RPAQQ REDO.TTC 5)
-
-(RPAQQ UNDO.TTC 6)
-
-(RPAQQ CMD.TTC 7)
-
-(RPAQQ NEXT.TTC 8)
-
-(RPAQQ EXPAND.TTC 9)
-
-(RPAQQ PUNCT.TTC 20)
-
-(RPAQQ TEXT.TTC 21)
-
-(RPAQQ WHITESPACE.TTC 22)
-
-
-(CONSTANTS (NONE.TTC 0)
-       (CHARDELETE.TTC 1)
-       (WORDDELETE.TTC 2)
-       (DELETE.TTC 3)
-       (FUNCTIONCALL.TTC 4)
-       (REDO.TTC 5)
-       (UNDO.TTC 6)
-       (CMD.TTC 7)
-       (NEXT.TTC 8)
-       (EXPAND.TTC 9)
-       (PUNCT.TTC 20)
-       (TEXT.TTC 21)
-       (WHITESPACE.TTC 22))
-)
-)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ MSPACE 153)
-
-(RPAQQ NSPACE 152)
-
-(RPAQQ THINSPACE 159)
-
-(RPAQQ FIGSPACE 154)
-
-
-(CONSTANTS (MSPACE 153)
-       (NSPACE 152)
-       (THINSPACE 159)
-       (FIGSPACE 154))
-)
-)
-
-
-
-(* ;; "FROM TEDITWINDOW")
-
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE TEDITCARET (TCNOWTIME 
-
-         (* Used to hold the current time, when checking to see if a transition is due)
-
-                                TCTHENTIME                   (* Time when the next transition is 
-                                                           to take place)
-                                TCFORCEDDOWN                 (* TCFORCEDOWN = T means
-                                                           (Make the caret visible at the next 
-                                                           call to \EDIT.FLIPCARET.))
-                                TCUP
-
-         (* TCUP = T => The caret is NOT VISIBLE.
-       Used to track the current state of the caret)
-
-                                TCCARETDS                    (* The display stream that the caret 
-                                                           appears in)
-                                TCCURSORBM                   (* The CURSOR representing the caret)
-                                TCCARETRATE                  (* %# of MSEC between caret up/down 
-                                                           transitions)
-                                TCFORCEUP
-
-         (* T => The caret is not allowed to become visible.
-       Used to keep the caret up during screen updates)
-
-                                TCCARETX                     (* X position in the window that the 
-                                                           caret appears at)
-                                TCCARETY                     (* Y position in the window where 
-                                                           the caret appears)
-                                TCCARET                      (* A lisp CARET to be flashed
-                                                           (eventually))
-                                )
-                         TCNOWTIME _ (CREATECELL \FIXP)
-                         TCTHENTIME _ (CREATECELL \FIXP)
-                         TCCURSORBM _ BXCARET TCCARETRATE _ \CARETRATE TCUP _ T TCCARET _
-                         (\CARET.CREATE BXCARET))
-)
-
-(/DECLAREDATATYPE 'TEDITCARET '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-                                      POINTER POINTER POINTER)
-       '((TEDITCARET 0 POINTER)
-         (TEDITCARET 2 POINTER)
-         (TEDITCARET 4 POINTER)
-         (TEDITCARET 6 POINTER)
-         (TEDITCARET 8 POINTER)
-         (TEDITCARET 10 POINTER)
-         (TEDITCARET 12 POINTER)
-         (TEDITCARET 14 POINTER)
-         (TEDITCARET 16 POINTER)
-         (TEDITCARET 18 POINTER)
-         (TEDITCARET 20 POINTER))
-       '22)
-)
-
-(/DECLAREDATATYPE 'TEDITCARET '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-                                      POINTER POINTER POINTER)
-       '((TEDITCARET 0 POINTER)
-         (TEDITCARET 2 POINTER)
-         (TEDITCARET 4 POINTER)
-         (TEDITCARET 6 POINTER)
-         (TEDITCARET 8 POINTER)
-         (TEDITCARET 10 POINTER)
-         (TEDITCARET 12 POINTER)
-         (TEDITCARET 14 POINTER)
-         (TEDITCARET 16 POINTER)
-         (TEDITCARET 18 POINTER)
-         (TEDITCARET 20 POINTER))
-       '22)
-
-
-
-(* ;; "FROM PCTREE added by Nakamura")
-
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE PCTNODE (CHNUM                                 (* ; 
-                                                           "Character #of piece in this node.")
-                             PCE                             (* ; "PIECE ")
-                             LO                              (* ; 
-                                                 "Subtree these nodes' ch#are less than this node.")
-                             HI                              (* ; 
-                                                " Subtree these nodes' ch#are more than this node.")
-                             BF                              (* ; "Balance factor.")
-                                                             (* ; 
-                                            "1: Right(HI) Subtree is higher than left(lo) subtree.")
-                                                             (* ; 
-                                                "0: Right subtree and left subtree are same height")
-                                                             (* ; 
-                                          "-1: Right(HI) Subtree is shorter than left(lo) subtree.")
-                             RANK                            (* ; "(# of nodes in left subtree) +1")
-                             )
-                      CHNUM _ 0 BF _ 0 RANK _ 1)
-)
-
-(/DECLAREDATATYPE 'PCTNODE '(POINTER POINTER POINTER POINTER POINTER POINTER)
-       '((PCTNODE 0 POINTER)
-         (PCTNODE 2 POINTER)
-         (PCTNODE 4 POINTER)
-         (PCTNODE 6 POINTER)
-         (PCTNODE 8 POINTER)
-         (PCTNODE 10 POINTER))
-       '12)
-
-
-
-(* ;;; "THE END")
-
-
-
-
-(* ;; 
-"Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character "
-)
-
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ NOTBEFORE.LB 1)
-
-(RPAQQ NOTAFTER.LB 2)
-
-(RPAQQ BEFORE.LB 4)
-
-(RPAQQ AFTER.LB 8)
-
-(RPAQQ DISAPPEAR-IF-NOT-SPLIT.LB 16)
-
-(RPAQQ NEWCHAR-IF-SPLIT.LB 32)
-
-
-(CONSTANTS (NOTBEFORE.LB 1)
-       (NOTAFTER.LB 2)
-       (BEFORE.LB 4)
-       (AFTER.LB 8)
-       (DISAPPEAR-IF-NOT-SPLIT.LB 16)
-       (NEWCHAR-IF-SPLIT.LB 32))
-)
-)
-(PUTPROPS TEDITDCL COPYRIGHT ("Venue" 1986 1987 1988 1989 1990 1991 1993 1994 1995))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
diff --git a/obsolete/library/new/TEDITDCL.LCOM b/obsolete/library/new/TEDITDCL.LCOM
deleted file mode 100644
index 1cbff1f1..00000000
--- a/obsolete/library/new/TEDITDCL.LCOM
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "23-Mar-95 14:06:27" ("compiled on " {DSK}<lispcore>library>new>TEDITDCL.;1) 
" 2-Feb-95 10:57:29" bcompl'd in "Medley  2-Feb-95 ..." dated " 2-Feb-95 12:09:48")
(FILECREATED "22-Mar-95 18:05:53" {DSK}<lispcore>library>new>TEDITDCL.;1 86457 changes to%: (RECORDS 
PIECE) previous date%: "25-Aug-94 10:53:00" {DSK}<lispcore>library>TEDITDCL.;2)
(PRETTYCOMPRINT TEDITDCLCOMS)
(RPAQQ TEDITDCLCOMS ((* ;;; 
"This file is the collected record declarations and compile-time necessities for TEDIT.") (* ;; 
"FROM TEDIT") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))) (* ;; 
"FROM TEDITSELECTION") (RECORDS SELECTION) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (COPYSELSHADE 
30583) (COPYLOOKSSELSHADE 30583) (EDITMOVESHADE -1) (EDITGRAY 32800))) (VARS TEDITFILES) (* ;; 
"FROM TEDITSCREEN") (RECORDS THISLINE LINEDESCRIPTOR LINECACHE) (DECLARE%: EVAL@COMPILE DONTCOPY (
CONSTANTS (LMInvisibleRun 401) (LMLooksChange 400))) (* ;; "FROM TEXTOFD") (RECORDS EDITMARK) (RECORDS
 PIECE TEXTOBJ TEXTIMAGEDATA TEXTSTREAM) (OPTIMIZERS TEXTPROP) (COMS (* ;; 
"Private data structures and constants FROM TEXTOFD") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (
\PCTBFreePieces 0) (\PCTBLastPieceOffset 1) (\FirstPieceOffset 2) (\SecondPieceOffset 4) (
\EltsPerPiece 2)) (MACROS \EDITELT \GETCH \GETCHB \EDITSETA \WORDSETA) (GLOBALVARS \TEXTIMAGEOPS 
\TEXTOFD \TEXTFDEV))) (* ;;; "FROM TEDITPAGE") (RECORDS PAGEFORMATTINGSTATE PAGEREGION) (DECLARE%: 
EVAL@COMPILE DONTCOPY (RECORDS TEDITPAPERSIZE) (FUNCTIONS \NEW-COLUMN-START \FIRST-COLUMN-START)) (* 
;; "FROM TEDITFIND") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\AlphaNumericFlag 256) (\AlphaFlag 
512) (\OneCharPattern 1024) (\AnyStringPattern 1025) (\OneAlphaPattern 1026) (\AnyAlphaPattern 1027) (
\OneNonAlphaPattern 1028) (\AnyNonAlphaPattern 1029) (\LeftBracketPattern 1030) (\RightBracketPattern 
1031) (\SpecialPattern 1024))) (* ;; " FROM TEDITLOOKS") (RECORDS CHARLOOKS FMTSPEC PENDINGTAB) (
DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \SMALLPIN \SMALLPOUT ONOFF)) (* ;; "FROM TEDITMENU") (
DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MBUTTON)) (INITRECORDS MBUTTON) (DECLARE%: EVAL@COMPILE 
DONTCOPY (RECORDS NWAYBUTTON)) (INITRECORDS NWAYBUTTON) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS 
MARGINBAR)) (INITRECORDS MARGINBAR) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TAB)) (RECORDS MB.3STATE
 MB.BUTTON MB.INSERT MB.MARGINBAR MB.NWAY MB.TEXT MB.TOGGLE) (FUNCTIONS WITHOUT-UPDATES) (* ;; 
"FROM TEDITHISTORY") (RECORDS TEDITHISTORYEVENT) (* ;; "FROM TEDITFILE") (DECLARE%: EVAL@COMPILE 
DONTCOPY (CONSTANTS (\PieceDescriptorLOOKS 0) (\PieceDescriptorOBJECT 1) (\PieceDescriptorPARA 2) (
\PieceDescriptorPAGEFRAME 3) (\PieceDescriptorCHARLOOKSLIST 4) (\PieceDescriptorPARALOOKSLIST 5) (
\PieceDescriptorSAFEOBJECT 6))) (* ;; "FROM TEDITCOMMAND") (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS 
\INSERT\TTY\BUFFER \TEDIT.MOUSESTATE \TEDIT.CHECK)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS 
TEDITTERMCODE)) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NONE.TTC 0) (CHARDELETE.TTC 1) (
WORDDELETE.TTC 2) (DELETE.TTC 3) (FUNCTIONCALL.TTC 4) (REDO.TTC 5) (UNDO.TTC 6) (CMD.TTC 7) (NEXT.TTC 
8) (EXPAND.TTC 9) (PUNCT.TTC 20) (TEXT.TTC 21) (WHITESPACE.TTC 22))) (DECLARE%: EVAL@COMPILE DONTCOPY 
(CONSTANTS (MSPACE 153) (NSPACE 152) (THINSPACE 159) (FIGSPACE 154))) (* ;; "FROM TEDITWINDOW") (
DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITCARET)) (INITRECORDS TEDITCARET) (* ;; 
"FROM PCTREE added by Nakamura") (RECORDS PCTNODE) (* ;;; "THE END") (COMS (* ;; 
"Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character "
) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NOTBEFORE.LB 1) (* ; 
"Must not break before this character (e.g. Japanese right-paren)") (NOTAFTER.LB 2) (* ; 
"Must not break after this character (e.g. Japanese open-quote)") (BEFORE.LB 4) (* ; 
"OK to break before this character, provided it's OK to break after the prior char (true of most non-white-space)"
) (AFTER.LB 8) (* ; 
"OK to break after this char, if it's OK to break before the next one (true of most white space)") (
DISAPPEAR-IF-NOT-SPLIT.LB 16) (* ; 
"This character shouldn't be rendered if it isn't the last char on the line (non-breaking hyphen has this)"
) (NEWCHAR-IF-SPLIT.LB 32) (* ; 
"Look this char up in *TEDIT-SPLITCHAR-HASH* if this IS the last character on a line, and render it as the char we found."
))))))
(DATATYPE SELECTION ((* ;; 
"Description of a piece of selected text for TEdit.  Text has to be selected before it can be operated on by the user."
) Y0 (* ; "Y value of topmost line of selection") X0 (* ; "X value of left edge of selection") DX (* ;
 "Width of the selection, if it's on one line.") CH# (* ; "CH# of the first selected character") XLIM 
(* ; "X value of right edge of last selected character") CHLIM (* ; 
"CH# of the last character in the selection") DCH (* ; 
"# of characters selected (can be zero, for point selection.)") L1 (* ; 
"-> line descriptor for the line where the first selected character is") LN (* ; 
"-> line descriptor for the line which contains the end of the selection") YLIM (* ; 
"Y value of the bottom of the line that ends the selection") POINT (* ; 
"Which end should the caret appear at?  (LEFT or RIGHT)") (SET FLAG) (* ; 
"T if this selection is real;  NIL if not") (\TEXTOBJ FULLXPOINTER) (* ; 
"TEXTOBJ that describes the selected text") SELKIND (* ; 
"What kind of selection?  CHAR or WORD or LINE or PARA") HOW (* ; 
"SHADE used to highlight this selection") HOWHEIGHT (* ; 
"Height of the highlight (1 usually, full line for delete selection...)") (HASCARET FLAG) (* ; 
"T if there should be a caret for this selection") SELOBJ (* ; 
"If this selection is inside an object, which object?") (ONFLG FLAG) (* ; 
"T if the selection is highlighted on the screen, else NIL") SELOBJINFO (* ; 
"A Place for the selected object to put info about selection inside itself.")) SET _ NIL HOW _ 
BLACKSHADE HOWHEIGHT _ 1 HASCARET _ T Y0 _ 0 X0 _ 0 POINT _ (QUOTE LEFT) L1 _ (LIST NIL) LN _ (LIST 
NIL))
(/DECLAREDATATYPE (QUOTE SELECTION) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER FLAG FULLXPOINTER POINTER POINTER POINTER FLAG POINTER FLAG POINTER)) 
(QUOTE ((SELECTION 0 POINTER) (SELECTION 2 POINTER) (SELECTION 4 POINTER) (SELECTION 6 POINTER) (
SELECTION 8 POINTER) (SELECTION 10 POINTER) (SELECTION 12 POINTER) (SELECTION 14 POINTER) (SELECTION 
16 POINTER) (SELECTION 18 POINTER) (SELECTION 20 POINTER) (SELECTION 20 (FLAGBITS . 0)) (SELECTION 22 
FULLXPOINTER) (SELECTION 24 POINTER) (SELECTION 26 POINTER) (SELECTION 28 POINTER) (SELECTION 28 (
FLAGBITS . 0)) (SELECTION 30 POINTER) (SELECTION 30 (FLAGBITS . 0)) (SELECTION 32 POINTER))) (QUOTE 34
))
(RPAQQ TEDITFILES (PCTREE TEXTOFD TEDIT TEDITABBREV TEDITCOMMAND TEDITDCL TEDITFILE TEDITFIND 
TEDITFNKEYS TEDITHCPY TEDITHISTORY TEDITLOOKS TEDITMENU TEDITPAGE TEDITSCREEN TEDITSELECTION 
TEDITWINDOW))
(DATATYPE THISLINE ((* ;; 
"Cache for line-related character location info, for selection and line-display code to use.") (DESC 
FULLXPOINTER) (* ; "Line descriptor for the line this describes now") LEN (* ; 
"Length of the line in characters") CHARS (* ;; 
"Array of character codes (or objects) on the line (charcode of 400 => dummy entry for looks change--go get next entry in LOOKS)"
) WIDTHS (* ; "Array of each character's width in points") LOOKS (* ; 
"Array of any looks changes within the line.  LOOKS (0) = starting character looks for the line") 
TLSPACEFACTOR (* ; "The SPACEFACTOR to be used in printing this line") TLFIRSTSPACE (* ; 
"The first space to which SPACEFACTOR is to apply.  This is used so that spaces to the left of a TAB have their default width."
)) LEN _ 0 CHARS _ (ARRAY 512 (QUOTE POINTER) 0 0) WIDTHS _ (ARRAY 512 (QUOTE POINTER) 0 0) LOOKS _ (
ARRAY 512 (QUOTE POINTER) NIL 0) TLFIRSTSPACE _ 0)
(DATATYPE LINEDESCRIPTOR ((* ;; 
"Description of a single line of formatted text, either on the display or for a printed page.") YBOT (
* ; "Y value for the bottom of the line (below the descent)") YBASE (* ; 
"Yvalue for the base line the characters sit on") LEFTMARGIN (* ; "Left margin, in screen points") 
RIGHTMARGIN (* ; "Right margin, in screen points") LXLIM (* ; 
"X value of right edge of rightmost character on the line (may exceed right margin, if char is a space.)"
) SPACELEFT (* ; "Space left on the line, ignoring trailing blanks & CRs.") LHEIGHT (* ; 
"Total height of hte line, Ascent+Descent.") ASCENT (* ; "Ascent of the line above YBASE") DESCENT (* 
; "How far line descends below YBASE") LTRUEDESCENT (* ; 
"The TRUE DESCENT for this line, unadjusted for line leading.") LTRUEASCENT (* ; 
"The TRUE ASCENT for this line, unadjusted for pre-paragraph leading.") CHAR1 (* ; 
"CH# of the first character on the line.") CHARLIM (* ; "CH# of the last character on the line") 
CHARTOP (* ; "CH# of the character which forced the line break (may exceed CHARLIM)") NEXTLINE (* ; 
"Next line chain pointer") (PREVLINE FULLXPOINTER) (* ; "Previous line chain pointer") LMARK (* ; 
"One of SOLID, GREY, NIL.  Tells what kind of special-line marker should be put in the left margin for this paragraph.  (For hardcopy, can also be an indicator for special processing?)"
) LTEXTOBJ (* ; 
"A cached TEXTOBJ that this line took its text from.  Used in hardcopy to disambiguate when chno's should be updated..."
) CACHE (* ; 
"A cached THISLINE, for keeping hardcopy info around while we crunch with the line descriptors to make things fit."
) LDOBJ (* ; "The object which lies behind this line of text, for updating, etc.") LFMTSPEC (* ; 
"The format spec for this line's paragraph (eventually)") (DIRTY FLAG) (* ; 
"T if this line has changed since it was last formatted.") (CR\END FLAG) (* ; 
"T if this line ends with a CR.") (DELETED FLAG) (* ; 
"T if this line has been completely deleted since it was last formatted or displayed.  (Used by deletion routines to detect garbage lines)"
) (LHASPROT FLAG) (* ; "This line contains protected text.") (LHASTABS FLAG) (* ; 
"If this line has a tab in it, this is the line-relative ch# of the final tab.  This is to let us punt properly with tabs in a line."
) (1STLN FLAG) (* ; "This line is the first line in a paragraph") (LSTLN FLAG) (* ; 
"This is the last line in a paragraph")) CHARLIM _ 1000000 NEXTLINE _ NIL PREVLINE _ NIL DIRTY _ NIL 
YBOT _ 0 YBASE _ 0 LEFTMARGIN _ 0 DELETED _ NIL)
(DATATYPE LINECACHE ((* ;; "Image cache for display lines.") LCBITMAP (* ; 
"The bitmap that will be used by this instance of the cache") (LCNEXTCACHE FULLXPOINTER) (* ; 
"The next cache in the chain, for screen updates.")))
(/DECLAREDATATYPE (QUOTE THISLINE) (QUOTE (FULLXPOINTER POINTER POINTER POINTER POINTER POINTER 
POINTER)) (QUOTE ((THISLINE 0 FULLXPOINTER) (THISLINE 2 POINTER) (THISLINE 4 POINTER) (THISLINE 6 
POINTER) (THISLINE 8 POINTER) (THISLINE 10 POINTER) (THISLINE 12 POINTER))) (QUOTE 14))
(/DECLAREDATATYPE (QUOTE LINEDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FULLXPOINTER POINTER POINTER 
POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG)) (QUOTE ((LINEDESCRIPTOR 0 POINTER) (
LINEDESCRIPTOR 2 POINTER) (LINEDESCRIPTOR 4 POINTER) (LINEDESCRIPTOR 6 POINTER) (LINEDESCRIPTOR 8 
POINTER) (LINEDESCRIPTOR 10 POINTER) (LINEDESCRIPTOR 12 POINTER) (LINEDESCRIPTOR 14 POINTER) (
LINEDESCRIPTOR 16 POINTER) (LINEDESCRIPTOR 18 POINTER) (LINEDESCRIPTOR 20 POINTER) (LINEDESCRIPTOR 22 
POINTER) (LINEDESCRIPTOR 24 POINTER) (LINEDESCRIPTOR 26 POINTER) (LINEDESCRIPTOR 28 POINTER) (
LINEDESCRIPTOR 30 FULLXPOINTER) (LINEDESCRIPTOR 32 POINTER) (LINEDESCRIPTOR 34 POINTER) (
LINEDESCRIPTOR 36 POINTER) (LINEDESCRIPTOR 38 POINTER) (LINEDESCRIPTOR 40 POINTER) (LINEDESCRIPTOR 40 
(FLAGBITS . 0)) (LINEDESCRIPTOR 40 (FLAGBITS . 16)) (LINEDESCRIPTOR 40 (FLAGBITS . 32)) (
LINEDESCRIPTOR 40 (FLAGBITS . 48)) (LINEDESCRIPTOR 38 (FLAGBITS . 0)) (LINEDESCRIPTOR 38 (FLAGBITS . 
16)) (LINEDESCRIPTOR 38 (FLAGBITS . 32)))) (QUOTE 42))
(/DECLAREDATATYPE (QUOTE LINECACHE) (QUOTE (POINTER FULLXPOINTER)) (QUOTE ((LINECACHE 0 POINTER) (
LINECACHE 2 FULLXPOINTER))) (QUOTE 4))
(RECORD EDITMARK ((* ;; 
"Used for fast access to a given place in the text--a %"Marker%".   It consists of the piece, and the offset within the piece, and the piece number within the piece table.  That's everything that's needed to set a text stream up quickly to start reading from a given place."
) PC PCOFF . PCNO))
(DATATYPE PIECE ((* ; 
"The piece describes either a string or part of a file.  , or a generalized OBJECT.") PSTR (* ; 
"The string where this piece's text resides, or NIL") PFILE (* ; 
"The file which contains this piece's text, or NIL") (PFPOS FIXP) (* ; 
"The FILEPTR of the start of the piece in the file") (PLEN FIXP) (* ; 
"Length of the piece, in characters.") (NEXTPIECE FULLXPOINTER) (* ; "-> Next piece in this textobj.")
 (PREVPIECE FULLXPOINTER) (* ; "-> Prior piece in this text object.") PLOOKS (* ; 
"Formatting info and formatting events in this piece") POBJ (* ; "The OBJECT this piece describes") (
PPARALAST FLAG) (* ; "This piece contains a paragraph break") PPARALOOKS (* ; 
"Paragraph looks for this piece") (PNEW FLAG) (* ; 
"This text is new here;  used by the tentative edit system, and anyone else interested.") (PFATP FLAG)
 (* ; "T if the characters in this piece are FAT -- i.e., are 16 bits each.") (PTREENODE XPOINTER) (* 
; "Points to the PCTB tree-node that contains this piece.")) PSTR _ NIL PFILE _ NIL PFPOS _ 0 PLEN _ 0
 PPARALOOKS _ TEDIT.DEFAULT.FMTSPEC PTREENODE _ NIL)
(DATATYPE TEXTOBJ ((* ;; 
"This is where TEdit stores its state information, and internal data about the text being edited.") 
PCTB (* ; "The piece table") TEXTLEN (* ; "# of chars in the text") \INSERTPC (* ; 
"Piece to hold type-in") \INSERTPCNO (* ; "Piece # of the input piece") \INSERTNEXTCH (* ; 
"CH# of next char which is typed into that piece.") \INSERTLEFT (* ; "Space left in the type-in piece"
) \INSERTLEN (* ; "# of characters already in the piece.") \INSERTSTRING (* ; 
"The string which the piece describes.") \INSERTFIRSTCH (* ; "CH# of first char in the piece.") (
\INSERTPCVALID FLAG) (* ; 
"T if it's OK to use the cached piece.  Set to NIL by people who require that the next insertion/deletion use a different piece."
) \WINDOW (* ; "The window<s> where this textobj is displayed") MOUSEREGION (* ; 
"Section of the window the mouse is in.") LINES (* ; 
"-> to top of chain of line descriptors for displayed text") DS (* ; 
"Display stream where this textobj is displayed") SEL (* ; "The current selection within the text") 
SCRATCHSEL (* ; "Scratch space for the selection code") MOVESEL (* ; 
"Source for the next MOVE of text") SHIFTEDSEL (* ; "Source for the next COPY") DELETESEL (* ; 
"Text to be deleted imminently") WRIGHT (* ; 
"Right edge of the window (or subregion) where this is displayed") WTOP (* ; 
"Top of the window/region") WBOTTOM (* ; "Bottom of the window/region") WLEFT (* ; 
"Left edge of the window/region") TXTFILE (* ; "The original text file we're editing") (\XDIRTY FLAG) 
(* ; "T => changed since last saved.") (STREAMHINT FULLXPOINTER) (* ; 
"-> the TEXTOFD stream which gives access to this textobj") EDITFINISHEDFLG (* ; 
"T => The guy has asked the editor to go way") CARET (* ; 
"Describes the flashing caret for the editing window") CARETLOOKS (* ; 
"Font to be used for inserted text.") WINDOWTITLE (* ; 
"Original title for this window, of there was one.") THISLINE (* ; 
"Cache of line-related info, to speed up selection &c") (MENUFLG FLAG) (* ; 
"T if this TEXTOBJ is a tedit-style menu") FMTSPEC (* ; 
"Default Formatting Spec to be used when formatting paragraphs") (FORMATTEDP FLAG) (* ; 
"Flag for paragraph formatting.  T if this document is to contain paragraph formatting information.") 
(TXTREADONLY FLAG) (* ; "This is only available for shift selection.") (TXTEDITING FLAG) (* ; 
"T => This document is in a window and there is an edit process behind it.  For example, it only makes sense to have a caret show up if you are editing."
) (TXTNONSCHARS FLAG) (* ; 
"T => If TEdit rns into a 255, it won't attempt to convert to NS characters.  Used for REALLY plain-text manipulation."
) TXTTERMSA (* ; "Special instructions for displaying characters on the screen") EDITOPACTIVE (* ; 
"T if there is an editing operation in progress.  Used to interlock the TEdit menu") DEFAULTCHARLOOKS 
(* ; 
"The default character looks -- if any -- to be applied to characters coming into the file from outside."
) TXTRTBL (* ; "The READTABLE to be used by the command loop for command dispatch") TXTWTBL (* ; 
"The READTABLE to be used to decide on word breaks") EDITPROPS (* ; 
"The PROPS that were passed into this edit session") (BLUEPENDINGDELETE FLAG) (* ; 
"T if the next insertion in this document is to be preceded by a deletion of the then-current selection"
) TXTHISTORY (* ; "The history list for this edit session.") (SELWINDOW FULLXPOINTER) (* ; 
"The window in which the last 'real' selection got made for this edit;  used to control caret placement"
) PROMPTWINDOW (* ; 
"A window to be used for unscheduled interactions;  normally a small window above the edit window") 
DISPLAYCACHE (* ; "The bitmap to be used when building the image of a line for display") 
DISPLAYCACHEDS (* ; "The DISPLAYSTREAM that is used to build line images") DISPLAYHCPYDS (* ; 
"The DISPLAYSTREAM used to build line images of lines that are displayed in 'hardcopy' simulation mode"
) TXTPAGEFRAMES (* ; "A tree of page frames, specifying how the document is to be laid out.") 
TXTCHARLOOKSLIST (* ; "List of all the CHARLOOKSs in the document, so they can be kept unique") 
TXTPARALOOKSLIST (* ; "List of all the FMTSPECs in the document, so they can be kept unique") (
TXTNEEDSUPDATE FLAG) (* ; "T => Screen invalid, need to run updater") (TXTDON'TUPDATE FLAG) (* ; 
"T if we're holding off on screen updates until later.  Used, e.g., by the menu-SHOW code so that you don't get piecemeal updates, but only one at the end of the SHOW."
) TXTRAWINCLUDESTREAM (* ; 
"NODIRCORE stream used to cache RAW includes (and maybe later, all includes?)") DOCPROPS (* ; 
"Document properties that are stored with the document (not used yet)") TXTSTYLESHEET (* ; 
"Style sheet local to this document.  Not currently saved as part of the file.")) (ACCESSFNS TEXTOBJ (
(\DIRTY (ffetch (TEXTOBJ \XDIRTY) of DATUM) (PROGN (IF (NEQ (FETCH (TEXTOBJ \XDIRTY) OF DATUM) 
NEWVALUE) THEN (* ; "update the title to reflect the change") (\TEDIT.WINDOW.TITLE DATUM (
\TEDIT.ORIGINAL.WINDOW.TITLE (ffetch (TEXTOBJ TXTFILE) of DATUM) NEWVALUE))) (freplace \XDIRTY OF 
DATUM WITH NEWVALUE))))) SEL _ (create SELECTION) SCRATCHSEL _ (create SELECTION) MOVESEL _ (create 
SELECTION HOWHEIGHT _ 32767 HASCARET _ NIL) SHIFTEDSEL _ (create SELECTION HASCARET _ NIL) DELETESEL _
 (create SELECTION HOWHEIGHT _ 32767 HASCARET _ NIL) \INSERTNEXTCH _ -1 \INSERTPC _ NIL \INSERTLEFT _ 
0 \INSERTLEN _ 0 \INSERTSTRING _ NIL \INSERTFIRSTCH _ 1000000 TEXTLEN _ 0 WRIGHT _ 0 WTOP _ 0 WLEFT _ 
0 WBOTTOM _ 0 TXTFILE _ NIL \XDIRTY _ NIL MOUSEREGION _ (QUOTE TEXT) THISLINE _ (create THISLINE) 
MENUFLG _ NIL FMTSPEC _ TEDIT.DEFAULT.FMTSPEC FORMATTEDP _ NIL)
(DATATYPE TEXTIMAGEDATA ((* ;; "Fills the IMAGEDATA field of text streams.") TICURPARALOOKS (* ; 
"The current paragraph looks") TICURIMAGESTREAM (* ; "The image stream for this hardcopy transduction"
) TILOOKSUPDATEFN (* ; "The function to call to update looks for this stream") TIPCOFFSET (* ; 
"The offset into the current piece, as of the last page cross.")))
(ACCESSFNS TEXTSTREAM ((* ;; 
"Overlay for the STREAM record to allow mnemonic access to stream fields for Text streams.") (REALFILE
 (fetch F1 of DATUM) (REPLACE F1 OF DATUM WITH NEWVALUE)) (* ; 
"The real, underlying file behind the current piece") (CHARSLEFT (fetch F2 of DATUM) (REPLACE F2 OF 
DATUM WITH NEWVALUE)) (* ;; 
"The # of characters that will be left in the current piece the next time its file crosses a page boundary"
) (TEXTOBJ (fetch F3 of DATUM) (REPLACE F3 OF DATUM WITH NEWVALUE)) (* ; 
"The TEXTOBJ that is editing this text") (PIECE (fetch F5 of DATUM) (REPLACE F5 OF DATUM WITH NEWVALUE
)) (* ; "The PIECE we're currently fetching chars from/putting chars into") (PCNO (fetch FW8 of DATUM)
 (REPLACE FW8 OF DATUM WITH NEWVALUE)) (* ; "The position of that piece in the piece table") (
PCSTARTPG (fetch FW6 of DATUM) (REPLACE FW6 OF DATUM WITH NEWVALUE)) (* ; 
"The underlying file page# that this piece starts on") (PCSTARTCH (fetch FW7 of DATUM) (REPLACE FW7 OF
 DATUM WITH NEWVALUE)) (* ; 
"The char within page of the underlying file that this piece starts on -- for backbin & co") (PCOFFSET
 (fetch TIPCOFFSET of (fetch IMAGEDATA of DATUM)) (REPLACE TIPCOFFSET OF (fetch IMAGEDATA of DATUM) 
with NEWVALUE)) (* ; "The offset into the current piece, as of the last page cross.") (CURRENTLOOKS (
fetch F10 of DATUM) (replace F10 of DATUM with NEWVALUE)) (* ; 
"The CHARLOOKS that are currently applicable to characters being taken from the stream.") (
CURRENTPARALOOKS (fetch TICURPARALOOKS of (fetch IMAGEDATA of DATUM)) (REPLACE TICURPARALOOKS OF (
fetch IMAGEDATA of DATUM) with NEWVALUE)) (* ; 
"The FMTSPEC that is currently applicable to characters being taken from the stream.") (
CURRENTIMAGESTREAM (fetch TICURIMAGESTREAM of (fetch IMAGEDATA of DATUM)) (REPLACE TICURIMAGESTREAM OF
 (fetch IMAGEDATA of DATUM) with NEWVALUE) (* ; 
"The image stream that this text is being put onto;  used for scaling decisions")) (LOOKSUPDATEFN (
fetch TILOOKSUPDATEFN of (fetch IMAGEDATA of DATUM)) (REPLACE TILOOKSUPDATEFN OF (fetch IMAGEDATA of 
DATUM) with NEWVALUE)) (* ; "Function to be called each time character looks change.") (FATSTREAMP (
fetch F4 of DATUM) (REPLACE F4 OF DATUM WITH NEWVALUE)) (* ; 
"T if the current piece is 16 bit characters.")) (CREATE (create STREAM using \TEXTOFD IMAGEDATA _ (
create TEXTIMAGEDATA))))
(/DECLAREDATATYPE (QUOTE PIECE) (QUOTE (POINTER POINTER FIXP FIXP FULLXPOINTER FULLXPOINTER POINTER 
POINTER FLAG POINTER FLAG FLAG XPOINTER)) (QUOTE ((PIECE 0 POINTER) (PIECE 2 POINTER) (PIECE 4 FIXP) (
PIECE 6 FIXP) (PIECE 8 FULLXPOINTER) (PIECE 10 FULLXPOINTER) (PIECE 12 POINTER) (PIECE 14 POINTER) (
PIECE 14 (FLAGBITS . 0)) (PIECE 16 POINTER) (PIECE 16 (FLAGBITS . 0)) (PIECE 16 (FLAGBITS . 16)) (
PIECE 18 XPOINTER))) (QUOTE 20))
(/DECLAREDATATYPE (QUOTE TEXTOBJ) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER FLAG FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER
 FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER FULLXPOINTER POINTER
 POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG POINTER POINTER POINTER)) (QUOTE ((TEXTOBJ 
0 POINTER) (TEXTOBJ 2 POINTER) (TEXTOBJ 4 POINTER) (TEXTOBJ 6 POINTER) (TEXTOBJ 8 POINTER) (TEXTOBJ 10
 POINTER) (TEXTOBJ 12 POINTER) (TEXTOBJ 14 POINTER) (TEXTOBJ 16 POINTER) (TEXTOBJ 16 (FLAGBITS . 0)) (
TEXTOBJ 18 POINTER) (TEXTOBJ 20 POINTER) (TEXTOBJ 22 POINTER) (TEXTOBJ 24 POINTER) (TEXTOBJ 26 POINTER
) (TEXTOBJ 28 POINTER) (TEXTOBJ 30 POINTER) (TEXTOBJ 32 POINTER) (TEXTOBJ 34 POINTER) (TEXTOBJ 36 
POINTER) (TEXTOBJ 38 POINTER) (TEXTOBJ 40 POINTER) (TEXTOBJ 42 POINTER) (TEXTOBJ 44 POINTER) (TEXTOBJ 
44 (FLAGBITS . 0)) (TEXTOBJ 46 FULLXPOINTER) (TEXTOBJ 48 POINTER) (TEXTOBJ 50 POINTER) (TEXTOBJ 52 
POINTER) (TEXTOBJ 54 POINTER) (TEXTOBJ 56 POINTER) (TEXTOBJ 56 (FLAGBITS . 0)) (TEXTOBJ 58 POINTER) (
TEXTOBJ 58 (FLAGBITS . 0)) (TEXTOBJ 58 (FLAGBITS . 16)) (TEXTOBJ 58 (FLAGBITS . 32)) (TEXTOBJ 58 (
FLAGBITS . 48)) (TEXTOBJ 60 POINTER) (TEXTOBJ 62 POINTER) (TEXTOBJ 64 POINTER) (TEXTOBJ 66 POINTER) (
TEXTOBJ 68 POINTER) (TEXTOBJ 70 POINTER) (TEXTOBJ 70 (FLAGBITS . 0)) (TEXTOBJ 72 POINTER) (TEXTOBJ 74 
FULLXPOINTER) (TEXTOBJ 76 POINTER) (TEXTOBJ 78 POINTER) (TEXTOBJ 80 POINTER) (TEXTOBJ 82 POINTER) (
TEXTOBJ 84 POINTER) (TEXTOBJ 86 POINTER) (TEXTOBJ 88 POINTER) (TEXTOBJ 88 (FLAGBITS . 0)) (TEXTOBJ 88 
(FLAGBITS . 16)) (TEXTOBJ 90 POINTER) (TEXTOBJ 92 POINTER) (TEXTOBJ 94 POINTER))) (QUOTE 96))
(/DECLAREDATATYPE (QUOTE TEXTIMAGEDATA) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((
TEXTIMAGEDATA 0 POINTER) (TEXTIMAGEDATA 2 POINTER) (TEXTIMAGEDATA 4 POINTER) (TEXTIMAGEDATA 6 POINTER)
)) (QUOTE 8))
(DEFOPTIMIZER TEXTPROP (TEXTOBJ PROP &OPTIONAL (VAL NIL WRITING)) (* ;; "compiles calls to TEXTPROP") 
(COND ((NOT (LISTP PROP)) (* ; "property is not quoted.") (QUOTE IGNOREMACRO)) ((NOT (EQ (CAR PROP) (
QUOTE QUOTE))) (* ; "property is not quoted.") (QUOTE IGNOREMACRO)) ((NOT WRITING) (* ; 
"fetching a TEXTPROP property.") (SELECTQ (CADR PROP) ((READONLY READ-ONLY) (BQUOTE (fetch (TEXTOBJ 
TXTREADONLY) of (TEXTOBJ (\, TEXTOBJ))))) ((BEING-EDITED ACTIVE) (BQUOTE (fetch (TEXTOBJ TXTEDITING) 
of (TEXTOBJ (\, TEXTOBJ))))) ((NO-NS-CHARS NONSCHARS NO-NSCHARS) (BQUOTE (fetch (TEXTOBJ TXTNONSCHARS)
 of (TEXTOBJ (\, TEXTOBJ))))) (BQUOTE (LISTGET (fetch (TEXTOBJ EDITPROPS) of (TEXTOBJ (\, TEXTOBJ))) (
\, PROP))))) (T (* ; "storing a window property") (SELECTQ (CADR PROP) ((READONLY READ-ONLY) (BQUOTE (
REPLACE (TEXTOBJ TXTREADONLY) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)))) ((BEING-EDITED ACTIVE) (
BQUOTE (REPLACE (TEXTOBJ TXTEDITING) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)))) ((NO-NS-CHARS 
NONSCHARS NO-NSCHARS) (BQUOTE (REPLACE (TEXTOBJ TXTNONSCHARS) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL))
)) (BQUOTE (LET* (($$TEXTOBJ$$ (TEXTOBJ (\, TEXTOBJ))) ($$PROPLST$$ (FETCH EDITPROPS OF $$TEXTOBJ$$)))
 (COND ($$PROPLST$$ (LISTPUT $$PROPLST$$ (\, PROP) (\, VAL))) (T (REPLACE EDITPROPS OF $$TEXTOBJ$$ 
WITH (LIST (\, PROP) (\, VAL)))))))))))
(RECORD PAGEFORMATTINGSTATE ((* ;; "Contains the state for a TEdit page-formatting job.") PAGE# (* ; 
"The current page number.  Counted from 1") FIRSTPAGE (* ;; 
"T if the current page is the 'first page' .  Is set initially, and can be set again by the user at will.  Gets reset after each page image is printed."
) MINPAGE# (* ; "The page # of the first page to be printed, or NIL") MAXPAGE# (* ; 
"The page # of the last page to be printed, or NIL") STATE (* ; "One of FORMATTING or SEARCHING.") 
REQUIREDREGIONTYPE (* ; 
"If STATE is SEARCHING, the kind of box we're looking for.  If STATE is :SEARCHING-FOR-EQUIVALENT-PAGE, this is the page count for the matching page."
) MAINSTREAM (* ; "The principal textobj/stream source") CHNO (* ; "Our position in that stream") 
PRESSREGION (* ; "The press code's REGION info.") PAGEHEADINGS (* ; 
"The list of current values to be printed, indexed by heading type") PAGE#GENERATOR (* ; 
"List of page numbers;  later, maybe, a function to generate page numbers.  Used to fill in PAGE#TEXT, below"
) PAGE#TEXT (* ; 
"If special page numbers are in use, this is the place to take them from.  PAGE# is still used for recto/verso decisions &c"
) PAGEISRECTO (* ; "T if this is a recto page, NIL if it's a VERSO page.") PAGEFOOTNOTELINES (* ; 
"A list of extant footnote lines that should appear at the next opportunity") PAGEFLOATINGTOPLINES (* 
; "A list of lines that should float to the top of the next available place") PAGECOUNT (* ; 
"The number of pages we've formatted so far.") PAGELINECACHE (* ; 
"A cache for pre-created LINEDESCRIPTOR/THISLINE sets, to avoid the overhead of re-allocating them all the time"
) NEWPAGELAYOUT (* ; 
"If we switch page layouts in mid-document, this is where the new layout gets cached until we get started again."
)) PAGECOUNT _ 0)
(DATATYPE PAGEREGION ((* ;; 
"Describe a part of a page for page formatting.  Can be made into compound descriptions.") 
REGIONFILLMETHOD (* ; "What kind of a region this is -- TEXT, FOLIO, PAGEHEADING, etc.") REGIONSPEC (*
 ; "The page-relative region this occupies") REGIONLOCALINFO (* ; "A PLIST for local information") (
REGIONPARENT FULLXPOINTER) (* ; "The parent node for this box, for sub-boxes") REGIONSUBBOXES (* ; 
"The sub-regions of this region") REGIONTYPE (* ; "A user-settable region type")))
(/DECLAREDATATYPE (QUOTE PAGEREGION) (QUOTE (POINTER POINTER POINTER FULLXPOINTER POINTER POINTER)) (
QUOTE ((PAGEREGION 0 POINTER) (PAGEREGION 2 POINTER) (PAGEREGION 4 POINTER) (PAGEREGION 6 FULLXPOINTER
) (PAGEREGION 8 POINTER) (PAGEREGION 10 POINTER))) (QUOTE 12))
(DATATYPE CHARLOOKS ((* ;; "Describes the appearance (%"Looks%") of characters in a TEdit document.") 
CLFONT (* ; "The font descriptor for these characters") CLNAME (* ;; 
"Name of the font (e.g., HELVETICA) THIS FIELD IS A HINT, OR FOR USE IN CHARLOOKS-BUILDING CODE.  USE FONTPROP TO GET THE RIGHT VALUE FROM CLFONT."
) CLSIZE (* ; "Font size, in points") (CLITAL FLAG) (* ; "T if the characters are italic, else NIL") (
CLBOLD FLAG) (* ; "T if the characters are bold, else NIL") (CLULINE FLAG) (* ; 
"T if the characters are to be underscored, else NIL") (CLOLINE FLAG) (* ; 
"T if the characters are to be overscored, else NIL") (CLSTRIKE FLAG) (* ; 
"T if the characters are to be struck thru, else nil.") CLOFFSET (* ; 
"A superscripting offset in points (?) else NIL (SUBSCRIPTING IF NEGATIVE.)") (CLSMALLCAP FLAG) (* ; 
"T if small caps, else NIL") (CLINVERTED FLAG) (* ; 
"T if the characters are to be shown white-on-black") (CLPROTECTED FLAG) (* ; 
"T if chars can't be selected, else NIL") (CLINVISIBLE FLAG) (* ; 
"T if TEDIT is to ignore these chars;  else NIL") (CLSELHERE FLAG) (* ;; 
"T if TEDIT can put selection after this char (for menu blanks) else NIL;  anything typed after this char will NOT BE PROTECTED."
) (CLCANCOPY FLAG) (* ;; 
"T if this text can be selected for copying, even tho protected (it will become unprotected after the copy;  for Dribble/TTY interface)"
) CLSTYLE (* ; "The style to be used in marking these characters;  overridden by the other fields") 
CLUSERINFO (* ; "Any information that an outsider wants to include") CLLEADER (* ; 
"For creating dotted and other kinds of leader") CLRULES (* ;; 
"For arbitrarily-places horizontal rules.  List of pairs, of (widthinpts  . offsetfrombaselineinpts).  Should be taken account of in ascent/descent calcs."
) (CLMARK FLAG) (* ;; 
"Used for a mark-&-sweep of looks at PUT time -- T means this set of looks really IS in use in the document"
)) CLOFFSET _ 0)
(DATATYPE FMTSPEC ((* ;; "Describe the paragraph formatting for a paragraph in a TEdit document.") 
1STLEFTMAR (* ; "Left margin of the first line of the paragraph") LEFTMAR (* ; 
"Left margin of the rest of the lines in the paragraph") RIGHTMAR (* ; 
"Right margin for the paragraph") LEADBEFORE (* ; 
"Leading above the paragraph's first line, in points") LEADAFTER (* ; 
"Leading below the paragraph's bottom line, in points.  NOT IMPLEMENTED.") LINELEAD (* ; 
"Leading between lines, in points.  Actually, this space is added BELOW each line in the para.") 
FMTBASETOBASE (* ; 
"The baseline-to-baseline spacing between lines in this paragraph.  THIS OVERRIDES THE LINE LEADING") 
TABSPEC (* ; "The list of tabs for this paragraph, including CAR for a default tab width") QUAD (* ; 
"How the para is formatted: one of LEFT, RIGHT, CENTERED, JUSTIFIED") FMTSTYLE (* ; 
"The STYLE that controls this paragraph's appearance") FMTCHARSTYLES (* ; 
"The characterstyles that control the appearance of characters in this para (maybe?  may be part of the fmtstyle.)"
) FMTUSERINFO (* ; "Space for a PLIST of user info") FMTSPECIALX (* ; 
"A special horizontal location on the printed page for this para.") FMTSPECIALY (* ; 
"A special vertical location on the page for this para") (FMTHEADINGKEEP FLAG) (* ; 
"This para should be kept with the top line or so of the next para..") FMTPARATYPE (* ; 
"What kind of para this is: TEXT, PAGEHEADING, whatever") FMTPARASUBTYPE (* ; 
"Sub type of the type, e.g., what KIND of page heading this is.") FMTNEWPAGEBEFORE (* ; 
"Start a new box (if T) or back up the page formatting tree to make a new box of the type named in the value -- by going the least distance back up the tree, then back down until you find that kind of box."
) FMTNEWPAGEAFTER (* ; "Similarly") FMTKEEP (* ; 
"For information about how this paragraph is to be kept with other paragraphs.") FMTCOLUMN (* ; 
"For setting up side-by-side paragraphs easily ala BravoX") FMTVERTRULES (* ; 
"For Keeping track of vertical rules in force") (FMTMARK FLAG) (* ; 
"Used to keep track of which PARALOOKSs are really being used -- a mark & collect is done just before a PUT, so that only 'real' PARALOOKSs make it into the file"
) (* ; 
"Used for a mark&sweep of para looks at PUT time -- T means this looks really IS in use in the document, so it makes sense to save it on the file."
) (FMTHARDCOPY FLAG) (* ; "T if this paragraph is to be displayed in hardcopy-format.") FMTREVISED (* 
; 
"T (or perhaps a revision level or revision-mark spec??) if this paragraph is to be marked as changed on output."
)) TABSPEC _ (CONS NIL NIL))
(DATATYPE PENDINGTAB ((* ;; 
"The data structure for a tab, within the line formatter, that we haven't finished dealing with yet, e.g. a centered tab where you need to wait for AFTER the centered text to do the formatting."
) PTNEWTX (* ;; 
"An updated TX, being passed back to the line formatter.  This results from the resolution of an old RIGHT, CENTERED, or DECIMAL tab, which changed the width of a prior tab."
) PTOLDTAB (* ; "The pending tab") PTTYPE (* ; "Its tab type") PTTABX (* ; "Its nominal X position") (
PTWBASE FULLXPOINTER) (* ; 
"The WBASE for its width, for updating when we've figured out how wide the tab really is") PTOLDTX (* 
; "The TX as of when the tab was encountered.")))
(/DECLAREDATATYPE (QUOTE CHARLOOKS) (QUOTE (POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG POINTER 
FLAG FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER FLAG)) (QUOTE ((CHARLOOKS 0 POINTER) (
CHARLOOKS 2 POINTER) (CHARLOOKS 4 POINTER) (CHARLOOKS 4 (FLAGBITS . 0)) (CHARLOOKS 4 (FLAGBITS . 16)) 
(CHARLOOKS 4 (FLAGBITS . 32)) (CHARLOOKS 4 (FLAGBITS . 48)) (CHARLOOKS 2 (FLAGBITS . 0)) (CHARLOOKS 6 
POINTER) (CHARLOOKS 6 (FLAGBITS . 0)) (CHARLOOKS 6 (FLAGBITS . 16)) (CHARLOOKS 6 (FLAGBITS . 32)) (
CHARLOOKS 6 (FLAGBITS . 48)) (CHARLOOKS 2 (FLAGBITS . 16)) (CHARLOOKS 2 (FLAGBITS . 32)) (CHARLOOKS 8 
POINTER) (CHARLOOKS 10 POINTER) (CHARLOOKS 12 POINTER) (CHARLOOKS 14 POINTER) (CHARLOOKS 14 (FLAGBITS
 . 0)))) (QUOTE 16))
(/DECLAREDATATYPE (QUOTE FMTSPEC) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER FLAG FLAG POINTER)) (QUOTE ((FMTSPEC 0 POINTER) (FMTSPEC 2 POINTER) (FMTSPEC 4 POINTER
) (FMTSPEC 6 POINTER) (FMTSPEC 8 POINTER) (FMTSPEC 10 POINTER) (FMTSPEC 12 POINTER) (FMTSPEC 14 
POINTER) (FMTSPEC 16 POINTER) (FMTSPEC 18 POINTER) (FMTSPEC 20 POINTER) (FMTSPEC 22 POINTER) (FMTSPEC 
24 POINTER) (FMTSPEC 26 POINTER) (FMTSPEC 26 (FLAGBITS . 0)) (FMTSPEC 28 POINTER) (FMTSPEC 30 POINTER)
 (FMTSPEC 32 POINTER) (FMTSPEC 34 POINTER) (FMTSPEC 36 POINTER) (FMTSPEC 38 POINTER) (FMTSPEC 40 
POINTER) (FMTSPEC 40 (FLAGBITS . 0)) (FMTSPEC 40 (FLAGBITS . 16)) (FMTSPEC 42 POINTER))) (QUOTE 44))
(/DECLAREDATATYPE (QUOTE PENDINGTAB) (QUOTE (POINTER POINTER POINTER POINTER FULLXPOINTER POINTER)) (
QUOTE ((PENDINGTAB 0 POINTER) (PENDINGTAB 2 POINTER) (PENDINGTAB 4 POINTER) (PENDINGTAB 6 POINTER) (
PENDINGTAB 8 FULLXPOINTER) (PENDINGTAB 10 POINTER))) (QUOTE 12))
(TYPERECORD MB.3STATE ((* ;; "Describes a 3-state menu button.") MBLABEL (* ; 
"Label for the button on the screen") MBFONT (* ; "Font the label text should appear in") 
MBCHANGESTATEFN (* ; "Function to call when the button's state changes") MBINITSTATE (* ; 
"Button's initial state.")) MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD)))
(TYPERECORD MB.BUTTON (MBLABEL MBBUTTONEVENTFN MBFONT) MBBUTTONEVENTFN _ (QUOTE MB.DEFAULTBUTTON.FN) 
MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD)))
(TYPERECORD MB.INSERT (MBINITENTRY))
(TYPERECORD MB.MARGINBAR (ignoredfield))
(TYPERECORD MB.NWAY (MBBUTTONS MBFONT MBCHANGESTATEFN MBINITSTATE MBMAXITEMSPERLINE) MBFONT _ (
FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD)))
(TYPERECORD MB.TEXT (MBSTRING MBFONT))
(TYPERECORD MB.TOGGLE (MBTEXT MBFONT MBCHANGESTATEFN MBINITSTATE) MBFONT _ (FONTCREATE (QUOTE 
HELVETICA) 8 (QUOTE BOLD)))
(DEFMACRO WITHOUT-UPDATES (TEXTOBJ SCRATCHSEL &BODY BODY) (* ;; 
"For TEdit windows, run BODY without updating the edit window for TEXTOBJ.  This is useful if you're making a log of changes to a document at one time, where the changes are in essence atomic, and you don't need to see intermediate results.  It's also a good bit faster than constant updating."
) (* ;; "TEXTOBJ is the TEXTOBJ for the document you'll be modifying.") (* ;; 
"SCRATCHSEL should be the scratch selection (often used in this work)") (BQUOTE (LET ((OLD-UNWIND-FLAG
 (FETCH (TEXTOBJ TXTDON'TUPDATE) OF (\, TEXTOBJ)))) (CL:UNWIND-PROTECT (PROGN (replace (TEXTOBJ 
TXTDON'TUPDATE) of (\, TEXTOBJ) with T) (\,@ BODY)) (\SHOWSEL (\, SCRATCHSEL) NIL NIL) (replace SET of
 (\, SCRATCHSEL) with NIL) (\TEDIT.MARK.LINES.DIRTY (\, TEXTOBJ) 1 (fetch (TEXTOBJ TEXTLEN) of (\, 
TEXTOBJ))) (replace (TEXTOBJ TXTDON'TUPDATE) of (\, TEXTOBJ) with OLD-UNWIND-FLAG) (
TEDIT.UPDATE.SCREEN (\, TEXTOBJ))))))
(RECORD TEDITHISTORYEVENT ((* ;; "Describes one event on the TEdit edit history list.") THACTION (* ; 
"A LITATOM, specifying what the event was") THPOINT (* ; "Was the selection to the left or right?") 
THLEN (* ; "The # of chars involved") THCH# (* ; "The starting ch#") THFIRSTPIECE (* ; 
"First piece involved") THOLDINFO (* ; "Old info, for undo") THAUXINFO (* ; 
"Auxiliary info about the event, primarily for redo") THTEXTOBJ (* ;; 
"Place to remember a second textobj, for those like MOVE who need to remember both a source and a destination."
)) THPOINT _ (QUOTE LEFT))
(/DECLAREDATATYPE (QUOTE TEDITCARET) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER)) (QUOTE ((TEDITCARET 0 POINTER) (TEDITCARET 2 POINTER) (TEDITCARET 4 
POINTER) (TEDITCARET 6 POINTER) (TEDITCARET 8 POINTER) (TEDITCARET 10 POINTER) (TEDITCARET 12 POINTER)
 (TEDITCARET 14 POINTER) (TEDITCARET 16 POINTER) (TEDITCARET 18 POINTER) (TEDITCARET 20 POINTER))) (
QUOTE 22))
(DATATYPE PCTNODE (CHNUM (* ; "Character #of piece in this node.") PCE (* ; "PIECE ") LO (* ; 
"Subtree these nodes' ch#are less than this node.") HI (* ; 
" Subtree these nodes' ch#are more than this node.") BF (* ; "Balance factor.") (* ; 
"1: Right(HI) Subtree is higher than left(lo) subtree.") (* ; 
"0: Right subtree and left subtree are same height") (* ; 
"-1: Right(HI) Subtree is shorter than left(lo) subtree.") RANK (* ; "(# of nodes in left subtree) +1"
)) CHNUM _ 0 BF _ 0 RANK _ 1)
(/DECLAREDATATYPE (QUOTE PCTNODE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((
PCTNODE 0 POINTER) (PCTNODE 2 POINTER) (PCTNODE 4 POINTER) (PCTNODE 6 POINTER) (PCTNODE 8 POINTER) (
PCTNODE 10 POINTER))) (QUOTE 12))
(PUTPROPS TEDITDCL COPYRIGHT ("Venue" 1986 1987 1988 1989 1990 1991 1993 1994 1995))
NIL
\ No newline at end of file
diff --git a/obsolete/library/new/TEDITFILE b/obsolete/library/new/TEDITFILE
deleted file mode 100644
index bc49b39a..00000000
--- a/obsolete/library/new/TEDITFILE
+++ /dev/null
@@ -1,3620 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED " 4-May-95 10:30:33" {DSK}<lispcore>library>new>TEDITFILE.;2 244496 
-
-      changes to%:  (FNS TEDIT.INCLUDE TEDIT.BUILD.PCTB0)
-
-      previous date%: "25-Aug-94 10:53:27" {DSK}<king>export>lispcore>library>TEDITFILE.;3)
-
-
-(* ; "
-Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT TEDITFILECOMS)
-
-(RPAQQ TEDITFILECOMS
-       ((FILES TEDITDCL)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
-               (FILES (LOADCOMP)
-                      TEDITDCL))
-        (COMS 
-              (* ;; "GETting a file")
-
-              (FNS TEDIT.BUILD.PCTB \TEDIT.CONVERT.FOREIGN.FORMAT TEDIT.FORMATTEDFILEP TEDIT.GET 
-                   TEDIT.PARSE.PAGEFRAMES1 \ARBIN \ATMIN \DWIN \STRINGIN \TEDIT.FORMATTEDP1 
-                   \TEDIT.SET.WINDOW))
-        (COMS 
-              (* ;; "INCLUDEing a file")
-
-              (FNS TEDIT.INCLUDE TEDIT.RAW.INCLUDE))
-        (COMS 
-              (* ;; "PUTting a file:")
-
-              (FNS TEDIT.PUT TEDIT.PUT.PCTB \TEDIT.PUTRESET TEDIT.PUT.PIECE.DESCRIPTOR \ARBOUT 
-                   \ATMOUT \DWOUT \STRINGOUT \TEDIT-OPEN-FONT-FILE))
-        (FNS \TEDIT.GET.CHARLOOKS.LIST \TEDIT.GET.SINGLE.CHARLOOKS \TEDIT.PUT.CHARLOOKS.LIST 
-             \TEDIT.PUT.SINGLE.CHARLOOKS)
-        (FNS \TEDIT.GET.PARALOOKS.LIST \TEDIT.GET.SINGLE.PARALOOKS \TEDIT.PUT.PARALOOKS.LIST 
-             \TEDIT.PUT.SINGLE.PARALOOKS)
-        (GLOBALVARS TEDIT.INPUT.FORMATS *TEDIT-FILE-READTABLE*)
-        (INITVARS (TEDIT.INPUT.FORMATS NIL)
-               (*TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE))
-                                                             (* ; 
-                                       "For consistent reading and writing of info on TEdit files.")
-               )
-        (COMS 
-              (* ;; 
-      "For converting old incoming format.  Cutover 5/22/85 to permit looks changes in the future.")
-
-              (FNS TEDIT.BUILD.PCTB2 \TEDIT.GET.CHARLOOKS.LIST2 \TEDIT.GET.SINGLE.CHARLOOKS2 
-                   \TEDIT.PUT.SINGLE.PARALOOKS2 \TEDIT.PUT.SINGLE.CHARLOOKS2 
-                   \TEDIT.GET.PARALOOKS.LIST2 \TEDIT.GET.SINGLE.PARALOOKS2 TEDIT.PUT.PCTB2 
-                   \TEDIT.PUT.CHARLOOKS.LIST2 \TEDIT.PUT.PARALOOKS.LIST2))
-        (COMS 
-              (* ;; "For converting incoming old-format files (1/27/85 cutover)")
-
-              (FNS TEDIT.BUILD.PCTB1 TEDIT.GET.PAGEFRAMES1 \TEDIT.GET.CHARLOOKS1 
-                   \TEDIT.GET.PARALOOKS1 TEDIT.GET.OBJECT1))
-        (COMS 
-              (* ;; "VERSION 0 Compatibility reading functions")
-
-              (FNS TEDIT.BUILD.PCTB0 TEDIT.GET.CHARLOOKS0 TEDIT.GET.OBJECT0 TEDIT.GET.PARALOOKS0))))
-
-(FILESLOAD TEDITDCL)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \SCRATCHLEN 64)
-
-
-(CONSTANTS (\SCRATCHLEN 64))
-)
-
-
-(FILESLOAD (LOADCOMP)
-       TEDITDCL)
-)
-
-
-
-(* ;; "GETting a file")
-
-(DEFINEQ
-
-(TEDIT.BUILD.PCTB
-  [LAMBDA (TEXT TEXTOBJ START END DEFAULTLOOKS DEFAULTPARALOOKS CLEARGET?)
-                                                             (* ; "Edited 19-Apr-93 13:46 by jds")
-                                                             (* ; 
-                                              "START = 1st char of file to read from, if specified")
-                                                             (* ; 
-                        "END = use this as eofptr of file.  For use in reading files within files.")
-    (PROG (SEL LINES PCTB PC OLDPC PCCOUNT TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN 
-               PIECEINFOCH# CACHE CACHE? TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP 
-               EXISTINGCHARLOOKS EXLOOK EXISTINGFMTSPECS (*READTABLE* *TEDIT-FILE-READTABLE*)
-               (*PRINT-BASE* 10)
-               (CURFILECH# (OR START 0))
-               (CURCH# 1)
-               (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)))
-               LOOKSHASH PARAHASH)
-          [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND
-                                                         (TEXTOBJ (fetch (TEXTOBJ FMTSPEC)
-                                                                     of TEXTOBJ))
-                                                         (T (create FMTSPEC using 
-                                                                                TEDIT.DEFAULT.FMTSPEC
-                                                                   ]
-                                                             (* ; 
-                      "Set the default paragraph formatting for filling in piece PPARALOOKS fields")
-          (COND
-             (TEXTOBJ                                        (* ; 
-             "If there's a TEXTOBJ behind this, set its TXTFILE field to point to the right place.")
-                    (replace (TEXTOBJ TXTFILE) of TEXTOBJ with TEXT)))
-          (SETQ DEFAULTLOOKS (OR DEFAULTLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT)))
-                                                             (* ; 
-                                  "Set the default CHARLOOKS, for filling in pieces' PLOOKS fields")
-          (SETQ TEXT (\CREATEPIECEORSTREAM TEXT DEFAULTLOOKS DEFAULTPARALOOKS START END))
-                                                             (* ; 
-                 "Grab the file, or a single piece (if the text is a string, or such simple cases)")
-          (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with NIL))
-                                                             (* ; 
-                                                           "Start by assuming no page formatting")
-          (COND
-             ((STREAMP TEXT)                                 (* ; 
-              "OK, it wasn't a string, so check for cases where we have to cache the file locally.")
-              (AND TEXTOBJ (replace (TEXTOBJ TXTFILE) of TEXTOBJ with TEXT))
-              (COND
-                 ((OR [AND TEXTOBJ (SETQ CACHE? (TEXTPROP TEXTOBJ 'CACHE]
-                      (NOT (RANDACCESSP TEXT)))              (* ; 
-                                  "If the file device isn't rancom access, cache the file locally.")
-                                                             (* ; 
-                                                       "Also do this if he asks for a local cache.")
-                  (SETQ CACHE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
-                                                             (* ; "The cache file")
-                  (COND
-                     ((OR START END)
-                      (COPYBYTES TEXT CACHE (OR START 0)
-                             (OR END -1)))
-                     (T (COPYBYTES TEXT CACHE)))             (* ; "Copy the text there")
-                  (SETQ CACHE? T)                            (* ; "Remember that we cached it!")
-
-                  (* ;; "COPYBYTES can only have start/end args of NIL if the file is not random access.  So it's impossible to grab out of the middle of a file on an NS server.  Sorry.")
-
-                  (COND
-                     (CACHE? 
-
-                            (* ;; "for the folx who don't trust the connections, since all their pcs will point to core, we can close the txtfile connection")
-
-                            (CLOSEF TEXT)))
-                  (replace (STREAM EOLCONVENTION) of CACHE with (fetch (STREAM 
-                                                                                        EOLCONVENTION
-                                                                                              )
-                                                                               of TEXT))
-                                                             (* ; 
-    "Remember the EOL convention from the original file, so that we can do a copybytes if need by.")
-                  (SETQ TEXT CACHE)                          (* ; 
-                                              "And pretend the cache IS the real file from here on")
-                  (SETQ START (SETQ END NIL))
-
-                  (* ;; "Since we only copied the relevant part of the file into the cache, we don't need to remember the limits of interest.")
-
-                  ))
-              (SETQ PCCOUNT (\TEDIT.FORMATTEDP1 TEXT END))
-              (COND
-                 ((AND (NOT PCCOUNT)
-                       (NEQ (fetch (STREAM EOLCONVENTION) of TEXT)
-                            CR.EOLC))
-
-                  (* ;; "This is an UNFORMATTED file, and it has a foreign EOL convention.  Convert it, and save the converted copy locally.")
-
-                  (SETQ CACHE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
-                                                             (* ; "Build a cache file")
-                  (COND
-                     ((OR START END)
-                      (COPYCHARS TEXT CACHE (OR START 0)
-                             (OR END -1))
-
-                      (* ;; "mcf: just like before, we have all the relevant portion")
-
-                      (SETQ START (SETQ END NIL)))
-                     (T (COPYCHARS TEXT CACHE)))             (* ; 
-                "Copy the text, converting from the foreign EOL convention into CR as end of line.")
-                  (SETQ TEXT CACHE)
-
-                  (* ;; "And think of THIS as the cache.  At this point, we may have cached twice in succession--no need to clip off START and END.")
-
-                  (SETQ CACHE? T)                            (* ; 
-                                                           "Remember that we cached the file!")
-                  ))                                         (* ; 
- "Check to see if this is a formatted file, and find out how may pieces we should allocate for it.")
-              ))
-          (AND TEXTOBJ (TEXTPROP TEXTOBJ 'CACHE CACHE?))     (* ; 
-               "REMEMBER THAT THIS TEXT WAS CACHED, SO THAT LATER PUTS DON'T INVALIDATE THE CACHE.")
-          [COND
-             [(type? PIECE TEXT)                         (* ; 
-                       "If this isn't a text stream, build a piece table with the one piece in it.")
-              (COND
-                 ((EQ (fetch (PIECE PLEN) of TEXT)
-                      0)                                     (* ; 
-                                                           "I hate piece whose length is zero.")
-                  (SETQ PCTB (\MAKEPCTB (SETQ TEXT NIL)))    (* INSERT-BRT (CREATEPCNODE 1
-                                                           (QUOTE LASTPIECE)) PCTB)
-                  )
-                 (T (SETQ PCTB (\MAKEPCTB TEXT))             (* INSERT-BRT (CREATEPCNODE
-                                                           (ADD1 (fetch (PIECE PLEN) of TEXT))
-                                                           (QUOTE LASTPIECE)) PCTB)
-                    (replace (PIECE PLOOKS) of TEXT with (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                      (fetch (PIECE PLOOKS)
-                                                                         of TEXT)
-                                                                      TEXTOBJ))
-                                                             (* ; 
-                   "And note the CHARLOOKS and PARALOOKS of this text--as well as filling them in.")
-                    (replace (PIECE PPARALOOKS) of TEXT with (\TEDIT.UNIQUIFY.PARALOOKS
-                                                                          (fetch (PIECE 
-                                                                                           PPARALOOKS
-                                                                                            )
-                                                                             of TEXT)
-                                                                          TEXTOBJ]
-             (CLEARGET? 
-
-                    (* ;; "If the user wants an uninterpreted stream onto the file , build a piece table with the one piece in it.")
-
-                    (SETQ TEXT (create PIECE
-                                      PFILE _ TEXT
-                                      PFPOS _ (COND
-                                                 (START START)
-                                                 (T 0))
-                                      PLEN _ (IDIFFERENCE (OR END (GETEOFPTR TEXT))
-                                                    (COND
-                                                       (START START)
-                                                       (T 0)))
-                                      PREVPIECE _ NIL
-                                      PLOOKS _ DEFAULTLOOKS
-                                      PPARALAST _ NIL
-                                      PPARALOOKS _ DEFAULTPARALOOKS))
-                                                             (* ; 
-                                                        "A single piece to describe the whole file")
-                    (SETQ PCTB (\MAKEPCTB TEXT))
-                    (replace (PIECE PLOOKS) of TEXT with (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                      (fetch (PIECE PLOOKS)
-                                                                         of TEXT)
-                                                                      TEXTOBJ))
-                                                             (* ; 
-            "And note the CHARLOOKS and PARALOOKS for later saving.  Keep those caches consistent.")
-                    (replace (PIECE PPARALOOKS) of TEXT with (\TEDIT.UNIQUIFY.PARALOOKS
-                                                                          (fetch (PIECE 
-                                                                                           PPARALOOKS
-                                                                                            )
-                                                                             of TEXT)
-                                                                          TEXTOBJ))
-                                                             (* INSERT-BRT (CREATEPCNODE
-                                                           (ADD1 (fetch (PIECE PLEN) of TEXT))
-                                                           (QUOTE LASTPIECE)) PCTB)
-                    )
-             [(NOT PCCOUNT)                                  (* ; "This is an unformatted file")
-              (COND
-                 [(SETQ USERFILEFORMAT (for FILETYPE in TEDIT.INPUT.FORMATS
-                                          when (SETQ USERTEMP (APPLY* (CAR FILETYPE)
-                                                                         TEXT))
-                                          do (RETURN FILETYPE)))
-                                                             (* ; 
-     "The input file is in a user-sensible format, which he is willing to convert for TEdit's use.")
-                                                             (* ; "See if there are Bravo headers")
-                  (SETQ PCTB (\TEDIT.CONVERT.FOREIGN.FORMAT (CADR USERFILEFORMAT)
-                                    TEXT USERTEMP TEXTOBJ DEFAULTLOOKS DEFAULTPARALOOKS))
-                                                             (* ; 
-                                               "Convert the foreign format file, and grab its PCTB")
-                  (bind (PC _ (\GETBASEPTR (\FIRSTNODE PCTB)
-                                         0)) while [AND PC (NOT (EQ PC 'LASTPIECE]
-                     do                                  (* ; 
-      "Run thru the converted pieces, noting their CHARLOOKS and PARALOOKS for the get/put caches.")
-                           (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                           (fetch (PIECE PLOOKS)
-                                                                              of PC)
-                                                                           TEXTOBJ))
-                           (replace (PIECE PPARALOOKS) of PC
-                              with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE PPARALOOKS)
-                                                                     of PC)
-                                              TEXTOBJ))
-                           (SETQ PC (fetch (PIECE NEXTPIECE) of PC]
-                 (T                                          (* ; 
-                                                           "Nope--it's straight unformatted text")
-                    [SETQ PCTB (\MAKEPCTB (create PIECE
-                                                 PFILE _ TEXT
-                                                 PFPOS _ CURFILECH#
-                                                 PLEN _ (IDIFFERENCE (OR END (GETEOFPTR TEXT))
-                                                               CURFILECH#)
-                                                 PREVPIECE _ NIL
-                                                 PLOOKS _ (\TEDIT.UNIQUIFY.CHARLOOKS DEFAULTLOOKS 
-                                                                 TEXTOBJ)
-                                                 PPARALAST _ NIL
-                                                 PPARALOOKS _ (\TEDIT.UNIQUIFY.PARALOOKS 
-                                                                     DEFAULTPARALOOKS TEXTOBJ]
-                                                             (* ; 
-                                                "So create a single piece to describe its contents")
-                                                             (* INSERT-BRT (CREATEPCNODE
-                                                           (ADD1 (IDIFFERENCE
-                                                           (OR END (GETEOFPTR TEXT)) CURFILECH#))
-                                                           (QUOTE LASTPIECE)) PCTB)
-                                                             (* ; "Insert LASTPIECE here")
-                    ]
-             [(LISTP PCCOUNT)                                (* ; 
-                                            "This is an obsolete version of the TEdit file format.")
-              (SELECTQ (CAR PCCOUNT)
-                  (0                                         (* ; "VERSION 0")
-                     (SETQ PCTB (TEDIT.BUILD.PCTB0 TEXT TEXTOBJ (CDR PCCOUNT)
-                                       START END)))
-                  (1                                         (* ; 
-                                                 "Version 1;  obsoleted at INTERMEZZO release 2/85")
-                     (SETQ PCTB (TEDIT.BUILD.PCTB1 TEXT TEXTOBJ (CDR PCCOUNT)
-                                       START END)))
-                  (2                                         (* ; "Version 2;  obsoleted 5/22/85")
-                     (SETQ PCTB (TEDIT.BUILD.PCTB2 TEXT TEXTOBJ (CDR PCCOUNT)
-                                       START END)))
-                  (SHOULDNT "File format version incompatible with this version of TEdit."))
-              (bind (PC _ (\GETBASEPTR (\FIRSTNODE PCTB)
-                                     0)) while [AND PC (NOT (EQ PC 'LASTPIECE]
-                 do                                      (* ; 
-                    "Run thru the converted pieces, noting CHARLOOKS and PARALOOKS for the caches.")
-                       (replace (PIECE PLOOKS) of PC with (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                       (fetch (PIECE PLOOKS)
-                                                                          of PC)
-                                                                       TEXTOBJ))
-                       (replace (PIECE PPARALOOKS) of PC with (\TEDIT.UNIQUIFY.PARALOOKS
-                                                                           (fetch (PIECE 
-                                                                                           PPARALOOKS
-                                                                                             )
-                                                                              of PC)
-                                                                           TEXTOBJ))
-                       (SETQ PC (fetch (PIECE NEXTPIECE) of PC]
-             (T                                              (* ; 
-                                           "This IS a TEdit-format file, so read in all the parts.")
-                (SETQ PCTB (\MAKEPCTB NIL PCCOUNT))
-                (replace (TEXTOBJ PCTB) of TEXTOBJ with PCTB)
-                (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT))
-                                        8))
-                (SETQ PIECEINFOCH# (\DWIN TEXT))
-                (SETFILEPTR TEXT PIECEINFOCH#)
-                (bind (OLDPC _ NIL)
-                       (OLDPARALOOKS _ DEFAULTPARALOOKS) for I from 1 to PCCOUNT
-                   as PCN from 1
-                   do (SETQ PC NIL)                      (* ; 
-                      "This loop may not really read a piece, so we have to distinguish that case.")
-                         (SETQ PCLEN (\DWIN TEXT))
-                         (SETQ TYPECODE (\SMALLPIN TEXT))    (* ; "What kind of piece is it?")
-                         [SELECTC TYPECODE
-                             (\PieceDescriptorPAGEFRAME      (* ; 
-                                                           "This is page layout info for the file")
-                                  (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ
-                                                  with (TEDIT.GET.PAGEFRAMES TEXT)))
-                                  (add PCN -1)
-
-                                  (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))")
-                                                             (* ; 
-                              "This didn't create a piece -- don't count it in the PCTB placement.")
-                                  )
-                             (\PieceDescriptorCHARLOOKSLIST  (* ; 
-                                            "This is the list of CHARLOOKSs used in this document.")
-                                  (replace (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ
-                                     with (\TEDIT.GET.CHARLOOKS.LIST TEXT TEXTOBJ))
-                                                             (* ; 
-                                                    "Read the list of looks used in this document.")
-                                  [SETQ LOOKSHASH (ARRAY (FLENGTH (fetch (TEXTOBJ 
-                                                                                    TXTCHARLOOKSLIST)
-                                                                     of TEXTOBJ]
-                                                             (* ; 
-                                       "Build an array of the looks, so the reader can index them.")
-                                  (for I from 1 as LOOKS in (fetch (TEXTOBJ
-                                                                                        
-                                                                                     TXTCHARLOOKSLIST
-                                                                                        )
-                                                                               of TEXTOBJ)
-                                     do (SETA LOOKSHASH I LOOKS))
-                                  (add PCN -1)
-
-                                  (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))")
-                                                             (* ; 
-                              "This didn't create a piece -- don't count it in the PCTB placement.")
-                                  (add I -1))
-                             (\PieceDescriptorPARALOOKSLIST  (* ; 
-                                            "This is the list of PARALOOKSs used in this document.")
-                                  (replace (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ
-                                     with (\TEDIT.GET.PARALOOKS.LIST TEXT TEXTOBJ))
-                                                             (* ; 
-                                                    "Read the list of looks used in this document.")
-                                  [SETQ PARAHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST
-                                                                                   ) of TEXTOBJ]
-                                                             (* ; 
-                                       "Build an array of the looks, so the reader can index them.")
-                                  (for I from 1 as LOOKS in (fetch (TEXTOBJ
-                                                                                        
-                                                                                     TXTPARALOOKSLIST
-                                                                                        )
-                                                                               of TEXTOBJ)
-                                     do (SETA PARAHASH I LOOKS))
-                                  (add PCN -1)
-
-                                  (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))")
-                                                             (* ; 
-                              "This didn't create a piece -- don't count it in the PCTB placement.")
-                                  (add I -1))
-                             (\PieceDescriptorPARA           (* ; 
-                                                           "Reading a new set of paragraph looks.")
-                                  (AND OLDPC (replace (PIECE PPARALAST) of OLDPC with
-                                                                                         T))
-                                                             (* ; 
-                                                         "Mark the end of the preceding paragraph.")
-                                  (SETQ OLDPARALOOKS (\TEDIT.GET.PARALOOKS TEXT PARAHASH))
-                                                             (* ; 
-                                               "Get the new set of looks, for use by later pieces.")
-                                  (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) of TEXTOBJ
-                                                  with T))
-                                                             (* ; 
-                                        "Mark the document as containing paragraph formatting info")
-                                  (add PCN -1)
-
-                                  (* ;; "(|add| pcn (iminus |\\EltsPerPiece|))")
-                                                             (* ; 
-                              "This didn't create a piece -- don't count it in the PCTB placement.")
-                                  )
-                             (\PieceDescriptorLOOKS          (* ; 
-                                "New character looks.  Build a piece to describe those characters.")
-                                  (SETQ PC
-                                   (create PIECE
-                                          PFILE _ TEXT
-                                          PFPOS _ CURFILECH#
-                                          PLEN _ PCLEN
-                                          PREVPIECE _ OLDPC
-                                          PPARALOOKS _ OLDPARALOOKS))
-                                                             (* ; "Build the new piece")
-                                  (\TEDIT.GET.CHARLOOKS PC TEXT LOOKSHASH OLDPC)
-                                                             (* ; 
-                                                           "Read the character looks for this guy.")
-                                  (COND
-                                     (OLDPC                  (* ; 
-                                            "If there's a prior piece, hook this one on the chain.")
-                                            (replace (PIECE NEXTPIECE) of OLDPC with
-                                                                                        PC)))
-                                  (add CURFILECH# PCLEN) (* ; 
-                                                           "And note the passing of characters.")
-                                  )
-                             (\PieceDescriptorOBJECT         (* ; 
- "It describes an object.  Read that, and perhaps some description of the charlooks to go with it.")
-                                  (SETQ PC
-                                   (create PIECE
-                                          PFILE _ TEXT
-                                          PFPOS _ CURFILECH#
-                                          PLEN _ PCLEN
-                                          PREVPIECE _ OLDPC
-                                          PPARALOOKS _ OLDPARALOOKS))
-                                  (COND
-                                     (OLDPC                  (* ; 
-                                            "If there's a prior piece, hook this one on the chain.")
-                                            (replace (PIECE NEXTPIECE) of OLDPC with
-                                                                                        PC)))
-                                  (TEDIT.GET.OBJECT TEXTSTREAM PC TEXT CURFILECH#)
-                                  (add CURFILECH# (fetch (PIECE PLEN) of PC))
-                                  [COND
-                                     ((NOT (ZEROP (\BIN TEXT)))
-                                                             (* ; 
-                                    "There are new character looks for this object.  Read them in.")
-                                      (replace (PIECE PLOOKS) of PC with (
-                                                                        \TEDIT.GET.SINGLE.CHARLOOKS
-                                                                                      TEXT)))
-                                     (T                      (* ; 
-                                                  "No new looks;  steal them from the prior piece.")
-                                        (replace (PIECE PLOOKS) of PC
-                                           with (OR (AND OLDPC (fetch (PIECE PLOOKS)
-                                                                      of OLDPC))
-                                                        DEFAULTLOOKS]
-                                  (replace (PIECE PLEN) of PC with 1)
-                                                             (* ; 
-                                                       "OBJECTs are officially one character long.")
-                                  )
-                             (PROGN (TEDIT.PROMPTPRINT TEXTOBJ "WARNING: Unknown-type piece skipped."
-                                           T)
-                                    (SETFILEPTR TEXT (IPLUS (GETFILEPTR TEXT)
-                                                            (\SMALLPIN TEXT]
-                         (COND
-                            (PC (\INSERTPIECE PC 'LASTPIECE TEXTOBJ)
-                                                             (* ; 
-                                                     "If we created a piece, save it in the table.")
-                                (add CURCH# (fetch (PIECE PLEN) of PC))
-                                (SETQ OLDPC PC))) finally 
-
-                                                        (* ;; "(\\editseta pctb pcn curch#)")
-
-                                                        (* ;; 
-                                                      " (\\editseta pctb (add1 pcn) 'lastpiece)")
-
-                                                        (* ;; 
-                                            "(\\editseta pctb |\\PCTBLastPieceOffset| (add1 pcn)) ")
-
-                                                        (* ;; 
-                                                      "(\\editseta pctb |\\PCTBFreePieces| 0)")
-                                                             (* INSERT-BRT (CREATEPCNODE CURCH#
-                                                           (QUOTE LASTPIECE)) PCTB)
-                                                        ]
-          (AND (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ)
-               (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ)
-                      TEXTOBJ))                              (* ; 
-                       "And make sure that the default and caret looks are reflected in that list.")
-          (AND (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ)
-               (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ)
-                      TEXTOBJ))
-          (AND DEFAULTLOOKS (\TEDIT.UNIQUIFY.CHARLOOKS DEFAULTLOOKS TEXTOBJ))
-                                                             (* ; 
-                                                "And the default looks we used in this function...")
-          (\TEDIT.UNIQUIFY.PARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)
-                 TEXTOBJ)                                    (* ; 
-                                  "And make sure the default paralooks are reflected in that list.")
-          [AND TEXT (bind (CHARLOOKSLIST _ (fetch (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ))
-                           (PARALOOKSLIST _ (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ))
-                       for (PC _ (\GETBASEPTR (\FIRSTNODE PCTB)
-                                            0)) by (fetch (PIECE NEXTPIECE) of PC)
-                       while [AND PC (NOT (EQ PC 'LASTPIECE]
-                       do                                (* ; 
-               "Look at every piece, and assure that its CHARLOOKS and PARALOOKS are in the cache.")
-                             [COND
-                                ((FMEMB (fetch (PIECE PLOOKS) of PC)
-                                        CHARLOOKSLIST)       (* ; 
-        "This piece's CHARLOOKS are known in the cache already.  Don't bother doing anything else.")
-                                 )
-                                (T                           (* ; 
-                                                           "Nope;  add these looks to the cache")
-                                   (replace (PIECE PLOOKS) of PC
-                                      with (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (PIECE PLOOKS)
-                                                                             of PC)
-                                                      TEXTOBJ]
-                             (COND
-                                ((FMEMB (fetch (PIECE PPARALOOKS) of PC)
-                                        PARALOOKSLIST)       (* ; 
-        "This piece's PARALOOKS are known in the cache already.  Don't bother doing anything else.")
-                                 )
-                                (T                           (* ; 
-                                                           "Nope;  add these looks to the cache")
-                                   (replace (PIECE PPARALOOKS) of PC
-                                      with (\TEDIT.UNIQUIFY.PARALOOKS (fetch (PIECE 
-                                                                                           PPARALOOKS
-                                                                                            )
-                                                                             of PC)
-                                                      TEXTOBJ]
-          (RETURN PCTB])
-
-(\TEDIT.CONVERT.FOREIGN.FORMAT
-  [LAMBDA (CONVERSIONFN FILE PREDICATERESULT TEXTOBJ DEFAULTLOOKS DEFAULTPARALOOKS)
-                                                            (* ; "Edited 12-Jun-90 18:16 by mitani")
-
-         (* Perform the conversion from a foreign file format into TEdit-internal form 
-       as an open TextStream.)
-
-    (PROG (TSTREAM TTEXTOBJ SEL WORKINGSTREAM)               (* See if there are Bravo headers)
-          (SETQ WORKINGSTREAM (OPENTEXTSTREAM ""))
-          (RESETLST
-              (RESETSAVE (\TEDIT.SET.WINDOW (CONS (TEXTOBJ WORKINGSTREAM)
-                                                      NIL)))
-              (SETQ TSTREAM (APPLY* CONVERSIONFN FILE PREDICATERESULT WORKINGSTREAM)))
-          (COND
-             (TEXTOBJ 
-
-         (* If we're filling in an existing TEXTOBJ, there are fields that need to be 
-       copied.)
-
-                    [OR (fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ)
-                        (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ
-                           with (fetch (TEXTOBJ TXTPAGEFRAMES) of (TEXTOBJ TSTREAM]
-                                                             (* Such as the page formatting, 
-                                                           which the converter may well set.)
-                    ))
-          (RETURN (fetch (TEXTOBJ PCTB) of (TEXTOBJ TSTREAM])
-
-(TEDIT.FORMATTEDFILEP
-  [LAMBDA (STREAM)                                       (* ; "Edited 19-Apr-93 11:57 by jds")
-                                                             (* ; 
- "Test to see if this stream's text would need a TEdit-format file (T) or is just plain text (NIL)")
-    (PROG ((TEXTOBJ (TEXTOBJ STREAM))
-           (FONTFILE 0)
-           OLDPARALOOKS PC OLDLOOKS PREVPC TENTATIVE)
-          (SETQ OLDPARALOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))
-          (SETQ TENTATIVE (TEXTPROP TEXTOBJ 'TEDIT.TENTATIVE))
-                                                             (* ; "If edits are to be shown")
-          (SETQ PC (\GETBASEPTR (\FIRSTNODE (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-                          0))                                (* ; "First piece in the document")
-          (COND
-             ((ATOM PC)                                      (* ; "Empty document")
-              (RETURN NIL)))
-          (SETQ OLDLOOKS (OR (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ)
-                             TEDIT.DEFAULT.CHARLOOKS))
-          (while PC do [COND
-                                  ((fetch (PIECE POBJ) of PC)
-                                                             (* ; 
-                                                           "OBJECTS require the special format")
-                                   (SETQ FONTFILE 4))
-                                  ([AND (OR (NOT PREVPC)
-                                            (fetch (PIECE PPARALAST) of PREVPC))
-                                        (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS) of PC)
-                                                    (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ]
-                                                             (* ; "We just hit a paragraph break.")
-                                   (SETQ FONTFILE (IMAX FONTFILE 3)))
-                                  ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS) of
-                                                                                         PC)))
-                                       (AND TENTATIVE (OR (AND PREVPC (NEQ (fetch (PIECE PNEW)
-                                                                              of PREVPC)
-                                                                           (fetch (PIECE PNEW)
-                                                                              of PC)))
-                                                          (AND (NOT PREVPC)
-                                                               (fetch (PIECE PNEW) of PC))
-                                                          (AND PREVPC (NEQ (fetch (PIECE PFATP)
-                                                                              of PREVPC)
-                                                                           (fetch (PIECE PFATP)
-                                                                              of PC]
-                                                             (* ; "Change in font, size, etc.")
-                                   (SETQ FONTFILE (IMAX FONTFILE 2)))
-                                  ((fetch (PIECE PFATP) of PC)
-                                                             (* ; "NS Chars in the piece.")
-                                   (SETQ FONTFILE (IMAX FONTFILE 1]
-                              (SETQ PREVPC PC)
-                              (SETQ PC (fetch (PIECE NEXTPIECE) of PC)))
-          (RETURN (SELECTQ FONTFILE
-                      (0 NIL)
-                      (1 'NSCHARS)
-                      (2 'CHARLOOKS)
-                      (3 'PARALOOKS)
-                      (4 'IMAGEOBJ)
-                      NIL])
-
-(TEDIT.GET
-  [LAMBDA (TEXTOBJ FILE UNFORMATTED?)                    (* ; "Edited 19-Apr-93 13:12 by jds")
-
-    (* ;; "Get a new file (overwriting the one being edited.)")
-
-    (PROG ((TEXTOBJ (TEXTOBJ TEXTOBJ))
-           OFILE OCURSOR LINES USER.CMFILE RESP TITLE FILENAME MENUSTREAM (GETFN (TEXTPROP
-                                                                                  TEXTOBJ
-                                                                                  'GETFN))
-           (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-           (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-           (TEDIT.GET.FINISHEDFORMS NIL))
-          (COND
-             ([AND (fetch (TEXTOBJ \DIRTY) of TEXTOBJ)
-                   (PROGN (AND (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ)
-                               (FRESHLINE (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ)))
-                          (NOT (MOUSECONFIRM "Not saved yet; LEFT go Get anyway." T
-                                      (fetch (TEXTOBJ PROMPTWINDOW) of TEXTOBJ]
-
-              (* ;; "Only do the GET if he knows he'll zorch himself.")
-
-              (RETURN)))
-          [SETQ OFILE (OR FILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "File to GET:  "
-                                                           (OR (TEXTPROP TEXTOBJ 'LASTGETFILENAME)
-                                                               (\TEXTSTREAM.FILENAME TEXTOBJ]
-          (TEXTPROP TEXTOBJ 'LASTGETFILENAME OFILE)
-          (COND
-             [(AND OFILE (OR (OPENP FILE)
-                             (INFILEP OFILE)))               (* ; 
-                                              "Only if there's a file to load and the file exists.")
-              (COND
-                 ((AND GETFN (EQ (APPLY* GETFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)
-                                        (FULLNAME OFILE)
-                                        'BEFORE)
-                                 'DON'T))                    (* ; 
-                                                    "He doesn't want this document put.  Bail out.")
-                  (RETURN)))
-              (TEXTPROP TEXTOBJ 'LASTGETFILENAME NIL)
-              (RESETLST
-                  (RESETSAVE (TTYDISPLAYSTREAM (OR (AND (NEQ (fetch (TEXTOBJ PROMPTWINDOW)
-                                                                of TEXTOBJ)
-                                                             'DON'T)
-                                                        (fetch (TEXTOBJ PROMPTWINDOW)
-                                                           of TEXTOBJ))
-                                                   PROMPTWINDOW)))
-                  (RESETSAVE (CURSOR WAITINGCURSOR))
-                  (\SHOWSEL (fetch (TEXTOBJ SEL) of TEXTOBJ)
-                         NIL NIL)
-                  (\TEXTCLOSEF (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))
-                                                             (* ; "CLOSE the old files")
-                  [OR (AND (STREAMP FILE)
-                           (OPENP FILE))
-                      (SETQ OFILE (OPENSTREAM OFILE 'INPUT]  (* ; "And open the new one.")
-                  (SETQ PCTB (replace (TEXTOBJ PCTB) of TEXTOBJ
-                                with (TEDIT.BUILD.PCTB OFILE TEXTOBJ NIL NIL
-                                                (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ)
-                                                (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)
-                                                UNFORMATTED?)))
-                  (for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM))
-                                                             (* ; 
-                                                    "Do any necessary cleanup for outside packages")
-                  (SETQ LINES (fetch (TEXTOBJ LINES) of TEXTOBJ))
-                  (replace (TEXTOBJ \DIRTY) of TEXTOBJ with NIL)
-                  (for FIRSTLINE inside LINES do (replace (LINEDESCRIPTOR NEXTLINE)
-                                                                of FIRSTLINE with NIL))
-                  (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-
-                  (* ;; "The old cached piece is no longer valid--keep people from stepping on it, to prevent lost type-in and smashing other docuemnts to which it has been moved...")
-
-                  (* ;; "(replace TEXTLEN of TEXTOBJ with (SUB1 (\EDITELT PCTB (SUB1 (\EDITELT PCTB \PCTBLastPieceOffset)))))")
-
-                  (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (fetch (BTREENODE TOTLEN
-                                                                                           )
-                                                                            of PCTB))
-                  (replace (SELECTION CH#) of SEL with (replace (SELECTION CHLIM)
-                                                                      of SEL with 1))
-                  (replace (SELECTION DCH) of SEL with 0)
-                  (replace (SELECTION POINT) of SEL with 'LEFT)
-                  (replace (SELECTION SET) of SEL with T)
-                  (replace (SELECTION SET) of (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)
-                     with NIL)
-                  (replace (SELECTION SET) of (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)
-                     with NIL)
-                  (replace (SELECTION SET) of (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)
-                     with NIL)
-                  (replace (SELECTION SET) of TEDIT.SELECTION with NIL)
-                  (replace (SELECTION SET) of TEDIT.SHIFTEDSELECTION with NIL)
-                  (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (
-                                                                          \TEDIT.GET.INSERT.CHARLOOKS
-                                                                             TEXTOBJ SEL))
-                  (for WINDOW inside (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-                     as LINE inside LINES do     (* ; 
-                                                       "Fill the edit window (s) with the new text")
-                                                        (\FILLWINDOW (fetch (LINEDESCRIPTOR
-                                                                                 YBOT) of LINE)
-                                                               LINE TEXTOBJ NIL WINDOW))
-                  (\FIXSEL SEL TEXTOBJ)
-                  (\SHOWSEL SEL NIL T)
-                  (SETQ TITLE (TEXTSTREAM.TITLE TEXTOBJ))    (* ; "find and set the title")
-                  (\TEDIT.WINDOW.TITLE TEXTOBJ (\TEDIT.ORIGINAL.WINDOW.TITLE TITLE NIL))
-                  (SETQ MENUSTREAM (TEDITMENU.STREAM TEXTOBJ))
-                  (COND
-                     ((AND MENUSTREAM (type? LITATOM TITLE))
-                                                             (* ; 
-                          "if we have a filename then put it in the GET and PUT fields of the menu")
-                      (SETQ FILENAME (PACKFILENAME 'VERSION NIL 'BODY TITLE))
-                      (MBUTTON.SET.FIELD MENUSTREAM 'Get FILENAME)
-                      (MBUTTON.SET.FIELD MENUSTREAM 'Put FILENAME)))
-                  (\TEDIT.SET.WINDOW.EXTENT TEXTOBJ (\TEDIT.PRIMARYW TEXTOBJ))
-                  (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT
-                                                    THACTION _ 'Get)))
-              (AND GETFN (APPLY* GETFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)
-                                (FULLNAME (fetch (TEXTOBJ TXTFILE) of TEXTOBJ))
-                                'AFTER]
-             (OFILE (TEDIT.PROMPTPRINT TEXTOBJ "[File not found.]")
-                    (TEXTPROP TEXTOBJ 'LASTGETFILENAME OFILE)(* ; 
-                                   "Remember the file name he tried for, so we offer it next time.")
-                    )
-             (T (TEDIT.PROMPTPRINT TEXTOBJ "[Get aborted.]" T])
-
-(TEDIT.PARSE.PAGEFRAMES1
-  [LAMBDA (PAGELIST PARENT)                                  (* ; "Edited  2-Jan-87 12:21 by jds")
-                                                             (* Take an external pageframe and 
-                                                             internalize it.)
-    (PROG (FRAMETYPE PAGEFRAME)
-          (COND
-             ((type? PAGEREGION PAGELIST)
-              (RETURN PAGELIST))
-             ((NEQ 'LIST (SETQ FRAMETYPE (pop PAGELIST)))
-              [SETQ PAGEFRAME (create PAGEREGION
-                                     REGIONFILLMETHOD _ FRAMETYPE
-                                     REGIONTYPE _ (pop PAGELIST)
-                                     REGIONLOCALINFO _ (pop PAGELIST)
-                                     REGIONSPEC _ (for VAL
-                                                     in (OR (pop PAGELIST)
-                                                            (LIST 0 0 0 0))
-                                                     collect (\TEDIT.SCALE VAL
-                                                                    (CONSTANT (FQUOTIENT 1 35.27778]
-              (replace REGIONSUBBOXES of PAGEFRAME with (for ALIST in (pop PAGELIST)
-                                                           collect (TEDIT.PARSE.PAGEFRAMES1 ALIST 
-                                                                          PAGEFRAME)))
-              (RETURN PAGEFRAME))
-             (T (RETURN (for FRAMESPEC in (CAR PAGELIST) collect (TEDIT.PARSE.PAGEFRAMES1 FRAMESPEC 
-                                                                        NIL])
-
-(\ARBIN
-  [LAMBDA (STREAM)                                           (* jds "13-Nov-86 20:21")
-                                                             (* ; 
-                                     "Read an arbitrary object from a file, parse it, and return it.")
-
-    (PROG ((LEN (\SMALLPIN STREAM))
-           USERSTR)
-          (COND
-             ((NOT (ZEROP LEN))
-              (SETQ USERSTR (OPENSTRINGSTREAM (\STRINGIN STREAM LEN)
-                                   'INPUT))
-              (RETURN (PROG1 (READ USERSTR *TEDIT-FILE-READTABLE*)
-                             (CLOSEF? USERSTR])
-
-(\ATMIN
-  [LAMBDA (STREAM)                                           (* jds " 3-Apr-84 10:41")
-    (PROG ((LEN (\SMALLPIN STREAM)))
-          (RETURN (COND
-                     ((ZEROP LEN)
-                      NIL)
-                     (T (PACK (for I from 1 to LEN collect (CHARACTER (\BIN STREAM])
-
-(\DWIN
-  [LAMBDA (FILE)                                             (* jds " 3-JAN-83 16:08")
-    (IPLUS (LLSH (\BIN FILE)
-                 24)
-           (LLSH (\BIN FILE)
-                 16)
-           (LLSH (\BIN FILE)
-                 8)
-           (\BIN FILE])
-
-(\STRINGIN
-  [LAMBDA (STREAM SETLEN)                                (* ; "Edited 20-Apr-88 19:54 by jds")
-          (* Read a string in length-contents form%: One word for the length, and one 
-        byte per character contained. However, the length may be specified by the 
-        caller instead of being read from the file.)
-    (PROG ((LEN (OR SETLEN (\SMALLPIN STREAM)))
-           STR)
-          (SETQ STR (ALLOCSTRING LEN))
-          [OR (ZEROP LEN)
-              (for I from 1 to LEN do (RPLCHARCODE STR I (READCCODE STREAM]
-          (RETURN STR])
-
-(\TEDIT.FORMATTEDP1
-  [LAMBDA (FILE LEN)                                     (* ; "Edited 12-Feb-88 11:43 by jds")
-                                                             (* ; 
-                                                           "Checks for a version-1 formatted file")
-          
-          (* ;; "Returns NIL if it isn't a formatted file, or the # of pieces needed if it is;  leaves file at start of text or of piece descriptions, resp.")
-
-    (SETQ LEN (OR LEN (GETEOFPTR FILE)))
-    (PROG (DESCPTR NPIECES PASSWORD)
-          (COND
-             ((ILEQ LEN 8)                                   (* ; "Too short to be formatted.")
-
-              (RETURN NIL))
-             (T (SETFILEPTR FILE (IDIFFERENCE LEN 8))        (* ; 
-                                                         "Move to start of FILEPTR to descriptions")
-
-                (SETQ DESCPTR (\DWIN FILE))              (* ; 
-                                                           "Read the file pos of the descriptions")
-
-                (SETQ NPIECES (\SMALLPIN FILE))
-                (SETQ PASSWORD (\SMALLPIN FILE))
-                (COND
-                   ((IEQP PASSWORD 31418)                    (* ; 
-                                                   "Version 3 TEdit format;  instituted on 5/22/85")
-
-                    (SETFILEPTR FILE DESCPTR)
-                    (RETURN NPIECES))
-                   ((IEQP PASSWORD 31417)
-          
-          (* ;; "Version 2 format.  Obsoleted 5/22/85 to permit revision of looks in the future without loss of compatibility")
-
-                    (SETFILEPTR FILE DESCPTR)
-                    (RETURN (CONS 2 NPIECES)))
-                   ((IEQP PASSWORD 31416)                    (* ; "VERSION 1 TEDIT FORMAT")
-
-                    (SETFILEPTR FILE DESCPTR)
-                    (RETURN (CONS 1 NPIECES)))
-                   ((IEQP PASSWORD 31415)                    (* ; "VERSION 0 TEDIT FORMAT")
-
-                    (SETFILEPTR FILE DESCPTR)
-                    (RETURN (CONS 0 NPIECES)))
-                   (T                                        (* ; "NOT A FORMATTED FILE")
-
-                      (SETFILEPTR FILE 0)
-                      (RETURN NIL])
-
-(\TEDIT.SET.WINDOW
-  [LAMBDA (TOWIND)                                      (* ; "Edited 12-Jun-90 18:16 by mitani")
-                                                             (* USED IN RESETSAVES TO NULL OUT A 
-                                                           TEXTSTREAM'S WINDOW BRIEFLY.)
-    (PROG1 (CONS (CAR TOWIND)
-                 (fetch (TEXTOBJ \WINDOW) of (CAR TOWIND)))
-        (replace (TEXTOBJ \WINDOW) of (CAR TOWIND) with (CDR TOWIND)))])
-)
-
-
-
-(* ;; "INCLUDEing a file")
-
-(DEFINEQ
-
-(TEDIT.INCLUDE
-  [LAMBDA (STREAM FILE START END SAFE)        (* ; 
-                                                "Edited  4-May-95 10:29 by sybalsky:mv:envos")
-
-    (* ;; "Obtain a file name, and include that file's contents at the place where the caret is.")
-
-    (* ;; "Returns T if the insertion happened, NIL if there was no place to put it.")
-
-    (SETQ STREAM (TEXTOBJ STREAM))
-    (PROG ((SEL (fetch (TEXTOBJ SEL) of STREAM))
-           PCTB TEXTLEN NFILE NNFILE INSERTCH# INSPC LEN INSPC# PCLST NPC WASOPEN PCCOUNT NSTREAM 
-           START-OF-PIECE)
-          (DECLARE (SPECVARS START-OF-PIECE))
-          (COND
-             ((fetch (TEXTOBJ TXTREADONLY) of STREAM)(* ; "This is read-only.")
-              )
-             ((fetch (SELECTION SET) of SEL)         (* ; 
-                                                           "There is a place to do the include.")
-              [SETQ NFILE (OR FILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT STREAM 
-                                                               "Name of the file to load:  "]
-              (COND
-                 ((NOT NFILE)                                (* ; 
-                                                   "If no file was given, don't bother INCLUDEing.")
-                  (TEDIT.PROMPTPRINT STREAM "[Include aborted.]" T)
-                  (RETURN))
-                 ((STREAMP NFILE))
-                 ((NOT (INFILEP NFILE))                      (* ; 
-                                                         "Can't find the file.  Put out a message.")
-                  (TEDIT.PROMPTPRINT STREAM "[File not found.]")
-                  (RETURN)))
-              (COND
-                 ((NOT SAFE)
-
-                  (* ;; "If the caller sets SAFE, we don't need to do any of this copying, because he's guaranteeing that the files'll be there until we don't need 'em any more.")
-
-                  (SETQ NNFILE (OPENSTREAM '{NODIRCORE} 'OUTPUT 'NEW))
-                                                             (* ; "Create the holding file")
-                  [SETQ NFILE (COND
-                                 ((OPENP NFILE)
-                                  (SETQ WASOPEN T)
-                                  NFILE)
-                                 (T                          (* ; 
-                                                      "Wasn't open -- need to open it for input...")
-                                    (OPENFILE NFILE 'INPUT]  (* ; 
-                                                           "And copy the file-section into it.")
-                  [COPYCHARS NFILE NNFILE (OR START 0)
-                         (OR END (GETFILEINFO NFILE 'LENGTH] (* ; "Have to explicitly fill in 0 and EOFPTR, because if the file was open already, NILs would only copy from current fileptr to EOF.")
-                  (OR WASOPEN (CLOSEF NFILE))                (* ; 
-                                                   "If the file didn't come to use open, close it.")
-                  (CLOSEF NNFILE)
-                  (SETQ NFILE NNFILE)
-                  (SETQ START (SETQ END NIL))                (* ; "Then pretend nothing happened.")
-                  ))
-              (TEDIT.DO.BLUEPENDINGDELETE SEL STREAM)        (* ; "Delete any text, if need be")
-              (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of STREAM))
-                                                             (* ; 
-              "We need the POST-deletion text length for later, so this must come after the b-p-d.")
-              (\SHOWSEL SEL NIL NIL)                         (* ; 
-                                                           "Turn off SELs before we go any further")
-              [SETQ NFILE (TEXTOBJ (SETQ NSTREAM (OPENTEXTSTREAM (OPENSTREAM NFILE 'INPUT)
-                                                        NIL NIL NIL (LIST 'FONT (
-                                                                          \TEDIT.GET.INSERT.CHARLOOKS
-                                                                                 STREAM SEL)
-                                                                          'PARALOOKS
-                                                                          (fetch (TEXTOBJ FMTSPEC
-                                                                                            )
-                                                                             of STREAM]
-
-              (* ;; "Get a textobj to describe the include source file (need NSTREAM so that if we have to convert it to formatted, we won't have lost the textstream--and thus smash the free list.)")
-
-              (COND
-                 ((AND (fetch (TEXTOBJ FORMATTEDP) of NFILE)
-                       (NOT (fetch (TEXTOBJ FORMATTEDP) of STREAM)))
-                                                             (* ; 
-                          "If the includED text is formatted but this file isn't, let's format it!")
-                  (\TEDIT.CONVERT.TO.FORMATTED STREAM))
-                 ((AND (fetch (TEXTOBJ FORMATTEDP) of STREAM)
-                       (NOT (fetch (TEXTOBJ FORMATTEDP) of NFILE)))
-
-                  (* ;; "The TARGET document is formatted, but the INCLUDEd text isn't.  Better format it before completing the include.")
-
-                  (\TEDIT.CONVERT.TO.FORMATTED NFILE)))
-              (SETQ PCTB (fetch (TEXTOBJ PCTB) of STREAM))
-                                                             (* ; 
-                                 "HERE, because the conversion to formatted will lengthen the pctb")
-              [SETQ INSERTCH# (COND
-                                 ((EQ (fetch (SELECTION POINT) of SEL)
-                                      'LEFT)
-                                  (fetch (SELECTION CH#) of SEL))
-                                 (T (fetch (SELECTION CHLIM) of SEL]
-                                                             (* ; 
-                                                           "Find the place to make the insertion.")
-              (SETQ INSPC (\CHTOPC INSERTCH# PCTB T))        (* ; 
-                                                           "The piece to make the insertion in")
-              [COND
-                 ((NEQ INSPC 'LASTPIECE)
-                  (COND
-                     ((IGREATERP INSERTCH# START-OF-PIECE)   (* ; "Must split the piece.")
-                      (SETQ INSPC (\SPLITPIECE INSPC INSERTCH# STREAM INSPC#))
-                      (SETQ PCTB (fetch (TEXTOBJ PCTB) of STREAM))
-                                                             (* ; 
-                                                           "Refresh the PCTB in case it grew.")
-                      ]
-              (SETQ PCLST (fetch (TEXTOBJ PCTB) of NFILE))
-                                                             (* ; 
-                            "A temporary pctb, holding the pieces which describe the INCLUDEd text")
-              (SETQ LEN (fetch (BTREENODE TOTLEN) of PCLST))
-              (\TEDIT.INSERT.PIECES STREAM INSERTCH# (SETQ PCLST (\GETBASEPTR (\FIRSTNODE PCLST)
-                                                                        0))
-                     LEN INSPC INSPC# NIL)
-              [COND
-                 ((AND (fetch (TEXTOBJ FORMATTEDP) of STREAM)
-                       (NOT (fetch (TEXTOBJ FORMATTEDP) of NFILE)))
-                                                             (* ; 
-                          "If the includED text is formatted but this file isn't, let's format it!")
-                  (\TEDIT.CONVERT.TO.FORMATTED STREAM INSERTCH# (IPLUS INSERTCH# LEN]
-              (\TEDIT.HISTORYADD STREAM (create TEDITHISTORYEVENT
-                                               THACTION _ 'Include
-                                               THCH# _ INSERTCH#
-                                               THLEN _ LEN
-                                               THFIRSTPIECE _ PCLST))
-                                                             (* ; 
-                                                  "Remember that we did this, so it can be undone.")
-              (replace (TEXTOBJ TEXTLEN) of STREAM with (IPLUS TEXTLEN LEN))
-                                                             (* ; 
-         "Inserting the pieces didn't fix up things like the length of the document, so do it now.")
-              (AND (fetch (TEXTOBJ \WINDOW) of STREAM)
-                   (\FIXILINES STREAM SEL INSERTCH# LEN TEXTLEN))
-                                                             (* ; "Mark any changed lines dirty.")
-              (replace (SELECTION CHLIM) of SEL with (IPLUS (replace (SELECTION
-                                                                                      CH#)
-                                                                           of SEL with 
-                                                                                            INSERTCH#
-                                                                               )
-                                                                        LEN))
-                                                             (* ; 
-         "Now fix up the selection to be the included text, point_left, character selection grain.")
-              (replace (SELECTION DCH) of SEL with LEN)
-              (replace (SELECTION DX) of SEL with 0)
-              (replace (SELECTION POINT) of SEL with 'RIGHT)
-                                                             (* ; 
-                                    "So that several things INCLUDED in sequence fall in sequence.")
-              (replace (SELECTION SELKIND) of SEL with 'CHAR)
-              (replace (SELECTION SELOBJ) of SEL with NIL)
-              (COND
-                 ((fetch (TEXTOBJ \WINDOW) of STREAM)(* ; 
-                        "We're displaying;  update the display and the selection's line references")
-                  (TEDIT.UPDATE.SCREEN STREAM)
-                  (\FIXSEL SEL STREAM)
-                  (\SHOWSEL SEL NIL T)))
-              (replace (TEXTOBJ \DIRTY) of STREAM with T)
-                                                             (* ; "Mark the document changed")
-              (\SETUPGETCH (IPLUS -1 INSERTCH# LEN (- (fetch (TEXTOBJ TEXTLEN) of STREAM)
-                                                      (+ TEXTLEN LEN)))
-                     STREAM)                                 (* ; "Set the fileptr to the end of the insertion; the (- fetch ...) form accounts for any change due to NSCHAR translation that may occur duing the screen update.")
-              T)
-             (T (TEDIT.PROMPTPRINT STREAM "Please choose the place for the INCLUDE first." T])
-
-(TEDIT.RAW.INCLUDE
-  [LAMBDA (STREAM INFILE START END)           (* ; 
-                                                "Edited 27-May-93 16:36 by sybalsky:mv:envos")
-
-    (* ;; "takes a text stream and an OPEN stream to include.  Note: Start and End are inclusive ptrs, unlike in copybytes and friends")
-
-    (* ;; 
-  "no interpretation (alternate file type e.g.  Bravo) takes place.  Simply include the characters")
-
-    (* ;; "Default character and paragraph looks are applied")
-
-    (LET* ((TEXTOBJ (TEXTOBJ STREAM))
-           (START START)
-           (END END)
-           (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-           [HOLDING.FILE (OR (fetch (TEXTOBJ TXTRAWINCLUDESTREAM) of TEXTOBJ)
-                             (replace (TEXTOBJ TXTRAWINCLUDESTREAM) of TEXTOBJ
-                                with (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW]
-           PCTB TEXTLEN INSERTCH# INSPC LEN INSPC# PCLST NPC WASOPEN HOLDSTART HOLDLEN START-OF-PIECE
-           )
-          (COND
-             ((NOT (fetch (SELECTION SET) of SEL))
-              (SHOULDNT "\TEDIT.RAW.INCLUDE called with no selection set"))
-             ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)
-                                                             (* ; "Not allowed to change it.")
-              )
-             (T                                              (* ; 
-                                                           "There is a place to do the include.")
-                (\SHOWSEL SEL NIL NIL)                       (* ; 
-                                                           "Turn any pre-existing selection off")
-                (COND
-                   (END 
-                        (* ;; "This is the copy-part-of-a-file case, with file liable to be volatile.  Copy it to core for protection")
-
-                        [SETQ INFILE (COND
-                                        ((OPENP INFILE)
-                                         (SETQ WASOPEN T)
-                                         INFILE)
-                                        (T (OPENSTREAM INFILE 'INPUT]
-                                                             (* ; 
-                                                           "And copy the file-section into it.")
-                        (SETFILEPTR HOLDING.FILE (SETQ HOLDSTART (GETEOFPTR HOLDING.FILE)))
-                                                             (* ; 
-                                            "Move to the end of the pre-existing part of the file.")
-                        (COPYBYTES INFILE HOLDING.FILE START END)
-                                                             (* ; 
-                                                     "must be copychars to respect eol conventions")
-                        (SETQ HOLDLEN (IDIFFERENCE (OR END (GETEOFPTR INFILE))
-                                             START))
-                        (COND
-                           ((NOT WASOPEN)                    (* ; 
-                                         "Close the input file if it wasn't open when we got here.")
-                            (CLOSEF INFILE)))
-                        (SETQ INFILE HOLDING.FILE)
-                        (SETQ START (SETQ END NIL))          (* ; "Then pretend nothing happened.")
-                        ))
-                (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-                (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-                (SETQ INSERTCH# (TEDIT.GETPOINT NIL SEL))    (* ; 
-                                                           "Find the place to make the insertion.")
-                (SETQ INSPC (OR (\CHTOPC INSERTCH# PCTB T)
-                                (LASTPIECE PCTB)))           (* ; 
-                                                           "The piece to make the insertion in")
-                [COND
-                   ((NEQ INSPC 'LASTPIECE)
-                    (COND
-                       ((IGREATERP INSERTCH# START-OF-PIECE) (* ; "Must split the piece.")
-                        (SETQ INSPC (\SPLITPIECE INSPC (- INSERTCH# START-OF-PIECE)
-                                           TEXTOBJ INSPC#))
-                        (add INSPC# 1)
-                        (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-                                                             (* ; 
-                                                           "Refresh the PCTB in case it grew.")
-                        ]
-                (SETQ PCLST (create PIECE
-                                   PFILE _ INFILE
-                                   PFPOS _ (OR HOLDSTART START 0)
-                                   PLEN _ [OR HOLDLEN (IDIFFERENCE
-                                                       [COND
-                                                          (END END)
-                                                          (T (* ; "get the eof pointer")
-                                                             (COND
-                                                                ((OPENP INFILE)
-                                                                 (GETEOFPTR INFILE))
-                                                                (T (OPENSTREAM INFILE 'INPUT)
-                                                                   (PROG1 (GETEOFPTR INFILE)
-                                                                          (CLOSEF INFILE]
-                                                       (COND
-                                                          (START START)
-                                                          (T 0]
-                                   PREVPIECE _ NIL
-                                   NEXTPIECE _ NIL
-                                   PLOOKS _ (\TEDIT.UNIQUIFY.CHARLOOKS (CHARLOOKS.FROM.FONT 
-                                                                              DEFAULTFONT)
-                                                   TEXTOBJ)
-                                   PPARALAST _ NIL
-                                   PPARALOOKS _ (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC))
-                 )
-                (SETQ LEN (fetch (PIECE PLEN) of PCLST))
-                (\TEDIT.INSERT.PIECES TEXTOBJ INSERTCH# PCLST LEN INSPC INSPC# NIL)
-                (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IPLUS TEXTLEN LEN))
-                (AND (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-                     (\FIXILINES TEXTOBJ SEL INSERTCH# LEN TEXTLEN))
-                (replace (SELECTION CHLIM) of SEL with (IPLUS (replace (SELECTION
-                                                                                        CH#)
-                                                                             of SEL with
-                                                                                        INSERTCH#)
-                                                                          LEN))
-                                                             (* ; 
-         "Now fix up the selection to be the included text, point_left, character selection grain.")
-                (replace (SELECTION DCH) of SEL with LEN)
-                (replace (SELECTION DX) of SEL with 0)
-                (replace (SELECTION POINT) of SEL with 'RIGHT)
-                                                             (* ; 
-                                    "So that several things INCLUDED in sequence fall in sequence.")
-                (replace (SELECTION SELKIND) of SEL with 'CHAR)
-                (replace (SELECTION SELOBJ) of SEL with NIL)
-                (COND
-                   ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-                    (TEDIT.UPDATE.SCREEN TEXTOBJ)
-                    (\FIXSEL SEL TEXTOBJ)
-                    (\SHOWSEL SEL NIL T)))
-                (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T)
-                                                             (* ; "Mark the document changed")
-                (\SETUPGETCH (create EDITMARK
-                                    PC _ INSPC
-                                    PCOFF _ 0
-                                    PCNO _ NIL)
-                       TEXTOBJ)                              (* ; 
-                                                     "Set the fileptr to the end of the insertion.")
-                T])
-)
-
-
-
-(* ;; "PUTting a file:")
-
-(DEFINEQ
-
-(TEDIT.PUT
-  [LAMBDA (STREAM FILE FORCENEW UNFORMATTED? OLDFORMAT?) (* ; "Edited 19-Apr-93 13:04 by jds")
-
-    (* ;; "If the guy was editing a file, make a new updated version;  else, ask for a file name")
-
-    (* ;; "If FILE is specd, it's used;  else the user must give us one")
-
-    (* ;; "Returns an open stream on the file you PUT to.")
-
-    (PROG ((TEXTOBJ (TEXTOBJ STREAM))
-           (TEDIT.PUT.FINISHEDFORMS NIL)
-           (TEDIT.GET.FINISHEDFORMS NIL)
-           (OUTPUT.FILE.WRITTEN NIL)
-           OCURSOR OFILE FONTFILEUSED PROPS WINDOW PUTFN CACHE MENUSTREAM FILENAME TITLE CH#S PC)
-          [COND
-             (FILE                                           (* ; "We were given a file to use.")
-                   (SETQ OFILE FILE))
-             [FORCENEW                                       (* ; 
-                                           "He insists on a new file.  (without giving us one NIL)")
-                    (SETQ OFILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "File to PUT to:  "]
-             (T                                              (* ; "Get a file to put the text into")
-                (SETQ OFILE (\TEDIT.MAKEFILENAME (TEDIT.GETINPUT TEXTOBJ "File to PUT to:  "
-                                                        (\TEXTSTREAM.FILENAME TEXTOBJ]
-          (SETQ PUTFN (TEXTPROP TEXTOBJ 'PUTFN))
-          (SETQ CACHE (TEXTPROP TEXTOBJ 'CACHE))
-          (COND
-             ((NOT OFILE)                                    (* ; 
-                                                        "There's no file to put to;  don't bother.")
-              (RETURN))
-             ((AND PUTFN (EQ (APPLY* PUTFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)
-                                    (FULLNAME OFILE)
-                                    'BEFORE)
-                             'DON'T))                        (* ; 
-                                                    "He doesn't want this document put.  Bail out.")
-              (RETURN)))
-          (RESETLST
-              [RESETSAVE [SETQ OFILE (OPENSTREAM OFILE 'OUTPUT 'NEW NIL
-                                            (COND
-                                               [UNFORMATTED? (* ; 
-                                              "If the user forced no formatting, respect his wish.")
-                                                      '((TYPE TEXT]
-                                               [(TEDIT.FORMATTEDFILEP TEXTOBJ)
-                                                             (* ; 
-               "If this file has objects, para looks, or font changes, then we need a binary file.")
-                                                '((TYPE BINARY]
-                                               [(EQL (U-CASE (FILENAMEFIELD OFILE 'EXTENSION))
-                                                     'TEDIT) (* ; "If file extension is TEDIT, then we presume that it really is a tedit file, thus making it a binary file.")
-                                                '((TYPE BINARY]
-                                               (T            (* ; 
-                                                        "Otherwise, we can get by with a text file")
-                                                  '((TYPE TEXT]
-                     '(AND RESETSTATE (DELFILE (CLOSEF? OLDVALUE]
-              [RESETSAVE (\TEDIT.PUTRESET (CONS (THIS.PROCESS)
-                                                    'DON'T]
-              (replace DESC of (fetch (TEXTOBJ THISLINE) of TEXTOBJ) with NIL)
-              (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "PUTting file " (fetch (STREAM FULLNAME)
-                                                                    of OFILE)
-                                                "...")
-                     T)
-              [COND
-                 ((IGREATERP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)
-                         0)
-                  (SETQ FONTFILEUSED (COND
-                                        (OLDFORMAT? (TEDIT.PUT.PCTB2 TEXTOBJ OFILE UNFORMATTED?))
-                                        (T (TEDIT.PUT.PCTB TEXTOBJ OFILE UNFORMATTED?]
-              (CLOSEF OFILE)                                 (* ; 
-                                     "Close the file, to free it up. And re-open it for INPUT only")
-              [COND
-                 ((NOT CACHE)                                (* ; 
-                                     "CSLI if caching do not need to reopen the output file anyway")
-                  (SETQ OFILE (OPENSTREAM (fetch (STREAM FULLFILENAME) of OFILE)
-                                     'INPUT]                 (* ; 
-                           "changed TEMPORary for ns filing with caching.  may not work in general")
-              (CLOSEF? (fetch (TEXTOBJ TXTFILE) of TEXTOBJ))
-                                                             (* ; "Close the old text file")
-              (replace (TEXTOBJ TXTFILE) of TEXTOBJ with OFILE)
-                                                             (* ; 
-                                                          "And remember the new one for next time.")
-              (replace (TEXTOBJ \DIRTY) of TEXTOBJ with NIL)
-                                                             (* ; 
-                                                  "We can safely QUIT now without losing anything.")
-              )
-          (SETQ CH#S (REVERSE (CDR FONTFILEUSED)))           (* ; 
-                                             "The true filepos's of the pieces in the output file.")
-          [COND
-             ((AND (NOT CACHE)
-                   (RANDACCESSP OFILE)
-                   (EQ CR.EOLC (fetch (STREAM EOLCONVENTION) of OFILE)))
-
-              (* ;; "If we've cached this file, DON'T go thru and fill in the real file's location, because the EOL convention may well be wrong.")
-
-              (* ;; "(SETQ PC (ELT (fetch PCTB of TEXTOBJ) (ADD1 \FirstPieceOffset)))")
-
-              (UNINTERRUPTABLY
-                  (SETQ PC (\GETBASEPTR (\FIRSTNODE (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-                                  0))
-                  (while (AND PC CH#S) do 
-
-                                                 (* ;; 
-          "Run thru the pieces in the PCTB, pointing them to the new file and their new locations.")
-
-                                                 (COND
-                                                    ((fetch (PIECE POBJ) of PC))
-                                                    (T (replace (PIECE PFPOS) of PC
-                                                          with (pop CH#S))
-                                                       (CLOSEF? (fetch (PIECE PFILE) of
-                                                                                         PC))
-                                                             (* ; 
-     "If this is a piece on an open file, close it, since we're never going to read from it again.")
-                                                       (replace (PIECE PFILE) of PC
-                                                          with OFILE)
-                                                       (replace (PIECE PSTR) of PC
-                                                          with NIL)))
-                                                 (SETQ PC (fetch (PIECE NEXTPIECE) of PC))))]
-          (TEDIT.PROMPTPRINT TEXTOBJ "done.")                (* ; "Tell him we're finished.")
-          (SETQ TITLE (TEXTSTREAM.TITLE TEXTOBJ))            (* ; "find and set the title")
-          (\TEDIT.WINDOW.TITLE TEXTOBJ (\TEDIT.ORIGINAL.WINDOW.TITLE TITLE NIL))
-          (SETQ MENUSTREAM (TEDITMENU.STREAM TEXTOBJ))
-          (COND
-             ((AND MENUSTREAM (type? LITATOM TITLE))     (* ; 
-                          "if we have a filename then put it in the GET and PUT fields of the menu")
-              (SETQ FILENAME (PACKFILENAME 'VERSION NIL 'BODY TITLE))
-              (MBUTTON.SET.FIELD MENUSTREAM 'Get FILENAME)
-              (MBUTTON.SET.FIELD MENUSTREAM 'Put FILENAME)))
-          (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; "Make sure any new insertions happen for real, and not as appends.  Since all the pieces now point to the file rather than the strings.")
-          (replace (TEXTOBJ \INSERTPC) of TEXTOBJ with NIL)
-
-     (* ;; "make sure that TEDIT doesn't try to just add to the \INSERTPC since it will now have a pfile property")
-
-          (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT
-                                            THACTION _ 'Put
-                                            THCH# _ 0
-                                            THLEN _ 0
-                                            THFIRSTPIECE _ NIL))
-                                                             (* ; "Remember we did this.")
-          (AND PUTFN (APPLY* PUTFN (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)
-                            (fetch (STREAM FULLNAME) of (fetch (TEXTOBJ TXTFILE)
-                                                                   of TEXTOBJ))
-                            'AFTER))                         (* ; 
-                                         "CSLI changed to not presume ofile is the txtfile anymore")
-          (RETURN OFILE])
-
-(TEDIT.PUT.PCTB
-  [LAMBDA (TEXTOBJ OFILE UNFORMATTED? SEPARATEFORMAT)
-                                                  (* ; 
-                                                "Edited 27-May-93 16:00 by sybalsky:mv:envos")
-
-    (* ;; "Put a representation of the piece table onto OFILE, preserving font changes and paragraph looks.  UNFORMATTED?  means write no font or formatting info.")
-
-    (PROG (OCURSOR CH PC PFILE PSTR POBJ OFILELEN OLDLOOKS (OLDPARALOOKS (fetch (TEXTOBJ FMTSPEC)
-                                                                            of TEXTOBJ))
-                 (*READTABLE* *TEDIT-FILE-READTABLE*)
-                 (*PRINT-BASE* 10)
-                 OLDCH# CURCH# PREVPC FONTFILE (PCCOUNT 0)
-                 TRUEFILE CHARLOOKSLST PARALOOKSLST (TEDIT.PUT.FINISHEDFORMS NIL)
-                 (EDITSTENTATIVE (TEXTPROP TEXTOBJ 'TEDIT.TENTATIVE))
-                 (PARALOOKSSEEN NIL)
-                 (FORMATTINGLEVEL (TEDIT.FORMATTEDFILEP TEXTOBJ))
-                 (CACHE (TEXTPROP TEXTOBJ 'CACHE))
-                 CH#S PREVFATP PARAHASH LOOKSHASH PREVPREVPC)
-          (replace (STREAM LINELENGTH) of OFILE with MAX.SMALLP)
-                                                             (* ; 
-                                     "Prevent spurious carriage-returns in the piece descriptions.")
-
-     (* ;; "(SETQ PC (\EDITELT (fetch PCTB of TEXTOBJ) (ADD1 \FirstPieceOffset)))")
-
-          (SETQ PC (\GETBASEPTR (\FIRSTNODE (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-                          0))                                (* ; "First piece in the document")
-          (SETQ OLDLOOKS (OR (AND (type? PIECE PC)
-                                  (fetch (PIECE PLOOKS) of PC))
-                             (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ)
-                             TEDIT.DEFAULT.CHARLOOKS))       (* ; "Starting looks")
-          (COND
-             ((NEQ (fetch (STREAM EOLCONVENTION) of OFILE)
-                   CR.EOLC)                                  (* ; 
-                                          "This file is on a non-CR host;  make a note to cache it")
-              (SETQ TRUEFILE OFILE)                          (* ; 
-                                                          "Remember where the file should wind up.")
-              (SETQ OFILE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
-                                                             (* ; 
-                                                           "And open a temp file to write it to.")
-              (replace (STREAM LINELENGTH) of OFILE with MAX.SMALLP)
-                                                             (* ; 
-                                     "Prevent spurious carriage-returns in the piece descriptions.")
-              ))
-          [SETQ CURCH# (SETQ OLDCH# (ADD1 (GETFILEPTR OFILE]
-          (COND
-             ((fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ)
-                                                             (* ; 
-                                                     "There is layout info for this file.  Save it")
-              (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE))
-                                                             (* ; 
-                                                          "Open a font-info file if one is needed.")
-              (TEDIT.PUT.PAGEFRAMES FONTFILE (fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ))
-              (add PCCOUNT 1)))
-          (\TEDIT.FLUSH.UNUSED.LOOKS TEXTOBJ PC)             (* ; 
-                        "Run thru the lists of char & para looks and remove any that aren't in use")
-          (COND
-             ([AND (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)
-                   (OR (IGREATERP (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ))
-                              1)
-                       (NOT (EQFMTSPEC (CAR (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ))
-                                   TEDIT.DEFAULT.FMTSPEC]
-
-              (* ;; "There are paragraph looks in this document that don't match the default -- save the list of them for later retrieval.")
-
-              (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE))
-                                                             (* ; 
-                                                          "Open a font-info file if one is needed.")
-              (SETQ PARAHASH (\TEDIT.PUT.PARALOOKS.LIST FONTFILE (fetch (TEXTOBJ 
-                                                                                     TXTPARALOOKSLIST
-                                                                                       ) of
-                                                                                         TEXTOBJ)))
-              (SETQ PARALOOKSSEEN T)))
-          [COND
-             ((OR PARALOOKSSEEN FORMATTINGLEVEL)
-
-              (* ;; "There are character looks in this document that don't match the default (or paragraph formatting, which forces looks to be saved) -- save the list for later retrieval.")
-
-              (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE))
-                                                             (* ; 
-                                                          "Open a font-info file if one is needed.")
-              (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST FONTFILE (fetch (TEXTOBJ 
-                                                                                     TXTCHARLOOKSLIST
-                                                                                        )
-                                                                         of TEXTOBJ]
-          [while PC do (COND
-                                  ([AND (NOT (ZEROP (fetch (PIECE PLEN) of PC)))
-                                        (OR (NOT PREVPC)
-                                            (fetch (PIECE PPARALAST) of PREVPC))
-                                        (OR PARALOOKSSEEN (NOT (EQFMTSPEC (fetch (PIECE 
-                                                                                           PPARALOOKS
-                                                                                            )
-                                                                             of PC)
-                                                                      (fetch (TEXTOBJ FMTSPEC)
-                                                                         of TEXTOBJ]
-                                                             (* ; 
-                                     "The last piece ended a paragraph, so send out new para looks")
-                                   (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE))
-                                                             (* ; 
-                                                          "Open a font-info file if one is needed.")
-                                   (COND
-                                      ((NEQ CURCH# OLDCH#)   (* ; 
-            "There were prior characters that hadn't been described in a piece yet.  Describe them")
-                                       [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST
-                                                                      FONTFILE
-                                                                      (fetch (TEXTOBJ 
-                                                                                     TXTCHARLOOKSLIST
-                                                                                        )
-                                                                         of TEXTOBJ]
-                                       (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC 
-                                              EDITSTENTATIVE LOOKSHASH PREVFATP)
-                                       (add PCCOUNT 1)
-                                       (SETQ OLDCH# CURCH#)  (* ; 
-                                "And now we've described all the characters up to the current one.")
-                                       ))
-                                   (\TEDIT.PUT.PARALOOKS FONTFILE PC PARAHASH)
-                                   (SETQ PARALOOKSSEEN T)    (* ; 
-           "Remember that we've seen a foreign paralooks, and must henceforth note para boundaries")
-                                   (add PCCOUNT 1)))
-                              (COND
-                                 [(fetch (PIECE POBJ) of PC)
-                                                             (* ; 
-                                                           "It's an object -- go use its PUTFN")
-                                  (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE))
-                                                             (* ; 
-                                                          "Open a font-info file if one is needed.")
-                                  (COND
-                                     ((AND (NEQ CURCH# OLDCH#)
-                                           PREVPC)           (* ; 
-            "There were prior characters that hadn't been described in a piece yet.  Describe them")
-                                      [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST
-                                                                     FONTFILE
-                                                                     (fetch (TEXTOBJ 
-                                                                                     TXTCHARLOOKSLIST
-                                                                                       ) of
-                                                                                         TEXTOBJ]
-                                      (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC 
-                                             EDITSTENTATIVE LOOKSHASH PREVFATP)
-                                      (add PCCOUNT 1)
-                                      (SETQ OLDCH# CURCH#)   (* ; 
-                                "And now we've described all the characters up to the current one.")
-                                      ))                     (* ; 
-                                          "If the prior thing was text, send along its descriptor.")
-                                  (AND (NOT UNFORMATTED?)
-                                       (add CURCH# (TEDIT.PUT.OBJECT PC OFILE FONTFILE CURCH#)))
-                                                             (* ; "Send out the object")
-                                  (add PCCOUNT 1)
-                                  (SETQ OLDCH# CURCH#)
-                                  (COND
-                                     ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS)
-                                                                     of PC)))
-                                          (NEQ (fetch (PIECE PFATP) of PC)
-                                               (AND PREVPC (fetch (PIECE PFATP) of PREVPC)))
-                                          [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW)
-                                                                      of PC)
-                                                                   (AND PREVPC (fetch
-                                                                                (PIECE PNEW)
-                                                                                  of PREVPC]
-                                          (AND (OR (NOT PREVPC)
-                                                   (fetch (PIECE PPARALAST) of PREVPC))
-                                               (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS)
-                                                                  of PC)
-                                                           (fetch (TEXTOBJ FMTSPEC) of 
-                                                                                              TEXTOBJ
-                                                                  ]
-                                                             (* ; 
-                                                        "The OBJECT has different ooks from before")
-                                      (\BOUT FONTFILE 1)
-                                      (\TEDIT.PUT.SINGLE.CHARLOOKS FONTFILE (fetch
-                                                                                 (PIECE PLOOKS)
-                                                                                   of PC))
-                                      (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC)))
-                                     (T                      (* ; 
-                                   "No differences.  Don't write any charlooks, and mark that fact")
-                                        (\BOUT FONTFILE 0)   (* ; 
-                              "MAKE BLOODY SURE THAT THE NEXT RUN OF CHARACTERS GETS ITS OWN LOOKS")
-                                        ]
-                                 ((NOT (ZEROP (fetch (PIECE PLEN) of PC)))
-                                                             (* ; "It's not an object.")
-
-                                  (* ;; 
-                                "For 0-length pieces, don't even acknowledge their existence!!")
-
-                                  (* ;; "So only do this processing if there's text in the piece.")
-
-                                  [COND
-                                     ([OR [NEQ (fetch (PIECE PFATP) of PC)
-                                               (SETQ PREVFATP (AND PREVPC (fetch (PIECE PFATP)
-                                                                             of PREVPC]
-                                          (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS)
-                                                                     of PC)))
-                                          [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW)
-                                                                      of PC)
-                                                                   (AND PREVPC (fetch
-                                                                                (PIECE PNEW)
-                                                                                  of PREVPC]
-                                          (AND (OR (NOT PREVPC)
-                                                   (fetch (PIECE PPARALAST) of PREVPC))
-                                               (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS)
-                                                                  of PC)
-                                                           (fetch (TEXTOBJ FMTSPEC) of 
-                                                                                              TEXTOBJ
-                                                                  ]
-                                                             (* ; "We have a piece with new looks.")
-                                                             (* ; 
-                "The PREVFATP clause needs to come first, so that PREVFATP gets set for later use.")
-                                      (SETQ FONTFILE (\TEDIT-OPEN-FONT-FILE FONTFILE))
-                                                             (* ; 
-                                                          "Open a font-info file if one is needed.")
-                                      (COND
-                                         ((NOT (IEQP OLDCH# CURCH#))
-                                                             (* ; 
-               "If there were looks past, and if the run was not empty, save a piece for its looks")
-                                          [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST
-                                                                         FONTFILE
-                                                                         (fetch (TEXTOBJ 
-                                                                                     TXTCHARLOOKSLIST
-                                                                                           )
-                                                                            of TEXTOBJ]
-                                          (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS 
-                                                 PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP)
-                                          (add PCCOUNT 1)))
-                                      (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC))
-                                      (SETQ OLDCH# CURCH#)
-                                      (COND
-                                         [PREVFATP (COND
-                                                      ((fetch (PIECE PFATP) of PC))
-                                                      (T     (* ; "Switching from FAT to thin")
-                                                         (BOUT OFILE 255)
-                                                         (BOUT OFILE 0)
-                                                         (add CURCH# 2]
-                                         ((fetch (PIECE PFATP) of PC)
-                                                             (* ; "Switching from thin to fat")
-                                          (BOUT OFILE 255)
-                                          (BOUT OFILE 255)
-                                          (BOUT OFILE 0)
-                                          (add CURCH# 3] (* ; 
-                                               "Now dump out the non-object contents of the piece.")
-                                  [COND
-                                     [(SETQ PFILE (fetch (PIECE PFILE) of PC))
-                                                             (* ; "It's on a file.  Copy it.")
-                                      [OR (OPENP PFILE)
-                                          (replace (PIECE PFILE) of PC
-                                             with (SETQ PFILE (\TEDIT.REOPEN.STREAM TEXTOBJ PFILE
-                                                                         ]
-                                                             (* ; "Make sure the file is open.")
-                                      (COPYBYTES PFILE OFILE (fetch (PIECE PFPOS) of PC)
-                                             (IPLUS (fetch (PIECE PFPOS) of PC)
-                                                    (COND
-                                                       ((fetch (PIECE PFATP) of PC)
-                                                             (* ; 
-                                     "For fat file pieces, copy twice as many bytes as characters.")
-                                                        (UNFOLD (fetch (PIECE PLEN) of PC)
-                                                               2))
-                                                       (T (fetch (PIECE PLEN) of PC]
-                                     ((SETQ PSTR (fetch (PIECE PSTR) of PC))
-                                                             (* ; 
-                                                           "It's in a string.  Just print it.")
-                                      (COND
-                                         [(fetch (PIECE PFATP) of PC)
-                                                             (* ; 
-                                            "The string is fat: Copy twice as many bytes as chars.")
-                                          (for I from 1 to (fetch (PIECE PLEN)
-                                                                          of PC) as CH
-                                             instring PSTR do (\BOUT OFILE (\CHARSET CH))
-                                                                     (\BOUT OFILE (\CHAR8CODE CH]
-                                         (T                  (* ; 
-                                                   "The string is thin.  Just copy it to the file.")
-                                            (for I from 1 to (fetch (PIECE PLEN)
-                                                                            of PC) as CH
-                                               instring PSTR do (\BOUT OFILE CH]
-                                  [COND
-                                     ((AND (NOT CACHE)
-                                           (RANDACCESSP OFILE))
-                                                             (* ; 
-"CSLI leave the pieces and the pctb alone and just write the file if its cached or not randomaccess")
-                                      (push CH#S (SUB1 CURCH#]
-                                  [COND
-                                     ((fetch (PIECE PFATP) of PC)
-                                      (add CURCH# (UNFOLD (fetch (PIECE PLEN) of PC)
-                                                             2)))
-                                     (T (add CURCH# (fetch (PIECE PLEN) of PC]
-                                                             (* ; 
-                                                  "Keep running track of where in the file we are.")
-                                  ))
-                              (COND
-                                 ((NOT (ZEROP (fetch (PIECE PLEN) of PC)))
-
-                                  (* ;; "Only remember this piece if it's not zero-length!")
-
-                                  (SETQ PREVPREVPC PREVPC)
-                                  (SETQ PREVPC PC)))
-                              (SETQ PC (fetch (PIECE NEXTPIECE) of PC))
-             finally                                     (* ; 
-                                      "Put out a piece describing the last characters in the file.")
-                   (COND
-                      ((AND FONTFILE (NEQ OLDCH# CURCH#))    (* ; 
-                   "Only if there WERE characters, and only if there's a need for font information")
-                       [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST
-                                                      FONTFILE
-                                                      (fetch (TEXTOBJ TXTCHARLOOKSLIST)
-                                                         of TEXTOBJ]
-                       (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE 
-                              LOOKSHASH PREVPREVPC)          (* ; 
-                                                          "Put out a description of the characters")
-                       (add PCCOUNT 1)))
-                   (COND
-                      ((AND PARALOOKSSEEN (fetch (PIECE PPARALAST) of PREVPC))
-                                                             (* ; 
-                       "The last piece contained the end of a paragraph.  Make sure it gets noted.")
-                       (\TEDIT.PUT.PARALOOKS FONTFILE PREVPC PARAHASH)
-
-                       (* ;; "Write out a dummy paragraph-looks piece, so that we protect the PPARALAST of the final piece in the document.")
-
-                       (\DWOUT FONTFILE 0)
-                       (\SMALLPOUT FONTFILE \PieceDescriptorPARA)
-                       (\SMALLPOUT FONTFILE 1)
-
-                       (* ;; "This adds a total of 2 pieces to the file:")
-
-                       (add PCCOUNT 2]
-          (for FORM in TEDIT.PUT.FINISHEDFORMS do (EVAL FORM))
-                                                             (* ; "Do any user-specific cleanup")
-          (COND
-             (TRUEFILE                                       (* ; 
-                                          "This file needs to be converted to the right convention")
-                    (COND
-                       ((AND FONTFILE (NOT UNFORMATTED?)
-                             (NOT SEPARATEFORMAT))           (* ; 
-                                                         "Formatted file: Copy without converting.")
-                        (COPYBYTES OFILE TRUEFILE 0 -1))
-                       (T                                    (* ; 
-                                "Go ahead and convert the EOLCONVENTION, this is a plain-text file")
-                          (COPYCHARS OFILE TRUEFILE 0 -1)))
-                    (SETQ OFILE TRUEFILE)))
-          [COND
-             ((AND (OPENP OFILE)
-                   FONTFILE)                                 (* ; "We need to write format info.")
-              (\DWOUT FONTFILE (GETFILEPTR OFILE))       (* ; 
-                                           "So remember the end of the plain-text part of the file")
-              (\SMALLPOUT FONTFILE PCCOUNT)                  (* ; 
-                                                   "# OF PIECES WE'' NEED TO RECONSTRUCT THIS FILE")
-              (\SMALLPOUT FONTFILE 31418)                    (* ; 
-                                                     "Now the password for NEW format files: 31416")
-              (COND
-                 ((AND (NOT UNFORMATTED?)
-                       (NOT SEPARATEFORMAT))
-
-                  (* ;; "Only write fmtg info at the end if we want it there--not if we want plain text or want it kept separate.")
-
-                  (COPYBYTES FONTFILE OFILE 0 (GETEOFPTR FONTFILE))
-                                                             (* ; 
-                                                    "Copy the font information to the file trailer")
-                  )
-                 (T))
-              (CLOSEF FONTFILE)
-              (COND
-                 ((NOT SEPARATEFORMAT)                       (* ; 
-                                   "Unless we want the formatting info separately, delete the file")
-                                                             (* ; 
-          "(since FONTFILE is a stream, we should not need to delete it at all) (DELFILE FONTFILE)")
-                  ]
-          (replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                           (fetch (TEXTOBJ 
-                                                                                     DEFAULTCHARLOOKS
-                                                                                             )
-                                                                              of TEXTOBJ)
-                                                                           TEXTOBJ))
-                                                             (* ; 
-    "Re-add the default and caret looks's to the lists, since they may not have been really saved.")
-          (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                     (fetch (TEXTOBJ CARETLOOKS)
-                                                                        of TEXTOBJ)
-                                                                     TEXTOBJ))
-          (replace (TEXTOBJ FMTSPEC) of TEXTOBJ with (\TEDIT.UNIQUIFY.PARALOOKS
-                                                                  (fetch (TEXTOBJ FMTSPEC)
-                                                                     of TEXTOBJ)
-                                                                  TEXTOBJ))
-          (RETURN (CONS (COND
-                           (UNFORMATTED? NIL)
-                           (T FONTFILE))
-                        CH#S])
-
-(\TEDIT.PUTRESET
-  [LAMBDA (PROC&VALUE)                                       (* jds "15-May-85 16:38")
-    (CONS (CAR PROC&VALUE)
-          (PROCESSPROP (CAR PROC&VALUE)
-                 'BEFOREEXIT
-                 (CDR PROC&VALUE])
-
-(TEDIT.PUT.PIECE.DESCRIPTOR
-  [LAMBDA (FILE CH1 CHLIM LOOKS)                         (* ; "Edited 30-May-91 20:25 by jds")
-                                                             (* Put a description of LOOKS into 
-                                                           FILE. LOOKS apply to characters CH1 
-                                                           thru CHLIM-1)
-                                                             (* (PROG ((FONT (fetch
-                                                           (CHARLOOKS CLFONT) of LOOKS)) STR)
-                                                           (SETQ STR (CONCAT "(FONTCREATE "
-                                                           (KWOTE (FONTPROP FONT
-                                                           (QUOTE FAMILY))) " "
-                                                           (FONTPROP FONT (QUOTE SIZE)) " "
-                                                           (KWOTE (FONTPROP FONT
-                                                           (QUOTE FACE))) " )"))
-                                                           (\DWOUT FILE (IDIFFERENCE CHLIM CH1))
-                                                           (* The length of this run of looks)
-                                                           (\SMALLPOUT FILE (NCHARS STR))
-                                                           (* The length of the description 
-                                                           which follows) (PRIN1 STR FILE)
-                                                           (* Print the form which can EVAL to 
-                                                           re-create the font information)
-                                                           (\BOUT FILE (LOGOR
-                                                           (COND ((fetch (CHARLOOKS CLPROTECTED)
-  of LOOKS) 8) (T 0)) (COND ((fetch (CHARLOOKS CLINVISIBLE) of LOOKS) NIL 4) (T 0))
-                                                           (COND ((fetch (CHARLOOKS CLSELHERE) 
-                                                           of LOOKS) 2) (T 0))
-                                                           (COND ((fetch (CHARLOOKS CLCANCOPY) 
-                                                           of LOOKS) 1) (T 0))))))
-    (HELP])
-
-(\ARBOUT
-  [LAMBDA (STREAM ITEM)                                  (* ; "Edited 20-Apr-88 19:55 by jds")
-                                                             (* ; 
-                                  "Write an arbitrary MKSTRING-able thing in length-contents form.")
-    (LET ((SIZE (AND ITEM (NCHARS ITEM T *TEDIT-FILE-READTABLE*)))
-          (FPTR)
-          (END-FPTR))
-         (\SMALLPOUT STREAM (OR SIZE 0))
-         (SETQ FPTR (GETFILEPTR STREAM))
-         (OR (NOT ITEM)
-             (ZEROP SIZE)
-             (PRIN2 ITEM STREAM *TEDIT-FILE-READTABLE*))
-          (* ;; "Because of NS chars, you gotta back up and really count bytes.")
-                                                             (* (SETQ END-FPTR (GETFILEPTR STREAM))
-                                                           (SETFILEPTR STREAM FPTR)
-                                                           (\SMALLPOUT STREAM
-                                                           (-
-                                                           END-FPTR FPTR)) (SETFILEPTR STREAM 
-                                                           END-FPTR))
-         NIL])
-
-(\ATMOUT
-  [LAMBDA (STREAM ATOM)                                      (* jds "30-Jan-85 14:46")
-                                                             (* Write an atom's characters in 
-                                                             length-contents form.)
-    (\SMALLPOUT STREAM (COND
-                          (ATOM (NCHARS ATOM))
-                          (T 0)))
-    (OR (NOT ATOM)
-        (ZEROP (NCHARS ATOM))
-        (for CH inatom ATOM do (\BOUT STREAM CH])
-
-(\DWOUT
-  [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])
-
-(\STRINGOUT
-  [LAMBDA (STREAM STRING LEN)                                (* jds " 1-May-84 11:58")
-          
-          (* Write a string on a file in length-contents form;
-          one word for the length, and one byte per character contained.)
-
-    (SETQ LEN (OR LEN (NCHARS STRING)))
-    (\SMALLPOUT STREAM LEN)
-    (OR (ZEROP LEN)
-        (for CH instring STRING as I from 1 to LEN do (\BOUT STREAM CH])
-
-(\TEDIT-OPEN-FONT-FILE
-  [LAMBDA (EXISTING-FONTFILE-IF-ANY)                         (* ; "Edited 23-Sep-87 12:31 by jds")
-          
-          (* ;; " Open a font-information file for TEDIT PUT operation, if one doesn't exist already.  Also set its linelength to effective infinity, so that we don't get spurious CRs in the middle of formatting info.")
-          
-          (* ;; 
-          "The calling form must be (SETQ FOO (\TEDIT-OPEN-FONT-FILE FOO)), to preserve information.")
-
-    (COND
-       ((NOT EXISTING-FONTFILE-IF-ANY)                       (* ; 
-                                                  "Create the font-info file if it doesn't exist yet")
-
-        (SETQ EXISTING-FONTFILE-IF-ANY (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
-        (replace (STREAM LINELENGTH) of EXISTING-FONTFILE-IF-ANY with MAX.SMALLP)
-                                                             (* ; 
-                                       "Prevent spurious carriage-returns in the piece descriptions.")
-
-        ))
-    EXISTING-FONTFILE-IF-ANY])
-)
-(DEFINEQ
-
-(\TEDIT.GET.CHARLOOKS.LIST
-  [LAMBDA (FILE)                                             (* jds "28-Jan-85 17:50")
-                                                             (* Read the list of CHARLOOKSs from 
-                                                             the file.)
-    (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.CHARLOOKS FILE])
-
-(\TEDIT.GET.SINGLE.CHARLOOKS
-  [LAMBDA (FILE)                                         (* ; "Edited 30-May-91 20:25 by jds")
-                                                             (* Read a set of CHARLOOKS from FILE)
-    (PROG* ((LOOKS (create CHARLOOKS))
-            (FILEPOS (GETFILEPTR FILE))
-            (LOOKSLEN (\SMALLPIN FILE))
-            FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR)
-           (SETQ NAME (\ARBIN FILE))                     (* The font name)
-           (SETQ SIZE (\SMALLPIN FILE))                      (* Size of the type, in points)
-           (SETQ SUPER (\SMALLPIN FILE))                     (* Superscripting distance)
-           (replace (CHARLOOKS CLSTYLE) of LOOKS with (OR (\ARBIN FILE)
-                                                                      0))
-           (replace (CHARLOOKS CLUSERINFO) of LOOKS with (\ARBIN FILE))
-           (SETQ PROPS (\SMALLPIN FILE))
-           (with CHARLOOKS LOOKS [SETQ CLLEADER (NOT (ZEROP (LOGAND 2048 PROPS]
-                  [SETQ CLINVERTED (NOT (ZEROP (LOGAND 1024 PROPS]
-                  [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS]
-                  [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS]
-                  [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS]
-                  [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS]
-                  [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS]
-                  [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS]
-                  [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS]
-                  [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS]
-                  [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS]
-                  [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS]
-                  (SETQ CLSIZE SIZE)
-                  (SETQ CLOFFSET SUPER))
-           [replace (CHARLOOKS CLFONT) of LOOKS
-              with (COND
-                          ((LISTP NAME)                      (* This was a font class.
-                                                           Restore it.)
-                           (FONTCLASS (pop NAME)
-                                  NAME))
-                          ((AND NAME (NOT (ZEROP SIZE)))
-                           (FONTCREATE NAME SIZE (COND
-                                                    ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS)
-                                                          (fetch (CHARLOOKS CLITAL) of LOOKS)
-                                                          )
-                                                     'BOLDITALIC)
-                                                    ((fetch (CHARLOOKS CLBOLD) of LOOKS)
-                                                     'BOLD)
-                                                    ((fetch (CHARLOOKS CLITAL) of LOOKS)
-                                                     'ITALIC]
-           (SETFILEPTR FILE (IPLUS FILEPOS LOOKSLEN))
-           (RETURN LOOKS])
-
-(\TEDIT.PUT.CHARLOOKS.LIST
-  [LAMBDA (FILE LOOKSLIST)                                   (* jds " 5-Mar-85 15:58")
-                                                             (* Write the list of CHARLOOKSs into 
-                                                             the font file.)
-          
-          (* Returns a hasharray that will map from a given CHARLOOKS to that CHARLOOKS' 
-          position in the list we wrote on the file.
-          Those position numbers are then written in the individual looks descriptions, 
-          and are used to reconstruct the piece looks when the file is read back in.)
-
-    (PROG ((LOOKSHASH (HASHARRAY 50)))
-          (\DWOUT FILE 0)                                    (* No characters are described by this 
-                                                             pseudo-piece entry.)
-          (\SMALLPOUT FILE \PieceDescriptorCHARLOOKSLIST)    (* Mark it as containing the list of 
-                                                             CHARLOOKSs)
-          (\SMALLPOUT FILE (FLENGTH LOOKSLIST))              (* How many CHARLOOKSs there are in 
-                                                             the list)
-          (for I from 1 as LOOKS in LOOKSLIST do 
-          
-          (* Write each charlooks, in the order they appear in the list.)
-
-                                                 (\TEDIT.PUT.SINGLE.CHARLOOKS FILE LOOKS) 
-                                                             (* Write out the description)
-                                                 (PUTHASH LOOKS I LOOKSHASH) 
-          
-          (* And save it in the hash table so people can find its index.)
-)
-          (RETURN LOOKSHASH])
-
-(\TEDIT.PUT.SINGLE.CHARLOOKS
-  [LAMBDA (FILE LOOKS)                                   (* ; "Edited 30-May-91 20:26 by jds")
-                                                             (* Put out a single CHARLOOKS 
-                                                           description.)
-    (PROG ((FILEPOS (GETFILEPTR FILE))
-           (FONT (fetch (CHARLOOKS CLFONT) of LOOKS))
-           STR LEN)
-          (\SMALLPOUT FILE 0)                                (* Reserve space for the length of 
-                                                           this looks)
-          [COND
-             ((type? FONTCLASS FONT)                     (* For font classes, we need to save 
-                                                           a list of device-FD sets)
-              (\ARBOUT FILE (FONTCLASSUNPARSE FONT)))
-             (T                                              (* For FONTDESCRIPTORs, do it the 
-                                                           easy way)
-                (\ATMOUT FILE (FONTPROP FONT 'FAMILY]    (* The font family)
-          (\SMALLPOUT FILE (OR (FONTPROP FONT 'SIZE)
-                               0))                           (* Size of the type, in points)
-          (\SMALLPOUT FILE (OR (fetch (CHARLOOKS CLOFFSET) of LOOKS)
-                               0))                           (* Super/subscripting distance)
-          (COND
-             ([AND (fetch (CHARLOOKS CLSTYLE) of LOOKS)
-                   (NOT (ZEROP (fetch (CHARLOOKS CLSTYLE) of LOOKS]
-              (\ARBOUT FILE (fetch (CHARLOOKS CLSTYLE) of LOOKS)))
-             (T (\SMALLPOUT FILE 0)))
-          (COND
-             ((fetch (CHARLOOKS CLUSERINFO) of LOOKS)
-              (\ARBOUT FILE (fetch (CHARLOOKS CLUSERINFO) of LOOKS)))
-             (T (\SMALLPOUT FILE 0)))
-          [\SMALLPOUT FILE (LOGOR (COND
-                                     ((fetch (CHARLOOKS CLLEADER) of LOOKS)
-                                                             (* Dotted-leader; relevant only to 
-                                                           TABs)
-                                      2048)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLINVERTED) of LOOKS)
-                                                             (* Inverse-video)
-                                      1024)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLBOLD) of LOOKS)
-                                      512)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLITAL) of LOOKS)
-                                      256)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLULINE) of LOOKS)
-                                      128)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLOLINE) of LOOKS)
-                                      64)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLSTRIKE) of LOOKS)
-                                      32)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLSMALLCAP) of LOOKS)
-                                      16)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLPROTECTED) of LOOKS)
-                                      8)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLINVISIBLE) of LOOKS)
-                                      NIL 4)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLSELHERE) of LOOKS)
-                                      2)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLCANCOPY) of LOOKS)
-                                      1)
-                                     (T 0]
-
-         (* * Now go fill in the length field at the front of the LOOKS.
-       (ALL looks info should be written out BEFORE this comment.))
-
-          (SETQ LEN (IDIFFERENCE (GETFILEPTR FILE)
-                           FILEPOS))                         (* The length of this set of looks)
-          (SETFILEPTR FILE FILEPOS)                          (* Go write the length field)
-          (\SMALLPOUT FILE LEN)
-          (SETFILEPTR FILE -1)                               (* And back to the end of the file)
-      ])
-)
-(DEFINEQ
-
-(\TEDIT.GET.PARALOOKS.LIST
-  [LAMBDA (FILE TEXTOBJ)                                     (* jds "13-Jun-85 11:14")
-                                                             (* Read the list of CHARLOOKSs from 
-                                                             the file.)
-    (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.PARALOOKS FILE TEXTOBJ])
-
-(\TEDIT.GET.SINGLE.PARALOOKS
-  [LAMBDA (FILE TEXTOBJ)                      (* ; 
-                                                "Edited  2-Jul-93 21:31 by sybalskY:MV:ENVOS")
-                                                             (* ; 
-                         "Read a paragraph format spec from the FILE, and return it for later use.")
-    (PROG ((LOOKS (create FMTSPEC))
-           (FILEPOS (GETFILEPTR FILE))
-           (LOOKSLEN (\SMALLPIN FILE))
-           TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC TABTYPE QUAD)
-          (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* ; 
-                                                  "Left margin for the first line of the paragraph")
-          (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* ; 
-                                                        "Left margin for the rest of the paragraph")
-          (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* ; "Right margin for the paragraph")
-          (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE))
-                                                             (* ; "Leading before the paragraph")
-          (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE))
-                                                             (* ; "Lead after the paragraph")
-          (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE))
-                                                             (* ; "inter-line leading")
-          (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL)))
-                                                             (* ; "Will be tab specs")
-          (SETQ TABFLG (\BIN FILE))
-          (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (SETQ QUAD (\BIN FILE))
-                                                                (1 'LEFT)
-                                                                (2 'RIGHT)
-                                                                (3 'CENTERED)
-                                                                (4 'JUSTIFIED)
-                                                                (SHOULDNT)))
-          (COND
-             ((NOT (ZEROP (LOGAND TABFLG 1)))                (* ; "There are tabs to read")
-              (SETQ DEFAULTTAB (\SMALLPIN FILE))
-              (SETQ TABCOUNT (\BIN FILE))
-              [SETQ TABS (for TAB# from 1 to TABCOUNT
-                            collect (create TAB
-                                               TABX _ (\SMALLPIN FILE)
-                                               TABKIND _ (SELECTQ (SETQ TABTYPE (\BIN FILE))
-                                                             (0 'LEFT)
-                                                             (1 'RIGHT)
-                                                             (2 'CENTERED)
-                                                             (3 'DECIMAL)
-                                                             (4 'DOTTEDLEFT)
-                                                             (5 'DOTTEDRIGHT)
-                                                             (6 'DOTTEDCENTERED)
-                                                             (7 'DOTTEDDECIMAL)
-                                                             (SHOULDNT]
-              (OR (ZEROP DEFAULTTAB)
-                  (RPLACA TABSPEC DEFAULTTAB))
-              (RPLACD TABSPEC TABS)))
-          [COND
-             ((NOT (ZEROP (LOGAND TABFLG 2)))                (* ; 
-                                                 "There are other paragraph parameters to be read.")
-              (replace (FMTSPEC FMTSPECIALX) of LOOKS with (\SMALLPIN FILE))
-                                                             (* ; 
-                                                    "Special X location on page for this paragraph")
-              (replace (FMTSPEC FMTSPECIALY) of LOOKS with (\SMALLPIN FILE))
-              (replace (FMTSPEC FMTUSERINFO) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTPARATYPE) of LOOKS with (\ATMIN FILE))
-              (replace (FMTSPEC FMTPARASUBTYPE) of LOOKS with (\ATMIN FILE))
-              (replace (FMTSPEC FMTSTYLE) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTNEWPAGEAFTER) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTHEADINGKEEP) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTKEEP) of LOOKS with (\ARBIN FILE))
-              [COND
-                 ((ILESSP (GETFILEPTR FILE)
-                         (IPLUS FILEPOS LOOKSLEN))
-                  (replace (FMTSPEC FMTBASETOBASE) of LOOKS with (\ARBIN FILE]
-              [COND
-                 ((ILESSP (GETFILEPTR FILE)
-                         (IPLUS FILEPOS LOOKSLEN))
-                  (replace (FMTSPEC FMTREVISED) of LOOKS with (\ARBIN FILE]
-              [COND
-                 ((ILESSP (GETFILEPTR FILE)
-                         (IPLUS FILEPOS LOOKSLEN))
-                  (replace (FMTSPEC FMTCOLUMN) of LOOKS with (\ARBIN FILE]
-              (COND
-                 ((ILESSP (GETFILEPTR FILE)
-                         (IPLUS FILEPOS LOOKSLEN))
-                  (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE]
-          [COND
-             ((ILESSP (GETFILEPTR FILE)
-                     (IPLUS FILEPOS LOOKSLEN))               (* ; 
-                             "There is more PARALOOKS info in this piece -- we probably lost data.")
-              (TEDIT.PROMPTPRINT TEXTOBJ "WARNING: Newer file version; you lost PARALOOKS info" T)
-              (SETFILEPTR FILE (IPLUS FILEPOS LOOKSLEN]
-          (RETURN LOOKS])
-
-(\TEDIT.PUT.PARALOOKS.LIST
-  [LAMBDA (FILE LOOKSLIST)                                   (* ; "Edited  1-Sep-87 20:34 by jds")
-                                                             (* ; 
-                                                     "Write the list of FMTSPECs into the font file.")
-
-    (PROG ((LOOKSHASH (HASHARRAY 50)))
-          (\DWOUT FILE 0)
-          (\SMALLPOUT FILE \PieceDescriptorPARALOOKSLIST)
-          (\SMALLPOUT FILE (FLENGTH LOOKSLIST))
-          (for I from 1 as LOOKS in LOOKSLIST do (\TEDIT.PUT.SINGLE.PARALOOKS FILE LOOKS) 
-                                                             (* ; "Write out the description")
-
-                                                 (PUTHASH LOOKS I LOOKSHASH) 
-                                                             (* ; 
-                                        "And save it in the hash table so people can find its index.")
-)
-          (RETURN LOOKSHASH])
-
-(\TEDIT.PUT.SINGLE.PARALOOKS
-  [LAMBDA (FILE LOOKS)                        (* ; 
-                                                "Edited  2-Jul-93 21:30 by sybalskY:MV:ENVOS")
-
-    (* ;; "Put a description of LOOKS into FILE.")
-
-    (PROG ((FILEPOS (GETFILEPTR FILE))
-           DEFAULTTAB TABSPECS OUTPUTFORMAT LEN)
-          (\SMALLPOUT FILE 0)                                (* ; 
-                                                       "Reserve space for the length of this looks")
-          (\SMALLPOUT FILE (fetch (FMTSPEC 1STLEFTMAR) of LOOKS))
-                                                             (* ; 
-                                                  "Left margin for the first line of the paragraph")
-          (\SMALLPOUT FILE (fetch (FMTSPEC LEFTMAR) of LOOKS))
-                                                             (* ; 
-                                                        "Left margin for the rest of the paragraph")
-          (\SMALLPOUT FILE (fetch (FMTSPEC RIGHTMAR) of LOOKS))
-                                                             (* ; "Right margin for the paragraph")
-          (\SMALLPOUT FILE (fetch (FMTSPEC LEADBEFORE) of LOOKS))
-                                                             (* ; "Leading before the paragraph")
-          (\SMALLPOUT FILE (fetch (FMTSPEC LEADAFTER) of LOOKS))
-                                                             (* ; "Lead after the paragraph")
-          (\SMALLPOUT FILE (fetch (FMTSPEC LINELEAD) of LOOKS))
-                                                             (* ; "inter-line leading")
-          (SETQ DEFAULTTAB (CAR (fetch (FMTSPEC TABSPEC) of LOOKS)))
-          (SETQ TABSPECS (CDR (fetch (FMTSPEC TABSPEC) of LOOKS)))
-          (COND
-             ((AND (fetch (FMTSPEC TABSPEC) of LOOKS)
-                   (OR DEFAULTTAB TABSPECS))                 (* ; 
-                           "There are tab specs to save, or there is a default tab setting to save")
-              (\BOUT FILE 3))
-             (T                                              (* ; 
-                                                        "There are no tab looks.  Just let him go.")
-                (\BOUT FILE 2)))
-          (\BOUT FILE (SELECTQ (fetch (FMTSPEC QUAD) of LOOKS)
-                          (LEFT 1)
-                          (RIGHT 2)
-                          ((CENTER CENTERED) 
-                               3)
-                          ((JUST JUSTIFIED) 
-                               4)
-                          (SHOULDNT)))
-          [COND
-             ((OR TABSPECS DEFAULTTAB)                       (* ; "There are tab specs to save.")
-              (COND
-                 (DEFAULTTAB (\SMALLPOUT FILE DEFAULTTAB))
-                 (T (\SMALLPOUT FILE 0)))
-              (COND
-                 ((IGREATERP (LENGTH TABSPECS)
-                         255)
-                  (SHOULDNT "Paragraph has more than 255 TABs set--can't be saved.")))
-              (\BOUT FILE (LENGTH TABSPECS))
-              (COND
-                 (TABSPECS                                   (* ; "# of tab settings <256!")
-                        (for TAB in TABSPECS do (\SMALLPOUT FILE (fetch TABX
-                                                                                of TAB)) 
-                                                             (* ; "And setting.")
-                                                           (\BOUT FILE (SELECTQ (fetch TABKIND
-                                                                                   of TAB)
-                                                                           (LEFT 0)
-                                                                           (RIGHT 1)
-                                                                           (CENTERED 2)
-                                                                           (DECIMAL 3)
-                                                                           (DOTTEDLEFT 4)
-                                                                           (DOTTEDRIGHT 5)
-                                                                           (DOTTEDCENTERED 
-                                                                                6)
-                                                                           (DOTTEDDECIMAL 7)
-                                                                           (SHOULDNT))) 
-                                                             (* ; "Tab type")]
-          (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALX) of LOOKS)
-                               0))
-          (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALY) of LOOKS)
-                               0))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTUSERINFO) of LOOKS))
-          (\ATMOUT FILE (fetch (FMTSPEC FMTPARATYPE) of LOOKS))
-          (\ATMOUT FILE (fetch (FMTSPEC FMTPARASUBTYPE) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTSTYLE) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTCHARSTYLES) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEAFTER) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTHEADINGKEEP) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTKEEP) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTBASETOBASE) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTREVISED) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTCOLUMN) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTCHARSTYLES) of LOOKS))
-
-(* ;;; "Now go fill in the length field at the front of the LOOKS.  (ALL looks info should be written out BEFORE this comment.)")
-
-          (SETQ LEN (IDIFFERENCE (GETFILEPTR FILE)
-                           FILEPOS))                         (* ; "The length of this set of looks")
-          (SETFILEPTR FILE FILEPOS)                          (* ; "Go write the length field")
-          (\SMALLPOUT FILE LEN)
-          (SETFILEPTR FILE -1)                               (* ; "And back to the end of the file")
-      ])
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS TEDIT.INPUT.FORMATS *TEDIT-FILE-READTABLE*)
-)
-
-(RPAQ? TEDIT.INPUT.FORMATS NIL)
-
-(RPAQ? *TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE))
-
-
-
-(* ;; "For converting old incoming format.  Cutover 5/22/85 to permit looks changes in the future.")
-
-(DEFINEQ
-
-(TEDIT.BUILD.PCTB2
-  [LAMBDA (TEXT TEXTOBJ PCCOUNT START END DEFAULTLOOKS)  (* ; "Edited  4-May-93 16:27 by jds")
-
-    (* ;; "READ OBSOLETE FORMATS OF TEDIT FILE")
-
-    (* ;; "START = 1st char of file to read from, if specified")
-
-    (* ;; "END = use this as eofptr of file.  For use in reading files within files.")
-
-    (PROG (SEL LINES PCTB PC OLDPC TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE
-               CACHE? TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP EXISTINGCHARLOOKS EXLOOK 
-               EXISTINGFMTSPECS (CURFILECH# (OR START 0))
-               (CURCH# 1)
-               (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)))
-               LOOKSHASH PARAHASH)                           (* ; 
-            "Get the number of pieces needed (if AN formatted file), otherwise PCCOUNT will be NIL")
-          [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND
-                                                         (TEXTOBJ (fetch (TEXTOBJ FMTSPEC)
-                                                                     of TEXTOBJ))
-                                                         (T (create FMTSPEC using 
-                                                                                TEDIT.DEFAULT.FMTSPEC
-                                                                   ]
-          (SETQ DEFAULTLOOKS (OR DEFAULTLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT)))
-          (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with NIL))
-                                                             (* ; 
-                                                           "Start by assuming no page formatting")
-          (SETQ PCTB (\MAKEPCTB NIL PCCOUNT))
-          (replace (TEXTOBJ PCTB) of TEXTOBJ with PCTB)
-          (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT))
-                                  8))
-          (SETQ PIECEINFOCH# (\DWIN TEXT))
-          (SETFILEPTR TEXT PIECEINFOCH#)
-          (bind (OLDPC _ NIL)
-                 (OLDPARALOOKS _ DEFAULTPARALOOKS) for I from 1 to PCCOUNT as PCN
-             from \FirstPieceOffset by \EltsPerPiece
-             do (SETQ PC NIL)                            (* ; 
-                      "This loop may not really read a piece, so we have to distinguish that case.")
-                   (SETQ PCLEN (\DWIN TEXT))
-                   (SETQ TYPECODE (\SMALLPIN TEXT))          (* ; "What kind of piece is it?")
-                   (SELECTC TYPECODE
-                       (\PieceDescriptorPAGEFRAME            (* ; 
-                                                           "This is page layout info for the file")
-                            (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ
-                                            with (TEDIT.GET.PAGEFRAMES TEXT)))
-                            (add PCN (IMINUS \EltsPerPiece))
-                                                             (* ; 
-                              "This didn't create a piece -- don't count it in the PCTB placement.")
-                            )
-                       (\PieceDescriptorCHARLOOKSLIST        (* ; 
-                                            "This is the list of CHARLOOKSs used in this document.")
-                            (replace (TEXTOBJ TXTCHARLOOKSLIST) of TEXTOBJ
-                               with (\TEDIT.GET.CHARLOOKS.LIST2 TEXT))
-                                                             (* ; 
-                                                    "Read the list of looks used in this document.")
-                            [SETQ LOOKSHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTCHARLOOKSLIST)
-                                                               of TEXTOBJ]
-                                                             (* ; 
-                                       "Build an array of the looks, so the reader can index them.")
-                            (for I from 1 as LOOKS in (fetch (TEXTOBJ 
-                                                                                     TXTCHARLOOKSLIST
-                                                                                        )
-                                                                         of TEXTOBJ)
-                               do (SETA LOOKSHASH I LOOKS))
-                            (add PCN (IMINUS \EltsPerPiece))
-                                                             (* ; 
-                              "This didn't create a piece -- don't count it in the PCTB placement.")
-                            (add I -1))
-                       (\PieceDescriptorPARALOOKSLIST        (* ; 
-                                            "This is the list of PARALOOKSs used in this document.")
-                            (replace (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ
-                               with (\TEDIT.GET.PARALOOKS.LIST2 TEXT))
-                                                             (* ; 
-                                                    "Read the list of looks used in this document.")
-                            [SETQ PARAHASH (ARRAY (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST)
-                                                              of TEXTOBJ]
-                                                             (* ; 
-                                       "Build an array of the looks, so the reader can index them.")
-                            (for I from 1 as LOOKS in (fetch (TEXTOBJ 
-                                                                                     TXTPARALOOKSLIST
-                                                                                        )
-                                                                         of TEXTOBJ)
-                               do (SETA PARAHASH I LOOKS))
-                            (add PCN (IMINUS \EltsPerPiece))
-                                                             (* ; 
-                              "This didn't create a piece -- don't count it in the PCTB placement.")
-                            (add I -1))
-                       (\PieceDescriptorPARA                 (* ; 
-                                                           "Reading a new set of paragraph looks.")
-                            (AND OLDPC (replace (PIECE PPARALAST) of OLDPC with T))
-                                                             (* ; 
-                                                         "Mark the end of the preceding paragraph.")
-                            (SETQ OLDPARALOOKS (\TEDIT.GET.PARALOOKS TEXT PARAHASH))
-                                                             (* ; 
-                                               "Get the new set of looks, for use by later pieces.")
-                            (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) of TEXTOBJ
-                                            with T))     (* ; 
-                                        "Mark the document as containing paragraph formatting info")
-                            (add PCN (IMINUS \EltsPerPiece))
-                                                             (* ; 
-                              "This didn't create a piece -- don't count it in the PCTB placement.")
-                            )
-                       (\PieceDescriptorLOOKS                (* ; 
-                                "New character looks.  Build a piece to describe those characters.")
-                            (SETQ PC
-                             (create PIECE
-                                    PFILE _ TEXT
-                                    PFPOS _ CURFILECH#
-                                    PLEN _ PCLEN
-                                    PREVPIECE _ OLDPC
-                                    PPARALOOKS _ OLDPARALOOKS))
-                                                             (* ; "Build the new piece")
-                            (\TEDIT.GET.CHARLOOKS PC TEXT LOOKSHASH OLDPC)
-                                                             (* ; 
-                                                           "Read the character looks for this guy.")
-                            (COND
-                               [OLDPC                        (* ; 
-                                            "If there's a prior piece, hook this one on the chain.")
-                                      (replace (PIECE NEXTPIECE) of OLDPC with PC)
-                                      (COND
-                                         ((AND (fetch (PIECE PFATP) of PC)
-                                               (NOT (fetch (PIECE PFATP) of OLDPC)))
-                                                             (* ; 
-                                    "Switching from not-fat to fat.  Add 3 bytes for the 255-255-0")
-                                          (add (fetch (PIECE PFPOS) of PC)
-                                                 3)
-                                          (add CURFILECH# -3))
-                                         ((AND (fetch (PIECE PFATP) of OLDPC)
-                                               (NOT (fetch (PIECE PFATP) of PC)))
-                                                             (* ; 
-                                        "Switching from fat to not-fat.  Add 3 bytes for the 255-0")
-                                          (add (fetch (PIECE PFPOS) of PC)
-                                                 2]
-                               ((fetch (PIECE PFATP) of PC)
-                                                             (* ; 
-                                    "Switching from not-fat to fat.  Add 3 bytes for the 255-255-0")
-                                (add (fetch (PIECE PFPOS) of PC)
-                                       3)
-                                (add CURFILECH# -3)))
-                            (add CURFILECH# PCLEN)       (* ; 
-                                                           "And note the passing of characters.")
-                            )
-                       (\PieceDescriptorOBJECT               (* ; 
- "It describes an object.  Read that, and perhaps some description of the charlooks to go with it.")
-                            (SETQ PC
-                             (create PIECE
-                                    PFILE _ TEXT
-                                    PFPOS _ CURFILECH#
-                                    PLEN _ PCLEN
-                                    PREVPIECE _ OLDPC
-                                    PPARALOOKS _ OLDPARALOOKS))
-                            (COND
-                               (OLDPC                        (* ; 
-                                            "If there's a prior piece, hook this one on the chain.")
-                                      (replace (PIECE NEXTPIECE) of OLDPC with PC)))
-                            (TEDIT.GET.OBJECT TEXTSTREAM PC TEXT CURFILECH#)
-                            (add CURFILECH# (fetch (PIECE PLEN) of PC))
-                            [COND
-                               ((NOT (ZEROP (\BIN TEXT)))    (* ; 
-                                    "There are new character looks for this object.  Read them in.")
-                                (replace (PIECE PLOOKS) of PC with (
-                                                                       \TEDIT.GET.SINGLE.CHARLOOKS2
-                                                                                TEXT)))
-                               (T                            (* ; 
-                                                  "No new looks;  steal them from the prior piece.")
-                                  (replace (PIECE PLOOKS) of PC
-                                     with (OR (AND OLDPC (fetch (PIECE PLOOKS) of OLDPC))
-                                                  DEFAULTLOOKS]
-                            (replace (PIECE PLEN) of PC with 1)
-                                                             (* ; 
-                                                       "OBJECTs are officially one character long.")
-                            )
-                       (SHOULDNT "Impossible piece-type code in BUILD.PCTB"))
-                   (COND
-                      (PC                                    (* ; 
-                                                     "If we created a piece, save it in the table.")
-                          (\INSERTPIECE PC 'LASTPIECE TEXTOBJ)
-                          (add CURCH# (fetch (PIECE PLEN) of PC))
-                          (SETQ OLDPC PC))) finally      (* INSERT-BRT (CREATEPCNODE CURCH#
-                                                           (QUOTE LASTPIECE)) PCTB))
-          (RETURN PCTB])
-
-(\TEDIT.GET.CHARLOOKS.LIST2
-  [LAMBDA (FILE)                                             (* jds "22-May-85 14:28")
-                                                             (* Read the list of CHARLOOKSs from 
-                                                             the file.)
-    (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.CHARLOOKS2 FILE])
-
-(\TEDIT.GET.SINGLE.CHARLOOKS2
-  [LAMBDA (FILE)                                         (* ; "Edited 30-May-91 20:26 by jds")
-                                                             (* Read a set of CHARLOOKS from FILE)
-    (PROG* ((LOOKS (create CHARLOOKS))
-            FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR)
-           (SETQ NAME (\ARBIN FILE))                     (* The font name)
-           (SETQ SIZE (\SMALLPIN FILE))                      (* Size of the type, in points)
-           (SETQ SUPER (\SMALLPIN FILE))                     (* Superscripting distance)
-           (replace (CHARLOOKS CLSTYLE) of LOOKS with (OR (\ARBIN FILE)
-                                                                      0))
-           (replace (CHARLOOKS CLUSERINFO) of LOOKS with (\ARBIN FILE))
-           (SETQ PROPS (\SMALLPIN FILE))
-           (with CHARLOOKS LOOKS [SETQ CLLEADER (NOT (ZEROP (LOGAND 2048 PROPS]
-                  [SETQ CLINVERTED (NOT (ZEROP (LOGAND 1024 PROPS]
-                  [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS]
-                  [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS]
-                  [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS]
-                  [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS]
-                  [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS]
-                  [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS]
-                  [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS]
-                  [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS]
-                  [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS]
-                  [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS]
-                  (SETQ CLSIZE SIZE)
-                  (SETQ CLOFFSET SUPER))
-           [replace (CHARLOOKS CLFONT) of LOOKS
-              with (COND
-                          ((LISTP NAME)                      (* This was a font class.
-                                                           Restore it.)
-                           (FONTCLASS (pop NAME)
-                                  NAME))
-                          ((AND NAME (NOT (ZEROP SIZE)))
-                           (FONTCREATE NAME SIZE (COND
-                                                    ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS)
-                                                          (fetch (CHARLOOKS CLITAL) of LOOKS)
-                                                          )
-                                                     'BOLDITALIC)
-                                                    ((fetch (CHARLOOKS CLBOLD) of LOOKS)
-                                                     'BOLD)
-                                                    ((fetch (CHARLOOKS CLITAL) of LOOKS)
-                                                     'ITALIC]
-           (RETURN LOOKS])
-
-(\TEDIT.PUT.SINGLE.PARALOOKS2
-  [LAMBDA (FILE LOOKS)                                   (* ; "Edited 30-May-91 20:33 by jds")
-                                                             (* Put a description of LOOKS into 
-                                                           FILE. LOOKS apply to characters CH1 
-                                                           thru CHLIM-1)
-    (PROG (DEFAULTTAB TABSPECS OUTPUTFORMAT LEN)
-          (\SMALLPOUT FILE (fetch (FMTSPEC 1STLEFTMAR) of LOOKS))
-                                                             (* Left margin for the first line of 
-                                                           the paragraph)
-          (\SMALLPOUT FILE (fetch (FMTSPEC LEFTMAR) of LOOKS))
-                                                             (* Left margin for the rest of the 
-                                                           paragraph)
-          (\SMALLPOUT FILE (fetch (FMTSPEC RIGHTMAR) of LOOKS))
-                                                             (* Right margin for the paragraph)
-          (\SMALLPOUT FILE (fetch (FMTSPEC LEADBEFORE) of LOOKS))
-                                                             (* Leading before the paragraph)
-          (\SMALLPOUT FILE (fetch (FMTSPEC LEADAFTER) of LOOKS))
-                                                             (* Lead after the paragraph)
-          (\SMALLPOUT FILE (fetch (FMTSPEC LINELEAD) of LOOKS))
-                                                             (* inter-line leading)
-          (SETQ DEFAULTTAB (CAR (fetch (FMTSPEC TABSPEC) of LOOKS)))
-          (SETQ TABSPECS (CDR (fetch (FMTSPEC TABSPEC) of LOOKS)))
-          (COND
-             ((AND (fetch (FMTSPEC TABSPEC) of LOOKS)
-                   (OR DEFAULTTAB TABSPECS))
-
-         (* There are tab specs to save, or there is a default tab setting to save)
-
-              (\BOUT FILE 3))
-             (T                                              (* There are no tab looks.
-                                                           Just let him go.)
-                (\BOUT FILE 2)))
-          (\BOUT FILE (SELECTQ (fetch (FMTSPEC QUAD) of LOOKS)
-                          (LEFT 1)
-                          (RIGHT 2)
-                          ((CENTER CENTERED) 
-                               3)
-                          ((JUST JUSTIFIED) 
-                               4)
-                          (SHOULDNT)))
-          [COND
-             ((OR TABSPECS DEFAULTTAB)                       (* There are tab specs to save.)
-              (COND
-                 (DEFAULTTAB (\SMALLPOUT FILE DEFAULTTAB))
-                 (T (\SMALLPOUT FILE 0)))
-              (\BOUT FILE (LENGTH TABSPECS))
-              (COND
-                 (TABSPECS                                   (* %# of tab settings <256!)
-                        (for TAB in TABSPECS do (\SMALLPOUT FILE (fetch TABX
-                                                                                of TAB)) 
-                                                             (* And setting.)
-                                                           (\BOUT FILE (SELECTQ (fetch TABKIND
-                                                                                   of TAB)
-                                                                           (LEFT 0)
-                                                                           (RIGHT 1)
-                                                                           (CENTERED 2)
-                                                                           (DECIMAL 3)
-                                                                           (SHOULDNT))) 
-                                                             (* Tab type)]
-          (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALX) of LOOKS)
-                               0))
-          (\SMALLPOUT FILE (OR (fetch (FMTSPEC FMTSPECIALY) of LOOKS)
-                               0))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTUSERINFO) of LOOKS))
-          (\ATMOUT FILE (fetch (FMTSPEC FMTPARATYPE) of LOOKS))
-          (\ATMOUT FILE (fetch (FMTSPEC FMTPARASUBTYPE) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTSTYLE) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTCHARSTYLES) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS))
-          (\ARBOUT FILE (fetch (FMTSPEC FMTNEWPAGEAFTER) of LOOKS])
-
-(\TEDIT.PUT.SINGLE.CHARLOOKS2
-  [LAMBDA (FILE LOOKS)                                   (* ; "Edited 30-May-91 20:26 by jds")
-                                                             (* Put out a single CHARLOOKS 
-                                                           description.)
-    (PROG ((FONT (fetch (CHARLOOKS CLFONT) of LOOKS))
-           STR LEN)
-          [COND
-             ((type? FONTCLASS FONT)                     (* For font classes, we need to save 
-                                                           a list of device-FD sets)
-              (\ARBOUT FILE (FONTCLASSUNPARSE FONT)))
-             (T                                              (* For FONTDESCRIPTORs, do it the 
-                                                           easy way)
-                (\ATMOUT FILE (FONTPROP FONT 'FAMILY]    (* The font family)
-          (\SMALLPOUT FILE (OR (FONTPROP FONT 'SIZE)
-                               0))                           (* Size of the type, in points)
-          (\SMALLPOUT FILE (OR (fetch (CHARLOOKS CLOFFSET) of LOOKS)
-                               0))                           (* Super/subscripting distance)
-          (COND
-             ([AND (fetch (CHARLOOKS CLSTYLE) of LOOKS)
-                   (NOT (ZEROP (fetch (CHARLOOKS CLSTYLE) of LOOKS]
-              (\ARBOUT FILE (fetch (CHARLOOKS CLSTYLE) of LOOKS)))
-             (T (\SMALLPOUT FILE 0)))
-          (COND
-             ((fetch (CHARLOOKS CLUSERINFO) of LOOKS)
-              (\ARBOUT FILE (fetch (CHARLOOKS CLUSERINFO) of LOOKS)))
-             (T (\SMALLPOUT FILE 0)))
-          (\SMALLPOUT FILE (LOGOR (COND
-                                     ((fetch (CHARLOOKS CLLEADER) of LOOKS)
-                                                             (* Dotted-leader; relevant only to 
-                                                           TABs)
-                                      2048)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLINVERTED) of LOOKS)
-                                                             (* Inverse-video)
-                                      1024)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLBOLD) of LOOKS)
-                                      512)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLITAL) of LOOKS)
-                                      256)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLULINE) of LOOKS)
-                                      128)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLOLINE) of LOOKS)
-                                      64)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLSTRIKE) of LOOKS)
-                                      32)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLSMALLCAP) of LOOKS)
-                                      16)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLPROTECTED) of LOOKS)
-                                      8)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLINVISIBLE) of LOOKS)
-                                      NIL 4)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLSELHERE) of LOOKS)
-                                      2)
-                                     (T 0))
-                                  (COND
-                                     ((fetch (CHARLOOKS CLCANCOPY) of LOOKS)
-                                      1)
-                                     (T 0])
-
-(\TEDIT.GET.PARALOOKS.LIST2
-  [LAMBDA (FILE)                                             (* jds "22-May-85 14:28")
-                                                             (* Read the list of CHARLOOKSs from 
-                                                             the file.)
-    (for I from 1 to (\SMALLPIN FILE) collect (\TEDIT.GET.SINGLE.PARALOOKS2 FILE])
-
-(\TEDIT.GET.SINGLE.PARALOOKS2
-  [LAMBDA (FILE)                                         (* ; "Edited 30-May-91 20:33 by jds")
-                                                             (* Read a paragraph format spec from 
-                                                           the FILE, and return it for later 
-                                                           use.)
-    (PROG ((LOOKS (create FMTSPEC))
-           TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC)
-          (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Left margin for the first line of 
-                                                           the paragraph)
-          (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Left margin for the rest of the 
-                                                           paragraph)
-          (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Right margin for the paragraph)
-          (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Leading before the paragraph)
-          (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Lead after the paragraph)
-          (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE))
-                                                             (* inter-line leading)
-          (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL)))
-                                                             (* Will be tab specs)
-          (SETQ TABFLG (\BIN FILE))
-          (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (\BIN FILE)
-                                                                (1 'LEFT)
-                                                                (2 'RIGHT)
-                                                                (3 'CENTERED)
-                                                                (4 'JUSTIFIED)
-                                                                (SHOULDNT)))
-          (COND
-             ((NOT (ZEROP (LOGAND TABFLG 1)))                (* There are tabs to read)
-              (SETQ DEFAULTTAB (\SMALLPIN FILE))
-              (SETQ TABCOUNT (\BIN FILE))
-              [SETQ TABS (for TAB# from 1 to TABCOUNT
-                            collect (create TAB
-                                               TABX _ (\SMALLPIN FILE)
-                                               TABKIND _ (SELECTQ (\BIN FILE)
-                                                             (0 'LEFT)
-                                                             (1 'RIGHT)
-                                                             (2 'CENTERED)
-                                                             (3 'DECIMAL)
-                                                             (SHOULDNT]
-              (OR (ZEROP DEFAULTTAB)
-                  (RPLACA TABSPEC DEFAULTTAB))
-              (RPLACD TABSPEC TABS)))
-          [COND
-             ((NOT (ZEROP (LOGAND TABFLG 2)))                (* There are other paragraph 
-                                                           parameters to be read.)
-              (replace (FMTSPEC FMTSPECIALX) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Special X location on page for 
-                                                           this paragraph)
-              (replace (FMTSPEC FMTSPECIALY) of LOOKS with (\SMALLPIN FILE))
-              (replace (FMTSPEC FMTUSERINFO) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTPARATYPE) of LOOKS with (\ATMIN FILE))
-              (replace (FMTSPEC FMTPARASUBTYPE) of LOOKS with (\ATMIN FILE))
-              (replace (FMTSPEC FMTSTYLE) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTNEWPAGEAFTER) of LOOKS with (\ARBIN FILE]
-          (RETURN LOOKS])
-
-(TEDIT.PUT.PCTB2
-  [LAMBDA (TEXTOBJ OFILE UNFORMATTED? SEPARATEFORMAT)    (* ; "Edited 30-May-91 20:24 by jds")
-
-    (* ;; "Put a representation of the piece table onto OFILE, preserving font changes and paragraph looks.  UNFORMATTED?  means write no font or formatting info.")
-
-    (PROG (OCURSOR CH PC PFILE PSTR POBJ OFILELEN OLDLOOKS (OLDPARALOOKS (fetch (TEXTOBJ FMTSPEC)
-                                                                            of TEXTOBJ))
-                 OLDCH# CURCH# PREVPC (FONTFILE NIL)
-                 (PCCOUNT 0)
-                 TRUEFILE CHARLOOKSLST PARALOOKSLST (TEDIT.PUT.FINISHEDFORMS NIL)
-                 (EDITSTENTATIVE (TEXTPROP TEXTOBJ 'TEDIT.TENTATIVE))
-                 (PARALOOKSSEEN NIL)
-                 (FORMATTINGLEVEL (TEDIT.FORMATTEDFILEP TEXTOBJ))
-                 (CACHE (TEXTPROP TEXTOBJ 'CACHE))
-                 CH#S PREVFATP PREVPREVPC LOOKSHASH PARAHASH)
-          (SETQ PC (\EDITELT (fetch (TEXTOBJ PCTB) of TEXTOBJ)
-                          (ADD1 \FirstPieceOffset)))         (* ; "First piece in the document")
-          (SETQ OLDLOOKS (OR (AND (type? PIECE PC)
-                                  (fetch (PIECE PLOOKS) of PC))
-                             (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ)
-                             TEDIT.DEFAULT.CHARLOOKS))       (* ; "Starting looks")
-          (COND
-             ((NEQ (fetch (STREAM EOLCONVENTION) of OFILE)
-                   CR.EOLC)                                  (* ; 
-                                          "This file is on a non-CR host;  make a note to cache it")
-              (SETQ TRUEFILE OFILE)                          (* ; 
-                                                          "Remember where the file should wind up.")
-              (SETQ OFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW))(* ; 
-                                                           "And open a temp file to write it to.")
-              ))
-          [SETQ CURCH# (SETQ OLDCH# (ADD1 (GETFILEPTR OFILE]
-          (COND
-             ((fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ)
-                                                             (* ; 
-                                                     "There is layout info for this file.  Save it")
-              (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW))
-              (TEDIT.PUT.PAGEFRAMES FONTFILE (fetch (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ))
-              (add PCCOUNT 1)))
-          (\TEDIT.FLUSH.UNUSED.LOOKS TEXTOBJ PC)             (* ; 
-                        "Run thru the lists of char & para looks and remove any that aren't in use")
-          (COND
-             ([AND (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ)
-                   (OR (IGREATERP (FLENGTH (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ))
-                              1)
-                       (NOT (EQFMTSPEC (CAR (fetch (TEXTOBJ TXTPARALOOKSLIST) of TEXTOBJ))
-                                   TEDIT.DEFAULT.FMTSPEC]
-
-              (* ;; "There are paragraph looks in this document that don't match the default -- save the list of them for later retrieval.")
-
-              [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW]
-                                                             (* ; 
-                                                "Create the font-info file if it doesn't exist yet")
-              (SETQ PARAHASH (\TEDIT.PUT.PARALOOKS.LIST2 FONTFILE (fetch (TEXTOBJ 
-                                                                                     TXTPARALOOKSLIST
-                                                                                        )
-                                                                         of TEXTOBJ)))
-              (SETQ PARALOOKSSEEN T)))
-          [COND
-             ((OR PARALOOKSSEEN FORMATTINGLEVEL)
-
-              (* ;; "There are character looks in this document that don't match the default (or paragraph formatting, which forces looks to be saved) -- save the list for later retrieval.")
-
-              [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH 'NEW]
-              (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST2 FONTFILE (fetch (TEXTOBJ 
-                                                                                     TXTCHARLOOKSLIST
-                                                                                         )
-                                                                          of TEXTOBJ]
-          [while PC do (COND
-                                  ([AND (NOT (ZEROP (fetch (PIECE PLEN) of PC)))
-                                        (OR (NOT PREVPC)
-                                            (fetch (PIECE PPARALAST) of PREVPC))
-                                        (OR PARALOOKSSEEN (NOT (EQFMTSPEC (fetch (PIECE 
-                                                                                           PPARALOOKS
-                                                                                            )
-                                                                             of PC)
-                                                                      (fetch (TEXTOBJ FMTSPEC)
-                                                                         of TEXTOBJ]
-                                                             (* ; 
-                                     "The last piece ended a paragraph, so send out new para looks")
-                                   [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH
-                                                                      'NEW]
-                                                             (* ; 
-                                      "Create the formatting-info file, if it didn't exist before.")
-                                   (COND
-                                      ((NEQ CURCH# OLDCH#)   (* ; 
-            "There were prior characters that hadn't been described in a piece yet.  Describe them")
-                                       [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST
-                                                                      FONTFILE
-                                                                      (fetch (TEXTOBJ 
-                                                                                     TXTCHARLOOKSLIST
-                                                                                        )
-                                                                         of TEXTOBJ]
-                                       (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC 
-                                              EDITSTENTATIVE LOOKSHASH PREVFATP)
-                                       (add PCCOUNT 1)
-                                       (SETQ OLDCH# CURCH#)  (* ; 
-                                "And now we've described all the characters up to the current one.")
-                                       ))
-                                   (\TEDIT.PUT.PARALOOKS FONTFILE PC PARAHASH)
-                                   (SETQ PARALOOKSSEEN T)    (* ; 
-           "Remember that we've seen a foreign paralooks, and must henceforth note para boundaries")
-                                   (add PCCOUNT 1)))
-                              (COND
-                                 [(fetch (PIECE POBJ) of PC)
-                                                             (* ; 
-                                                           "It's an object -- go use its PUTFN")
-                                  [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE} 'BOTH
-                                                                     'NEW]
-                                                             (* ; 
-                                                           "Create the font-info file, if need be.")
-                                  (COND
-                                     ((AND (NEQ CURCH# OLDCH#)
-                                           PREVPC)           (* ; 
-            "There were prior characters that hadn't been described in a piece yet.  Describe them")
-                                      [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST
-                                                                     FONTFILE
-                                                                     (fetch (TEXTOBJ 
-                                                                                     TXTCHARLOOKSLIST
-                                                                                       ) of
-                                                                                         TEXTOBJ]
-                                      (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC 
-                                             EDITSTENTATIVE LOOKSHASH PREVFATP)
-                                      (add PCCOUNT 1)
-                                      (SETQ OLDCH# CURCH#)   (* ; 
-                                "And now we've described all the characters up to the current one.")
-                                      ))                     (* ; 
-                                          "If the prior thing was text, send along its descriptor.")
-                                  (add CURCH# (TEDIT.PUT.OBJECT PC OFILE FONTFILE CURCH#))
-                                                             (* ; "Send out the object")
-                                  (add PCCOUNT 1)
-                                  (SETQ OLDCH# CURCH#)
-                                  (COND
-                                     ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS)
-                                                                     of PC)))
-                                          (NEQ (fetch (PIECE PFATP) of PC)
-                                               (AND PREVPC (fetch (PIECE PFATP) of PREVPC)))
-                                          [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW)
-                                                                      of PC)
-                                                                   (AND PREVPC (fetch
-                                                                                (PIECE PNEW)
-                                                                                  of PREVPC]
-                                          (AND (OR (NOT PREVPC)
-                                                   (fetch (PIECE PPARALAST) of PREVPC))
-                                               (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS)
-                                                                  of PC)
-                                                           (fetch (TEXTOBJ FMTSPEC) of 
-                                                                                              TEXTOBJ
-                                                                  ]
-                                                             (* ; 
-                                                        "The OBJECT has different ooks from before")
-                                      (\BOUT FONTFILE 1)
-                                      (\TEDIT.PUT.SINGLE.CHARLOOKS FONTFILE (fetch
-                                                                                 (PIECE PLOOKS)
-                                                                                   of PC))
-                                      (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC)))
-                                     (T                      (* ; 
-                                   "No differences.  Don't write any charlooks, and mark that fact")
-                                        (\BOUT FONTFILE 0)   (* ; 
-                              "MAKE BLOODY SURE THAT THE NEXT RUN OF CHARACTERS GETS ITS OWN LOOKS")
-                                        ]
-                                 (T                          (* ; "It's not an object.")
-                                    [COND
-                                       ([OR (NOT (EQCLOOKS OLDLOOKS (fetch (PIECE PLOOKS)
-                                                                       of PC)))
-                                            (NEQ (fetch (PIECE PFATP) of PC)
-                                                 (AND PREVPC (fetch (PIECE PFATP) of PREVPC))
-                                                 )
-                                            [AND EDITSTENTATIVE (NEQ (fetch (PIECE PNEW)
-                                                                        of PC)
-                                                                     (AND PREVPC (fetch
-                                                                                  (PIECE PNEW)
-                                                                                    of PREVPC]
-                                            (AND (OR (NOT PREVPC)
-                                                     (fetch (PIECE PPARALAST) of PREVPC))
-                                                 (NOT (EQFMTSPEC (fetch (PIECE PPARALOOKS)
-                                                                    of PC)
-                                                             (fetch (TEXTOBJ FMTSPEC)
-                                                                of TEXTOBJ]
-                                                             (* ; "We have a piece with new looks.")
-                                        [OR FONTFILE (SETQ FONTFILE (OPENFILE '{NODIRCORE}
-                                                                           'BOTH
-                                                                           'NEW]
-                                        (COND
-                                           ((NOT (IEQP OLDCH# CURCH#))
-                                                             (* ; 
-               "If there were looks past, and if the run was not empty, save a piece for its looks")
-                                            [OR LOOKSHASH (SETQ LOOKSHASH (
-                                                                         \TEDIT.PUT.CHARLOOKS.LIST
-                                                                           FONTFILE
-                                                                           (fetch (TEXTOBJ 
-                                                                                     TXTCHARLOOKSLIST
-                                                                                             )
-                                                                              of TEXTOBJ]
-                                            (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS 
-                                                   PREVPC EDITSTENTATIVE LOOKSHASH PREVFATP)
-                                            (add PCCOUNT 1)))
-                                        (SETQ OLDLOOKS (fetch (PIECE PLOOKS) of PC))
-                                        (SETQ OLDCH# CURCH#)
-                                        (COND
-                                           [PREVFATP (COND
-                                                        ((fetch (PIECE PFATP) of PC))
-                                                        (T   (* ; "Switching from FAT to thin")
-                                                           (BOUT OFILE 255)
-                                                           (BOUT OFILE 0)
-                                                           (add CURCH# 2]
-                                           ((fetch (PIECE PFATP) of PC)
-                                                             (* ; "Switching from thin to fat")
-                                            (BOUT OFILE 255)
-                                            (BOUT OFILE 255)
-                                            (BOUT OFILE 0)
-                                            (add CURCH# 3)))
-                                        (SETQ PREVFATP (fetch (PIECE PFATP) of PC]
-                                                             (* ; 
-                                               "Now dump out the non-object contents of the piece.")
-                                    [COND
-                                       [(SETQ PFILE (fetch (PIECE PFILE) of PC))
-                                                             (* ; "It's on a file.  Copy it.")
-                                        [OR (OPENP PFILE)
-                                            (replace (PIECE PFILE) of PC
-                                               with (SETQ PFILE (OPENSTREAM (fetch
-                                                                                 (STREAM FULLNAME)
-                                                                                   of PFILE)
-                                                                           'INPUT]
-                                                             (* ; "Make sure the file is open.")
-                                        (COPYBYTES PFILE OFILE (fetch (PIECE PFPOS) of PC)
-                                               (IPLUS (fetch (PIECE PFPOS) of PC)
-                                                      (COND
-                                                         ((fetch (PIECE PFATP) of PC)
-                                                             (* ; 
-                                     "For fat file pieces, copy twice as many bytes as characters.")
-                                                          (UNFOLD (fetch (PIECE PLEN)
-                                                                     of PC)
-                                                                 2))
-                                                         (T (fetch (PIECE PLEN) of PC]
-                                       ((SETQ PSTR (fetch (PIECE PSTR) of PC))
-                                                             (* ; 
-                                                           "It's in a string.  Just print it.")
-                                        (COND
-                                           [(fetch (PIECE PFATP) of PC)
-                                                             (* ; 
-                                            "The string is fat: Copy twice as many bytes as chars.")
-                                            (for I from 1 to (fetch (PIECE PLEN)
-                                                                            of PC) as CH
-                                               instring PSTR do (\BOUT OFILE (\CHARSET CH))
-                                                                       (\BOUT OFILE (\CHAR8CODE
-                                                                                     CH]
-                                           (T                (* ; 
-                                                   "The string is thin.  Just copy it to the file.")
-                                              (for I from 1 to (fetch (PIECE PLEN)
-                                                                              of PC) as
-                                                                                         CH
-                                                 instring PSTR do (\BOUT OFILE CH]
-                                    [COND
-                                       ((AND (NOT CACHE)
-                                             (RANDACCESSP OFILE))
-                                                             (* ; 
-"CSLI leave the pieces and the pctb alone and just write the file if its cached or not randomaccess")
-                                        (push CH#S (SUB1 CURCH#]
-                                    [COND
-                                       ((fetch (PIECE PFATP) of PC)
-                                        (add CURCH# (UNFOLD (fetch (PIECE PLEN) of PC)
-                                                               2)))
-                                       (T (add CURCH# (fetch (PIECE PLEN) of PC]
-                                                             (* ; 
-                                                  "Keep running track of where in the file we are.")
-                                    ))
-                              (SETQ PREVPREVPC PREVPC)
-                              (SETQ PREVPC PC)
-                              (SETQ PC (fetch (PIECE NEXTPIECE) of PC))
-             finally                                     (* ; 
-                                      "Put out a piece describing the last characters in the file.")
-                   (COND
-                      ((AND FONTFILE (NEQ OLDCH# CURCH#))    (* ; 
-                   "Only if there WERE characters, and only if there's a need for font information")
-                       [OR LOOKSHASH (SETQ LOOKSHASH (\TEDIT.PUT.CHARLOOKS.LIST
-                                                      FONTFILE
-                                                      (fetch (TEXTOBJ TXTCHARLOOKSLIST)
-                                                         of TEXTOBJ]
-                       (\TEDIT.PUT.CHARLOOKS FONTFILE OLDCH# CURCH# OLDLOOKS PREVPC EDITSTENTATIVE 
-                              LOOKSHASH PREVPREVPC)          (* ; 
-                                                          "Put out a description of the characters")
-                       (add PCCOUNT 1)))
-                   (COND
-                      ((AND PARALOOKSSEEN (fetch (PIECE PPARALAST) of PREVPC))
-                                                             (* ; 
-                       "The last piece contained the end of a paragraph.  Make sure it gets noted.")
-                       (\TEDIT.PUT.PARALOOKS FONTFILE PREVPC PARAHASH)
-                       (add PCCOUNT 1]
-          (for FORM in TEDIT.PUT.FINISHEDFORMS do (EVAL FORM))
-                                                             (* ; "Do any user-specific cleanup")
-          (COND
-             (TRUEFILE                                       (* ; 
-                                          "This file needs to be converted to the right convention")
-                    (COND
-                       ((AND FONTFILE (NOT UNFORMATTED?)
-                             (NOT SEPARATEFORMAT))           (* ; 
-                                                         "Formatted file: Copy without converting.")
-                        (COPYBYTES OFILE TRUEFILE 0 -1))
-                       (T                                    (* ; 
-                                "Go ahead and convert the EOLCONVENTION, this is a plain-text file")
-                          (COPYCHARS OFILE TRUEFILE 0 -1)))
-                    (SETQ OFILE TRUEFILE)))
-          [COND
-             ((AND (OPENP OFILE)
-                   FONTFILE)                                 (* ; "We need to write format info.")
-              (\DWOUT FONTFILE (GETEOFPTR OFILE))        (* ; 
-                                           "So remember the end of the plain-text part of the file")
-              (\SMALLPOUT FONTFILE PCCOUNT)                  (* ; 
-                                                   "# OF PIECES WE'' NEED TO RECONSTRUCT THIS FILE")
-              (\SMALLPOUT FONTFILE 31417)                    (* ; 
-                                                     "Now the password for NEW format files: 31416")
-              (COND
-                 ((AND (NOT UNFORMATTED?)
-                       (NOT SEPARATEFORMAT))
-
-                  (* ;; "Only write fmtg info at the end if we want it there--not if we want plain text or want it kept separate.")
-
-                  (COPYBYTES FONTFILE OFILE 0 (GETEOFPTR FONTFILE))
-                                                             (* ; 
-                                                    "Copy the font information to the file trailer")
-                  )
-                 (T))
-              (CLOSEF FONTFILE)
-              (COND
-                 ((NOT SEPARATEFORMAT)                       (* ; 
-                                   "Unless we want the formatting info separately, delete the file")
-                                                             (* ; 
-          "(since FONTFILE is a stream, we should not need to delete it at all) (DELFILE FONTFILE)")
-                  ]
-          (replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                           (fetch (TEXTOBJ 
-                                                                                     DEFAULTCHARLOOKS
-                                                                                             )
-                                                                              of TEXTOBJ)
-                                                                           TEXTOBJ))
-                                                             (* ; 
-    "Re-add the default and caret looks's to the lists, since they may not have been really saved.")
-          (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                     (fetch (TEXTOBJ CARETLOOKS)
-                                                                        of TEXTOBJ)
-                                                                     TEXTOBJ))
-          (replace (TEXTOBJ FMTSPEC) of TEXTOBJ with (\TEDIT.UNIQUIFY.PARALOOKS
-                                                                  (fetch (TEXTOBJ FMTSPEC)
-                                                                     of TEXTOBJ)
-                                                                  TEXTOBJ))
-          (RETURN (CONS (COND
-                           (UNFORMATTED? NIL)
-                           (T FONTFILE))
-                        CH#S])
-
-(\TEDIT.PUT.CHARLOOKS.LIST2
-  [LAMBDA (FILE LOOKSLIST)                                   (* jds "22-May-85 15:12")
-                                                             (* Write the list of CHARLOOKSs into 
-                                                             the font file.)
-          
-          (* Returns a hasharray that will map from a given CHARLOOKS to that CHARLOOKS' 
-          position in the list we wrote on the file.
-          Those position numbers are then written in the individual looks descriptions, 
-          and are used to reconstruct the piece looks when the file is read back in.)
-
-    (PROG ((LOOKSHASH (HASHARRAY 50)))
-          (\DWOUT FILE 0)                                    (* No characters are described by this 
-                                                             pseudo-piece entry.)
-          (\SMALLPOUT FILE \PieceDescriptorCHARLOOKSLIST)    (* Mark it as containing the list of 
-                                                             CHARLOOKSs)
-          (\SMALLPOUT FILE (FLENGTH LOOKSLIST))              (* How many CHARLOOKSs there are in 
-                                                             the list)
-          (for I from 1 as LOOKS in LOOKSLIST do 
-          
-          (* Write each charlooks, in the order they appear in the list.)
-
-                                                 (\TEDIT.PUT.SINGLE.CHARLOOKS2 FILE LOOKS) 
-                                                             (* Write out the description)
-                                                 (PUTHASH LOOKS I LOOKSHASH) 
-          
-          (* And save it in the hash table so people can find its index.)
-)
-          (RETURN LOOKSHASH])
-
-(\TEDIT.PUT.PARALOOKS.LIST2
-  [LAMBDA (FILE LOOKSLIST)                                   (* jds "22-May-85 15:09")
-                                                             (* Write the list of FMTSPECs into the 
-                                                             font file.)
-    (PROG ((LOOKSHASH (HASHARRAY 50)))
-          (\DWOUT FILE 0)
-          (\SMALLPOUT FILE \PieceDescriptorPARALOOKSLIST)
-          (\SMALLPOUT FILE (FLENGTH LOOKSLIST))
-          (for I from 1 as LOOKS in LOOKSLIST do (\TEDIT.PUT.SINGLE.PARALOOKS2 FILE LOOKS) 
-                                                             (* Write out the description)
-                                                 (PUTHASH LOOKS I LOOKSHASH) 
-          
-          (* And save it in the hash table so people can find its index.)
-)
-          (RETURN LOOKSHASH])
-)
-
-
-
-(* ;; "For converting incoming old-format files (1/27/85 cutover)")
-
-(DEFINEQ
-
-(TEDIT.BUILD.PCTB1
-  [LAMBDA (TEXT TEXTOBJ PCCOUNT START END DEFAULTLOOKS)  (* ; "Edited 22-May-92 18:00 by jds")
-
-(* ;;; "READ OBSOLETE FORMATS OF TEDIT FILE")
-
-    (* ;; "START = 1st char of file to read from, if specified")
-
-    (* ;; "END = use this as eofptr of file.  For use in reading files within files.")
-
-    (PROG [SEL LINES PCTB PC OLDPC TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE
-               CACHE? TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP EXISTINGCHARLOOKS EXLOOK 
-               EXISTINGFMTSPECS (CURFILECH# (OR START 0))
-               (CURCH# 1)
-               (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ]
-
-     (* ;; "Get the number of pieces needed (if AN formatted file), otherwise PCCOUNT will be NIL")
-
-          [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND
-                                                         (TEXTOBJ (fetch (TEXTOBJ FMTSPEC)
-                                                                     of TEXTOBJ))
-                                                         (T (create FMTSPEC using 
-                                                                                TEDIT.DEFAULT.FMTSPEC
-                                                                   ]
-          (SETQ DEFAULTLOOKS (OR DEFAULTLOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT)))
-          (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ with NIL))
-                                                             (* ; 
-                                                           "Start by assuming no page formatting")
-          (SETQ PCTB (\MAKEPCTB NIL PCCOUNT))
-          (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT))
-                                  8))
-          (SETQ PIECEINFOCH# (\DWIN TEXT))
-          (SETFILEPTR TEXT PIECEINFOCH#)
-          (bind (OLDPC _ NIL)
-                 (OLDPARALOOKS _ DEFAULTPARALOOKS) for I from 1 to PCCOUNT as PCN
-             from \FirstPieceOffset by \EltsPerPiece
-             do (SETQ PC NIL)                            (* ; 
-                      "This loop may not really read a piece, so we have to distinguish that case.")
-                   (SETQ PCLEN (\DWIN TEXT))
-                   (SETQ TYPECODE (\SMALLPIN TEXT))          (* ; "What kind of piece is it?")
-                   (SELECTC TYPECODE
-                       (\PieceDescriptorPAGEFRAME            (* ; 
-                                                           "This is page layout info for the file")
-                            (AND TEXTOBJ (replace (TEXTOBJ TXTPAGEFRAMES) of TEXTOBJ
-                                            with (TEDIT.GET.PAGEFRAMES1 TEXT)))
-                            (add PCN (IMINUS \EltsPerPiece))
-                                                             (* ; 
-                              "This didn't create a piece -- don't count it in the PCTB placement.")
-                            )
-                       (\PieceDescriptorPARA                 (* ; 
-                                                           "Reading a new set of paragraph looks.")
-                            (AND OLDPC (replace (PIECE PPARALAST) of OLDPC with T))
-                                                             (* ; 
-                                                         "Mark the end of the preceding paragraph.")
-                            (SETQ OLDPARALOOKS (\TEDIT.GET.PARALOOKS1 TEXT))
-                                                             (* ; 
-                                               "Get the new set of looks, for use by later pieces.")
-                            (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP) of TEXTOBJ
-                                            with T))     (* ; 
-                                        "Mark the document as containing paragraph formatting info")
-                            (add PCN (IMINUS \EltsPerPiece))
-                                                             (* ; 
-                              "This didn't create a piece -- don't count it in the PCTB placement.")
-                            )
-                       (\PieceDescriptorLOOKS                (* ; 
-                                "New character looks.  Build a piece to describe those characters.")
-                            (SETQ PC
-                             (create PIECE
-                                    PFILE _ TEXT
-                                    PFPOS _ CURFILECH#
-                                    PLEN _ PCLEN
-                                    PREVPIECE _ OLDPC
-                                    PPARALOOKS _ OLDPARALOOKS))
-                                                             (* ; "Build the new piece")
-                            (COND
-                               (OLDPC                        (* ; 
-                                            "If there's a prior piece, hook this one on the chain.")
-                                      (replace (PIECE NEXTPIECE) of OLDPC with PC)))
-                            (\TEDIT.GET.CHARLOOKS1 PC TEXT)
-                                                             (* ; 
-                                                           "Read the character looks for this guy.")
-                            (add CURFILECH# (fetch (PIECE PLEN) of PC))
-                                                             (* ; 
-                                                           "And note the passing of characters.")
-                            )
-                       (\PieceDescriptorOBJECT               (* ; 
- "It describes an object.  Read that, and perhaps some description of the charlooks to go with it.")
-                            (SETQ PC
-                             (create PIECE
-                                    PFILE _ TEXT
-                                    PFPOS _ CURFILECH#
-                                    PLEN _ PCLEN
-                                    PREVPIECE _ OLDPC
-                                    PPARALOOKS _ OLDPARALOOKS))
-                            (COND
-                               (OLDPC                        (* ; 
-                                            "If there's a prior piece, hook this one on the chain.")
-                                      (replace (PIECE NEXTPIECE) of OLDPC with PC)))
-                            (TEDIT.GET.OBJECT1 TEXTSTREAM PC TEXT CURFILECH#)
-                            (add CURFILECH# (fetch (PIECE PLEN) of PC))
-                            [COND
-                               ((NOT (ZEROP (\BIN TEXT)))    (* ; 
-                                    "There are new character looks for this object.  Read them in.")
-                                (\DWIN TEXT)
-                                (\WIN TEXT)                  (* ; 
-                                            "Skip over the piece-type code we know has to be here.")
-                                (\TEDIT.GET.CHARLOOKS1 PC TEXT))
-                               (T                            (* ; 
-                                                  "No new looks;  steal them from the prior piece.")
-                                  (replace (PIECE PLOOKS) of PC
-                                     with (OR (AND OLDPC (fetch (PIECE PLOOKS) of OLDPC))
-                                                  DEFAULTLOOKS]
-                            (replace (PIECE PLEN) of PC with 1)
-                                                             (* ; 
-                                                       "OBJECTs are officially one character long.")
-                            )
-                       (SHOULDNT "Impossible piece-type code in BUILD.PCTB"))
-                   (COND
-                      (PC                                    (* ; 
-                                                     "If we created a piece, save it in the table.")
-                          [COND
-                             ((SETQ EXLOOK (for LOOK in EXISTINGCHARLOOKS
-                                              thereis (EQCLOOKS (fetch (PIECE PLOOKS)
-                                                                       of PC)
-                                                                 LOOK)))
-                                                             (* ; 
-                       "These charlooks are a duplicate of pre-existing ones.  Re-use the old one.")
-                              (replace (PIECE PLOOKS) of PC with EXLOOK))
-                             (T (push EXISTINGCHARLOOKS (fetch (PIECE PLOOKS) of PC]
-                          [COND
-                             ((SETQ EXLOOK (for LOOK in EXISTINGFMTSPECS
-                                              thereis (EQFMTSPEC (fetch (PIECE PPARALOOKS)
-                                                                        of PC)
-                                                                 LOOK)))
-                                                             (* ; 
-                       "These paralooks are a duplicate of pre-existing ones.  Re-use the old one.")
-                              (replace (PIECE PPARALOOKS) of PC with EXLOOK))
-                             (T (push EXISTINGFMTSPECS (fetch (PIECE PPARALOOKS) of
-                                                                                         PC]
-                          (INSERT-BRT (CREATEPCNODE CURCH# PC)
-                                 PCTB)
-                          (add CURCH# (fetch (PIECE PLEN) of PC))
-                          (SETQ OLDPC PC))) finally (INSERT-BRT (CREATEPCNODE CURCH# 'LASTPIECE)
-                                                               PCTB))
-          (RETURN PCTB])
-
-(TEDIT.GET.PAGEFRAMES1
-  [LAMBDA (FILE)                                             (* jds " 1-Feb-85 14:55")
-          
-          (* Read a bunch of page frames from the file, and return it.)
-
-    (TEDIT.PARSE.PAGEFRAMES1 (READ FILE])
-
-(\TEDIT.GET.CHARLOOKS1
-  [LAMBDA (PC FILE)                                      (* ; "Edited 30-May-91 20:26 by jds")
-                                                             (* Read a description of PC's 
-                                                           CHARLOOKS from FILE.)
-    (PROG (FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR (LOOKS (create CHARLOOKS))
-                )
-          (replace (PIECE PLOOKS) of PC with LOOKS)
-          (SETQ NAME (\ARBIN FILE))                      (* The font name)
-          (SETQ SIZE (\SMALLPIN FILE))                       (* Size of the type, in points)
-          (SETQ SUPER (\SMALLPIN FILE))                      (* Superscripting distance)
-          (SETQ SUB (\SMALLPIN FILE))                        (* former Subscripting distance)
-          (OR (ZEROP SUB)
-              (SETQ SUPER (IMINUS SUB)))
-
-         (* If this is an old file, it'll have a subscript value not zero.
-       Let those past and do the right thing.)
-
-          (COND
-             ((NOT (ZEROP (\BIN FILE)))                      (* This text is NEW.
-                                                           Mark it so.)
-              (replace (PIECE PNEW) of PC with T)))
-          [COND
-             ((NOT (ZEROP (\BIN FILE)))                      (* There is style or user 
-                                                           information to be read)
-              (replace (CHARLOOKS CLSTYLE) of LOOKS with (OR (\ARBIN FILE)
-                                                                         0))
-              (replace (CHARLOOKS CLUSERINFO) of LOOKS with (\ARBIN FILE]
-          (SETQ PROPS (\SMALLPIN FILE))
-          (with CHARLOOKS LOOKS [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS]
-                 [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS]
-                 [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS]
-                 [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS]
-                 [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS]
-                 [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS]
-                 [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS]
-                 [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS]
-                 [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS]
-                 [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS]
-                 (SETQ CLSIZE SIZE)
-                 (SETQ CLOFFSET SUPER))
-          (replace (CHARLOOKS CLFONT) of LOOKS
-             with (COND
-                         ((LISTP NAME)                       (* This was a font class.
-                                                           Restore it.)
-                          (FONTCLASS (pop NAME)
-                                 NAME))
-                         ((AND NAME (NOT (ZEROP SIZE)))
-                          (FONTCREATE NAME SIZE (COND
-                                                   ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS)
-                                                         (fetch (CHARLOOKS CLITAL) of LOOKS))
-                                                    'BOLDITALIC)
-                                                   ((fetch (CHARLOOKS CLBOLD) of LOOKS)
-                                                    'BOLD)
-                                                   ((fetch (CHARLOOKS CLITAL) of LOOKS)
-                                                    'ITALIC])
-
-(\TEDIT.GET.PARALOOKS1
-  [LAMBDA (FILE)                                         (* ; "Edited 30-May-91 20:34 by jds")
-                                                             (* Read a paragraph format spec from 
-                                                           the FILE, and return it for later 
-                                                           use.)
-    (PROG ((LOOKS (create FMTSPEC))
-           TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC)
-          (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Left margin for the first line of 
-                                                           the paragraph)
-          (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Left margin for the rest of the 
-                                                           paragraph)
-          (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Right margin for the paragraph)
-          (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Leading before the paragraph)
-          (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Lead after the paragraph)
-          (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE))
-                                                             (* inter-line leading)
-          (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL)))
-                                                             (* Will be tab specs)
-          (SETQ TABFLG (\BIN FILE))
-          (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (\BIN FILE)
-                                                                (1 'LEFT)
-                                                                (2 'RIGHT)
-                                                                (3 'CENTERED)
-                                                                (4 'JUSTIFIED)
-                                                                (SHOULDNT)))
-          (COND
-             ((NOT (ZEROP (LOGAND TABFLG 1)))                (* There are tabs to read)
-              (SETQ DEFAULTTAB (\SMALLPIN FILE))
-              (SETQ TABCOUNT (\BIN FILE))
-              [SETQ TABS (for TAB# from 1 to TABCOUNT
-                            collect (create TAB
-                                               TABX _ (\SMALLPIN FILE)
-                                               TABKIND _ (SELECTQ (\BIN FILE)
-                                                             (0 'LEFT)
-                                                             (1 'RIGHT)
-                                                             (2 'CENTERED)
-                                                             (3 'DECIMAL)
-                                                             (SHOULDNT]
-              (OR (ZEROP DEFAULTTAB)
-                  (RPLACA TABSPEC DEFAULTTAB))
-              (RPLACD TABSPEC TABS)))
-          [COND
-             ((NOT (ZEROP (LOGAND TABFLG 2)))                (* There are other paragraph 
-                                                           parameters to be read.)
-              (replace (FMTSPEC FMTSPECIALX) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Special X location on page for 
-                                                           this paragraph)
-              (replace (FMTSPEC FMTSPECIALY) of LOOKS with (\SMALLPIN FILE))
-              (replace (FMTSPEC FMTUSERINFO) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTPARATYPE) of LOOKS with (\ATMIN FILE))
-              (replace (FMTSPEC FMTPARASUBTYPE) of LOOKS with (\ATMIN FILE))
-              (replace (FMTSPEC FMTSTYLE) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTCHARSTYLES) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTNEWPAGEBEFORE) of LOOKS with (\ARBIN FILE))
-              (replace (FMTSPEC FMTNEWPAGEAFTER) of LOOKS with (\ARBIN FILE]
-          (RETURN LOOKS])
-
-(TEDIT.GET.OBJECT1
-  [LAMBDA (STREAM PIECE FILE CURCH#)                    (* ; "Edited 12-Jun-90 18:17 by mitani")
-                                                             (* Get an object from the file)
-
-         (* CURCH# = fileptr within the text section of the file where the object's text 
-       starts.)
-
-    (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-           FILEPTRSAVE NAMELEN GETFN OBJ)
-          (SETQ GETFN (\ATMIN FILE))                     (* The GETFN for this kind of 
-                                                           IMAGEOBJ)
-          (SETQ FILEPTRSAVE (GETFILEPTR FILE))               (* Save our file location thru the 
-                                                           building of the object)
-          (SETFILEPTR FILE CURCH#)
-          (SETQ OBJ (READIMAGEOBJ FILE GETFN))
-          (SETFILEPTR FILE FILEPTRSAVE)
-          (replace (PIECE POBJ) of PIECE with OBJ)
-          (replace (PIECE PFILE) of PIECE with NIL)
-          (replace (PIECE PSTR) of PIECE with NIL)
-          [replace (PIECE PLOOKS) of PIECE with (COND
-                                                               ((fetch (PIECE PREVPIECE)
-                                                                   of PIECE)
-                                                                (fetch (PIECE PLOOKS)
-                                                                   of (fetch (PIECE PREVPIECE
-                                                                                            )
-                                                                             of PIECE)))
-                                                               (T (OR (fetch (TEXTOBJ 
-                                                                                     DEFAULTCHARLOOKS
-                                                                                        )
-                                                                         of TEXTOBJ)
-                                                                      (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                       (CHARLOOKS.FROM.FONT 
-                                                                              DEFAULTFONT)
-                                                                       TEXTOBJ]
-          (RETURN (fetch (PIECE POBJ) of PIECE])
-)
-
-
-
-(* ;; "VERSION 0 Compatibility reading functions")
-
-(DEFINEQ
-
-(TEDIT.BUILD.PCTB0
-  [LAMBDA (TEXT TEXTOBJ PCCOUNT START END)    (* ; 
-                                                "Edited  2-May-95 14:11 by sybalsky:mv:envos")
-
-(* ;;; "READ OBSOLETE FORMATS OF TEDIT FILE")
-
-    (PROG [SEL LINES PCTB PC OLDPC TYPECODE PCLEN CHLOOKSSEEN NEWPC PARALOOKSSEEN PIECEINFOCH# CACHE
-               TTEXTOBJ USER.CMFILE TSTREAM USERFILEFORMAT USERTEMP (CURFILECH# (OR START 0))
-               (CURCH# 1)
-               (TEXTSTREAM (AND TEXTOBJ (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ]
-                                                             (* ; 
-            "Get the number of pieces needed (if AN formatted file), otherwise PCCOUNT will be NIL")
-          [SETQ DEFAULTPARALOOKS (OR DEFAULTPARALOOKS (COND
-                                                         (TEXTOBJ (fetch (TEXTOBJ FMTSPEC)
-                                                                     of TEXTOBJ))
-                                                         (T (create FMTSPEC using 
-                                                                                TEDIT.DEFAULT.FMTSPEC
-                                                                   ]
-          (SETQ PCTB (\MAKEPCTB NIL PCCOUNT))
-          (replace (TEXTOBJ PCTB) of TEXTOBJ with PCTB)
-          (SETFILEPTR TEXT (IDIFFERENCE (OR END (GETEOFPTR TEXT))
-                                  8))
-          (SETQ PIECEINFOCH# (\DWIN TEXT))
-          (SETFILEPTR TEXT PIECEINFOCH#)
-          (bind (OLDPC _ NIL) for I from 1 to PCCOUNT as PCN from 
-                                                                                    \FirstPieceOffset
-             by \EltsPerPiece do (SETQ PC (create PIECE
-                                                         PFILE _ TEXT
-                                                         PFPOS _ CURFILECH#
-                                                         PLEN _ (SETQ PCLEN (\DWIN TEXT))
-                                                         PREVPIECE _ OLDPC
-                                                         PPARALOOKS _ DEFAULTPARALOOKS))
-                                        [COND
-                                           (OLDPC (replace (PIECE NEXTPIECE) of OLDPC
-                                                     with PC)
-                                                  (replace (PIECE PPARALOOKS) of PC
-                                                     with (fetch (PIECE PPARALOOKS)
-                                                                 of OLDPC]
-                                        (SETQ TYPECODE (\SMALLPIN TEXT))
-                                        (SELECTC TYPECODE
-                                            (\PieceDescriptorLOOKS 
-                                                 (TEDIT.GET.CHARLOOKS0 PC TEXT)
-                                                 (add CURFILECH# (fetch (PIECE PLEN)
-                                                                        of PC)))
-                                            (\PieceDescriptorOBJECT 
-                                                 (TEDIT.GET.OBJECT0 TEXTSTREAM PC TEXT CURFILECH#
-                                                        )
-                                                 (add CURFILECH# (fetch (PIECE PLEN)
-                                                                        of PC))
-                                                 (replace (PIECE PLEN) of PC with 1)
-                                                             (* ; 
-                                          "Only object--can't be followed by either ot the others.")
-                                                 )
-                                            (\PieceDescriptorPARA 
-                                                 (AND OLDPC (replace (PIECE PPARALAST)
-                                                               of OLDPC with T))
-                                                 (TEDIT.GET.PARALOOKS0 PC TEXT)
-                                                 (replace (PIECE PLEN) of PC
-                                                    with (\DWIN TEXT))
-                                                             (* ; 
-                                                "Set this piece's length from the character looks.")
-                                                 (\SMALLPIN TEXT)
-                                                             (* ; 
-                                              "Skip the piece-type code, since we know what's next")
-                                                 (TEDIT.GET.CHARLOOKS0 PC TEXT)
-                                                             (* ; "This document is 'formatted' .")
-                                                 (add CURFILECH# (fetch (PIECE PLEN)
-                                                                        of PC))
-                                                 (AND TEXTOBJ (replace (TEXTOBJ FORMATTEDP)
-                                                                 of TEXTOBJ with T)))
-                                            (SHOULDNT "Impossible piece-type code in BUILD.PCTB"))
-                                        (SETQ OLDPC PC)
-                                        (\INSERTPIECE PC 'LASTPIECE TEXTOBJ) 
-                                                             (* INSERT-BRT (CREATEPCNODE CURCH# 
-                                                           PC) PCTB)
-                                        (add CURCH# (fetch (PIECE PLEN) of PC))
-             finally                                     (* INSERT-BRT (CREATEPCNODE CURCH#
-                                                           (QUOTE LASTPIECE)) PCTB))
-          (RETURN PCTB])
-
-(TEDIT.GET.CHARLOOKS0
-  [LAMBDA (PC FILE)                                      (* ; "Edited 30-May-91 20:26 by jds")
-                                                             (* Put a description of LOOKS into 
-                                                           FILE. LOOKS apply to characters CH1 
-                                                           thru CHLIM-1)
-    (PROG (FONT STR NAME NAMELEN SIZE SUPER SUB PROPS STYLESTR USERSTR (LOOKS (create CHARLOOKS))
-                )
-          (replace (PIECE PLOOKS) of PC with LOOKS)
-          (SETQ NAMELEN (\SMALLPIN FILE))                    (* The length of the description 
-                                                           which follows)
-          [SETQ NAME (PACK (for I from 1 to NAMELEN collect (CHARACTER (\BIN FILE]
-                                                             (* The font name)
-          (SETQ SIZE (\SMALLPIN FILE))                       (* Size of the type, in points)
-          (SETQ SUPER (\SMALLPIN FILE))                      (* Superscripting distance)
-          (SETQ SUB (\SMALLPIN FILE))                        (* former Subscripting distance)
-          (OR (ZEROP SUB)
-              (SETQ SUPER (IMINUS SUB)))
-
-         (* If this is an old file, it'll have a subscript value not zero.
-       Let those past and do the right thing.)
-
-          (COND
-             ((NOT (ZEROP (\BIN FILE)))                      (* This text is NEW.
-                                                           Mark it so.)
-              (replace (PIECE PNEW) of PC with T)))
-          [COND
-             ((NOT (ZEROP (\BIN FILE)))                      (* There is style or user 
-                                                           information to be read)
-              (SETQ STYLESTR (\STRINGIN FILE))
-              (SETQ USERSTR (\STRINGIN FILE))
-              (COND
-                 ((NOT (ZEROP (NCHARS STYLESTR)))            (* There IS style info)
-                  (replace (CHARLOOKS CLSTYLE) of LOOKS with (READ STYLESTR)))
-                 (T (replace (CHARLOOKS CLSTYLE) of LOOKS with 0)))
-              (COND
-                 ((NOT (ZEROP (NCHARS USERSTR)))             (* There IS user info)
-                  (replace (CHARLOOKS CLUSERINFO) of LOOKS with (READ USERSTR]
-          (SETQ PROPS (\SMALLPIN FILE))
-          (with CHARLOOKS LOOKS [SETQ CLBOLD (NOT (ZEROP (LOGAND 512 PROPS]
-                 [SETQ CLITAL (NOT (ZEROP (LOGAND 256 PROPS]
-                 [SETQ CLULINE (NOT (ZEROP (LOGAND 128 PROPS]
-                 [SETQ CLOLINE (NOT (ZEROP (LOGAND 64 PROPS]
-                 [SETQ CLSTRIKE (NOT (ZEROP (LOGAND 32 PROPS]
-                 [SETQ CLSMALLCAP (NOT (ZEROP (LOGAND 16 PROPS]
-                 [SETQ CLPROTECTED (NOT (ZEROP (LOGAND 8 PROPS]
-                 [SETQ CLINVISIBLE (NOT (ZEROP (LOGAND 4 PROPS]
-                 [SETQ CLSELHERE (NOT (ZEROP (LOGAND 2 PROPS]
-                 [SETQ CLCANCOPY (NOT (ZEROP (LOGAND 1 PROPS]
-                 (SETQ CLSIZE SIZE)
-                 (SETQ CLOFFSET SUPER))
-          (replace (CHARLOOKS CLFONT) of LOOKS
-             with (AND NAME (NOT (ZEROP SIZE))
-                           (FONTCREATE NAME SIZE (COND
-                                                    ((AND (fetch (CHARLOOKS CLBOLD) of LOOKS)
-                                                          (fetch (CHARLOOKS CLITAL) of LOOKS)
-                                                          )
-                                                     'BOLDITALIC)
-                                                    ((fetch (CHARLOOKS CLBOLD) of LOOKS)
-                                                     'BOLD)
-                                                    ((fetch (CHARLOOKS CLITAL) of LOOKS)
-                                                     'ITALIC])
-
-(TEDIT.GET.OBJECT0
-  [LAMBDA (STREAM PIECE FILE CURCH#)                    (* ; "Edited 12-Jun-90 18:17 by mitani")
-                                                             (* Get an object from the file)
-
-         (* CURCH# = fileptr within the text section of the file where the object's text 
-       starts.)
-
-    (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-           FILEPTRSAVE NAMELEN GETFN OBJ)
-          (SETQ GETFN (\ATMIN FILE))                     (* The GETFN for this kind of 
-                                                           IMAGEOBJ)
-          (SETQ FILEPTRSAVE (GETFILEPTR FILE))               (* Save our file location thru the 
-                                                           building of the object)
-          (SETFILEPTR FILE CURCH#)
-          (SETQ OBJ (READIMAGEOBJ FILE GETFN))
-          (SETFILEPTR FILE FILEPTRSAVE)
-          (replace (PIECE POBJ) of PIECE with OBJ)
-          (replace (PIECE PFILE) of PIECE with NIL)
-          (replace (PIECE PSTR) of PIECE with NIL)
-          [replace (PIECE PLOOKS) of PIECE with (COND
-                                                               ((fetch (PIECE PREVPIECE)
-                                                                   of PIECE)
-                                                                (fetch (PIECE PLOOKS)
-                                                                   of (fetch (PIECE PREVPIECE
-                                                                                            )
-                                                                             of PIECE)))
-                                                               (T (OR (fetch (TEXTOBJ 
-                                                                                     DEFAULTCHARLOOKS
-                                                                                        )
-                                                                         of TEXTOBJ)
-                                                                      (\TEDIT.UNIQUIFY.CHARLOOKS
-                                                                       (CHARLOOKS.FROM.FONT 
-                                                                              DEFAULTFONT)
-                                                                       TEXTOBJ]
-          (RETURN (fetch (PIECE POBJ) of PIECE])
-
-(TEDIT.GET.PARALOOKS0
-  [LAMBDA (PC FILE)                                      (* ; "Edited 30-May-91 20:34 by jds")
-                                                             (* Put a description of LOOKS into 
-                                                           FILE. LOOKS apply to characters CH1 
-                                                           thru CHLIM-1)
-    (PROG ((LOOKS (create FMTSPEC))
-           TABFLG DEFAULTTAB TABCOUNT TABS TABSPEC)
-          (replace (PIECE PPARALOOKS) of PC with LOOKS)
-          (replace (FMTSPEC 1STLEFTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Left margin for the first line of 
-                                                           the paragraph)
-          (replace (FMTSPEC LEFTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Left margin for the rest of the 
-                                                           paragraph)
-          (replace (FMTSPEC RIGHTMAR) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Right margin for the paragraph)
-          (replace (FMTSPEC LEADBEFORE) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Leading before the paragraph)
-          (replace (FMTSPEC LEADAFTER) of LOOKS with (\SMALLPIN FILE))
-                                                             (* Lead after the paragraph)
-          (replace (FMTSPEC LINELEAD) of LOOKS with (\SMALLPIN FILE))
-                                                             (* inter-line leading)
-          (replace (FMTSPEC TABSPEC) of LOOKS with (SETQ TABSPEC (CONS NIL NIL)))
-                                                             (* Will be tab specs)
-          (SETQ TABFLG (\BIN FILE))
-          (replace (FMTSPEC QUAD) of LOOKS with (SELECTC (\BIN FILE)
-                                                                (1 'LEFT)
-                                                                (2 'RIGHT)
-                                                                (3 'CENTERED)
-                                                                (4 'JUSTIFIED)
-                                                                (SHOULDNT)))
-          (COND
-             ((NOT (ZEROP TABFLG))                           (* There are tabs to read)
-              (SETQ DEFAULTTAB (\SMALLPIN FILE))
-              (SETQ TABCOUNT (\BIN FILE))
-              [SETQ TABS (for TAB# from 1 to TABCOUNT
-                            collect (create TAB
-                                               TABX _ (\SMALLPIN FILE)
-                                               TABKIND _ (SELECTQ (\BIN FILE)
-                                                             (0 'LEFT)
-                                                             (1 'RIGHT)
-                                                             (2 'CENTERED)
-                                                             (3 'DECIMAL)
-                                                             (SHOULDNT]
-              (OR (ZEROP DEFAULTTAB)
-                  (RPLACA TABSPEC DEFAULTTAB))
-              (RPLACD TABSPEC TABS])
-)
-(PUTPROPS TEDITFILE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 
-1991 1992 1993 1994 1995))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (3089 57219 (TEDIT.BUILD.PCTB 3099 . 37241) (\TEDIT.CONVERT.FOREIGN.FORMAT 37243 . 38684
-) (TEDIT.FORMATTEDFILEP 38686 . 42550) (TEDIT.GET 42552 . 50903) (TEDIT.PARSE.PAGEFRAMES1 50905 . 
-52611) (\ARBIN 52613 . 53234) (\ATMIN 53236 . 53565) (\DWIN 53567 . 53845) (\STRINGIN 53847 . 54444) (
-\TEDIT.FORMATTEDP1 54446 . 56710) (\TEDIT.SET.WINDOW 56712 . 57217)) (57255 77016 (TEDIT.INCLUDE 57265
- . 68392) (TEDIT.RAW.INCLUDE 68394 . 77014)) (77050 121476 (TEDIT.PUT 77060 . 86750) (TEDIT.PUT.PCTB 
-86752 . 115212) (\TEDIT.PUTRESET 115214 . 115460) (TEDIT.PUT.PIECE.DESCRIPTOR 115462 . 117925) (
-\ARBOUT 117927 . 119127) (\ATMOUT 119129 . 119644) (\DWOUT 119646 . 119929) (\STRINGOUT 119931 . 
-120383) (\TEDIT-OPEN-FONT-FILE 120385 . 121474)) (121477 131989 (\TEDIT.GET.CHARLOOKS.LIST 121487 . 
-121892) (\TEDIT.GET.SINGLE.CHARLOOKS 121894 . 124939) (\TEDIT.PUT.CHARLOOKS.LIST 124941 . 126736) (
-\TEDIT.PUT.SINGLE.CHARLOOKS 126738 . 131987)) (131990 146269 (\TEDIT.GET.PARALOOKS.LIST 132000 . 
-132413) (\TEDIT.GET.SINGLE.PARALOOKS 132415 . 138809) (\TEDIT.PUT.PARALOOKS.LIST 138811 . 139805) (
-\TEDIT.PUT.SINGLE.PARALOOKS 139807 . 146267)) (146577 207053 (TEDIT.BUILD.PCTB2 146587 . 159943) (
-\TEDIT.GET.CHARLOOKS.LIST2 159945 . 160352) (\TEDIT.GET.SINGLE.CHARLOOKS2 160354 . 163266) (
-\TEDIT.PUT.SINGLE.PARALOOKS2 163268 . 167982) (\TEDIT.PUT.SINGLE.CHARLOOKS2 167984 . 172480) (
-\TEDIT.GET.PARALOOKS.LIST2 172482 . 172889) (\TEDIT.GET.SINGLE.PARALOOKS2 172891 . 177479) (
-TEDIT.PUT.PCTB2 177481 . 204357) (\TEDIT.PUT.CHARLOOKS.LIST2 204359 . 206156) (
-\TEDIT.PUT.PARALOOKS.LIST2 206158 . 207051)) (207130 228254 (TEDIT.BUILD.PCTB1 207140 . 217330) (
-TEDIT.GET.PAGEFRAMES1 217332 . 217587) (\TEDIT.GET.CHARLOOKS1 217589 . 221139) (\TEDIT.GET.PARALOOKS1 
-221141 . 225722) (TEDIT.GET.OBJECT1 225724 . 228252)) (228314 244346 (TEDIT.BUILD.PCTB0 228324 . 
-234357) (TEDIT.GET.CHARLOOKS0 234359 . 238378) (TEDIT.GET.OBJECT0 238380 . 240908) (
-TEDIT.GET.PARALOOKS0 240910 . 244344)))))
-STOP
diff --git a/obsolete/library/new/TEDITFILE.LCOM b/obsolete/library/new/TEDITFILE.LCOM
deleted file mode 100644
index 9b95e8e8..00000000
Binary files a/obsolete/library/new/TEDITFILE.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITFIND.LCOM b/obsolete/library/new/TEDITFIND.LCOM
deleted file mode 100644
index eef44183..00000000
Binary files a/obsolete/library/new/TEDITFIND.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITFNKEYS.LCOM b/obsolete/library/new/TEDITFNKEYS.LCOM
deleted file mode 100644
index 08227e05..00000000
Binary files a/obsolete/library/new/TEDITFNKEYS.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITHCPY.LCOM b/obsolete/library/new/TEDITHCPY.LCOM
deleted file mode 100644
index dd0b09f3..00000000
Binary files a/obsolete/library/new/TEDITHCPY.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITHISTORY b/obsolete/library/new/TEDITHISTORY
deleted file mode 100644
index 03775d97..00000000
--- a/obsolete/library/new/TEDITHISTORY
+++ /dev/null
@@ -1,622 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED " 4-May-95 10:38:22" {DSK}<lispcore>library>new>TEDITHISTORY.;3 38709  
-
-      changes to%:  (FNS TEDIT.REDO.INSERTION \TEDIT.CUMULATE.EVENTS TEDIT.UNDO TEDIT.UNDO.REPLACE)
-
-      previous date%: "22-Mar-95 18:20:17" {DSK}<lispcore>library>new>TEDITHISTORY.;1)
-
-
-(* ; "
-Copyright (c) 1983, 1984, 1985, 1986, 1987, 1990, 1991, 1993, 1995 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT TEDITHISTORYCOMS)
-
-(RPAQQ TEDITHISTORYCOMS
-       ((FILES TEDITDECLS)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
-               (FILES (LOADCOMP)
-                      TEDITDECLS))
-        (GLOBALVARS TEDIT.HISTORY.TYPELST TEDIT.HISTORYLST)
-        (INITVARS (TEDIT.HISTORY.TYPELST NIL)
-               (TEDIT.HISTORYLST NIL))
-        (COMS 
-              (* ;; "History-list maintenance functions")
-
-              (FNS \TEDIT.HISTORYADD \TEDIT.CUMULATE.EVENTS))
-        (COMS 
-              (* ;; "Specialized UNDO & REDO functions.")
-
-              (FNS TEDIT.UNDO TEDIT.UNDO.INSERTION TEDIT.UNDO.DELETION TEDIT.REDO 
-                   TEDIT.REDO.INSERTION TEDIT.UNDO.MOVE TEDIT.UNDO.REPLACE TEDIT.REDO.REPLACE 
-                   TEDIT.REDO.MOVE))))
-
-(FILESLOAD TEDITDECLS)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \SCRATCHLEN 64)
-
-
-(CONSTANTS (\SCRATCHLEN 64))
-)
-
-
-(FILESLOAD (LOADCOMP)
-       TEDITDECLS)
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS TEDIT.HISTORY.TYPELST TEDIT.HISTORYLST)
-)
-
-(RPAQ? TEDIT.HISTORY.TYPELST NIL)
-
-(RPAQ? TEDIT.HISTORYLST NIL)
-
-
-
-(* ;; "History-list maintenance functions")
-
-(DEFINEQ
-
-(\TEDIT.HISTORYADD
-  [LAMBDA (TEXTOBJ EVENT)                                    (* ; "Edited  3-Sep-87 10:36 by jds")
-          
-          (* ;; "Add a new event to the history list.  For now, this just re-sets the whole list to be the one event...")
-          
-          (* ;; 
-          "This function also takes care of cumulating cumulative events, like successive deletions.")
-
-    (LET* ((OLDEVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ))
-           (ETYPE (fetch (TEDITHISTORYEVENT THACTION) of EVENT))
-           (OETYPE (fetch (TEDITHISTORYEVENT THACTION) of OLDEVENT))
-           (REALEVENT EVENT))
-          [COND
-             ((AND OLDEVENT (EQ OETYPE ETYPE)
-                   (EQ ETYPE 'Delete))                       (* ; 
-                                        "Repeated successive deletions.  See if we can combine them.")
-
-              (LET* [(OSTART (fetch (TEDITHISTORYEVENT THCH#) of OLDEVENT))
-                     (NSTART (fetch (TEDITHISTORYEVENT THCH#) of EVENT))
-                     (OLDEND (+ OSTART (fetch (TEDITHISTORYEVENT THLEN) of OLDEVENT)))
-                     (NEWEND (+ NSTART (fetch (TEDITHISTORYEVENT THLEN) of EVENT]
-                    (COND
-                       ((IEQP OLDEND NSTART)                 (* ; 
-                              "The old deletion was just in front of the current one; cumulate them.")
-
-                        (SETQ REALEVENT (\TEDIT.CUMULATE.EVENTS OLDEVENT EVENT T)))
-                       ((IEQP NEWEND OSTART)                 (* ; 
-                                  "The new deletion was just in front of the old one; cumulate them.")
-
-                        (SETQ REALEVENT (\TEDIT.CUMULATE.EVENTS EVENT OLDEVENT T]
-          (replace (TEXTOBJ TXTHISTORY) of TEXTOBJ with REALEVENT])
-
-(\TEDIT.CUMULATE.EVENTS
-  [LAMBDA (EVENT1 EVENT2 PIECES-TO-SAVE?)     (* ; 
-                                                "Edited  3-Apr-95 12:23 by sybalsky:mv:envos")
-
-    (* ;; "Accumulate history events that should really be combined into a single event.")
-
-    (* ;; "For now, this assumes they're events of the same type.  Actually, this should be able to cumulate a delete/insert pair into a replacement, etc.")
-
-    (LET* [(OLDLEN (fetch (TEDITHISTORYEVENT THLEN) of EVENT1))
-           (NEWPC1 (CAR (fetch (TEDITHISTORYEVENT THFIRSTPIECE) of EVENT2)))
-           (REALEVENT (create TEDITHISTORYEVENT using EVENT1 THLEN _
-                                                          (+ OLDLEN (fetch (TEDITHISTORYEVENT
-                                                                                THLEN) of EVENT2]
-          (bind (PC _ (CAR (fetch (TEDITHISTORYEVENT THFIRSTPIECE) of EVENT1)))
-                 (CHCOUNT _ 0) while (< (SETQ CHCOUNT (+ CHCOUNT (fetch (PIECE PLEN)
-                                                                        of PC)))
-                                            OLDLEN) do (SETQ PC (fetch (PIECE NEXTPIECE)
-                                                                       of PC))
-             finally (replace (PIECE NEXTPIECE) of PC with NEWPC1)
-                   (replace (PIECE PREVPIECE) of NEWPC1 with PC)
-                   (RETURN))
-          REALEVENT])
-)
-
-
-
-(* ;; "Specialized UNDO & REDO functions.")
-
-(DEFINEQ
-
-(TEDIT.UNDO
-  [LAMBDA (TEXTOBJ)                           (* ; 
-                                                "Edited 22-Mar-95 16:48 by sybalsky:mv:envos")
-
-    (* ;; "Undo the last thing this guy did.")
-
-    (COND
-       ((NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ))
-
-        (* ;; "Only undo things if the document is allowed to change.")
-
-        (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-               EVENT CH# LEN FIRSTPIECE)
-              (COND
-                 ((SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ))
-                                                             (* ; 
-                                       "There really is something to UNDO.  Decide what, & fix it.")
-                  (SETQ LEN (fetch THLEN of EVENT))  (* ; 
-                                             "Length of the text that was inserted/deleted/changed")
-                  (SETQ CH# (fetch THCH# of EVENT))  (* ; "Starting CH# of the change")
-                  (SETQ FIRSTPIECE (CAR (fetch THFIRSTPIECE of EVENT)))
-                                                             (* ; 
-                                                           "First piece affected by the change")
-                  (RESETLST
-                      (RESETSAVE (CURSOR WAITINGCURSOR))
-                      (\SHOWSEL SEL NIL NIL)
-                      [SELECTQ (fetch THACTION of EVENT)
-                          ((Insert Copy Include)             (* ; "It was an insertion")
-                               (TEDIT.UNDO.INSERTION TEXTOBJ EVENT LEN CH# FIRSTPIECE))
-                          (Delete                            (* ; "It was a deletion")
-                                  (TEDIT.UNDO.DELETION TEXTOBJ EVENT LEN CH# FIRSTPIECE))
-                          (Looks                             (* ; "It was a character-looks change")
-                                 (TEDIT.UNDO.LOOKS TEXTOBJ EVENT LEN CH# FIRSTPIECE))
-                          (ParaLooks                         (* ; "It was a PARA looks change")
-                                     (TEDIT.UNDO.PARALOOKS TEXTOBJ EVENT LEN CH# FIRSTPIECE))
-                          (Move (TEDIT.UNDO.MOVE TEXTOBJ EVENT LEN CH# FIRSTPIECE)
-                                                             (* ; "He moved some text")
-                                )
-                          ((Replace LowerCase UpperCase) 
-
-                                                 (* ;; "He replaced one piece of text with another ; Lower-casing and upper-casing have the same undo event.")
-
-                               (TEDIT.UNDO.REPLACE TEXTOBJ EVENT LEN CH# FIRSTPIECE))
-                          (Get                               (* ; "He did a GET -- not undoable.")
-                               (TEDIT.PROMPTPRINT TEXTOBJ "You can't UNDO a GET." T))
-                          (Put                               (* ; "He did a PUT -- not undoable.")
-                               (TEDIT.PROMPTPRINT TEXTOBJ "You can't UNDO a Put." T))
-                          (COND
-                             ((AND (SETQ UNDOFN (ASSOC (fetch THACTION of EVENT)
-                                                       TEDIT.HISTORY.TYPELST))
-                                   (SETQ UNDOFN (CADDR UNDOFN)))
-                                                             (* ; 
-                                    "TEDIT.HISTORY.TYPELST is an ALST of form (type redofn undofn)")
-                              (APPLY* UNDOFN TEXTOBJ EVENT LEN CH# FIRSTPIECE))
-                             (T (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "UNDO not implemented for "
-                                                                  (fetch THACTION of EVENT))
-                                       T]
-                      (\SHOWSEL SEL NIL T)))
-                 (T (TEDIT.PROMPTPRINT TEXTOBJ "Nothing to UNDO." T])
-
-(TEDIT.UNDO.INSERTION
-  [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE)             (* ; "Edited 21-Apr-93 01:33 by jds")
-
-    (* ;; "UNDO a prior Insert, Copy, or Include.")
-
-    (PROG (OBJ DELETEFN)
-          (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; 
-          "Keep TEdit from reusing the current cache piece in the future -- it is probably invalid")
-          (\DELETECH CH# (IPLUS CH# LEN)
-                 LEN TEXTOBJ)
-          (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ)
-                 (fetch (TEXTOBJ SEL) of TEXTOBJ)
-                 CH#
-                 (IPLUS CH# LEN)
-                 TEXTOBJ)                                    (* ; 
-                                                           "Fix the line descriptors & selection")
-          (TEDIT.UPDATE.SCREEN TEXTOBJ)                      (* ; 
-                                                         "Fix up the display for all this foofaraw")
-          (replace (SELECTION POINT) of (fetch (TEXTOBJ SEL) of TEXTOBJ)
-             with 'LEFT)
-          (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ)
-                 TEXTOBJ)                                    (* ; "Really fix the selection")
-          (replace THACTION of EVENT with 'Delete)
-                                                             (* ; 
-                                  "Make the UNDO be UNDOable, by changing the event to a deletion.")
-      ])
-
-(TEDIT.UNDO.DELETION
-  [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE)             (* ; "Edited 21-Apr-93 12:01 by jds")
-
-    (* ;; "UNDO a prior Deletion of text.")
-
-    (PROG ((NPC (fetch (PIECE NEXTPIECE) of FIRSTPIECE))
-           (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-           (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-           (OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-           NEWPIECE INSPC OBJECT INSERTFN START-OF-PIECE)
-          (SETQ INSPC (\CHTOPC CH# PCTB T))
-          (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; 
-  "Keep future people from stepping on the current cache piece, which is probably no longer valid.")
-          (COND
-             ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)
-                                                             (* ; 
-                                                           "Don't change read-only documents.")
-              (RETURN)))
-          [COND
-             ((IGREATERP CH# START-OF-PIECE)
-              (SETQ INSPC (\SPLITPIECE INSPC (- CH# START-OF-PIECE)
-                                 TEXTOBJ INSPC#]
-          (SETQ NEWPIECE (create PIECE using FIRSTPIECE))
-          (replace THFIRSTPIECE of EVENT with NEWPIECE)
-          (bind (TL _ 0) while (ILESSP TL LEN) do (\INSERTPIECE NEWPIECE INSPC TEXTOBJ) 
-                                                             (* ; "Insert the piece back in")
-                                                             [COND
-                                                                ([AND (SETQ OBJECT
-                                                                       (fetch (PIECE POBJ)
-                                                                          of NEWPIECE))
-                                                                      (SETQ INSERTFN
-                                                                       (IMAGEOBJPROP OBJECT
-                                                                              'WHENINSERTEDFN]
-                                                             (* ; 
-                                      "If this is an imageobject, and it has an insertfn, call it.")
-                                                                 (APPLY* INSERTFN OBJECT (
-                                                                                      \TEDIT.PRIMARYW
-                                                                                          TEXTOBJ)
-                                                                        NIL
-                                                                        (TEXTSTREAM TEXTOBJ]
-                                                             (SETQ TL (IPLUS TL (fetch
-                                                                                 (PIECE PLEN)
-                                                                                   of FIRSTPIECE)
-                                                                             )) 
-                                                             (* ; 
-                                                         "Keep track of how much we've re-inserted")
-                                                             (SETQ FIRSTPIECE NPC) 
-                                                             (* ; 
-                                                           "Move to the next piece to insert")
-                                                             (AND NPC (SETQ NPC (fetch
-                                                                                 (PIECE NEXTPIECE)
-                                                                                   of NPC)))
-                                                             (SETQ NEWPIECE (create PIECE
-                                                                               using FIRSTPIECE))
-                 )                                           (* ; 
-                                       "Done here because \INSERTPIECE creams the NEXTPIECE field.")
-          (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IPLUS (fetch (TEXTOBJ TEXTLEN)
-                                                                           of TEXTOBJ)
-                                                                        LEN))
-                                                             (* ; 
-                                            "Reset the text length and EOF ptr of the text stream.")
-          (\FIXILINES TEXTOBJ SEL CH# LEN OTEXTLEN)          (* ; 
-                                                           "Fix the line descriptors & selection")
-          (TEDIT.UPDATE.SCREEN TEXTOBJ)                      (* ; 
-                                                         "Fix up the display for all this foofaraw")
-          (replace (SELECTION CH#) of SEL with CH#)
-                                                             (* ; 
-                                                 "Make the selection point at the re-inserted text")
-          (replace (SELECTION CHLIM) of SEL with (IPLUS CH# LEN))
-          (replace (SELECTION DCH) of SEL with LEN)
-          (replace (SELECTION POINT) of SEL with (fetch THPOINT of EVENT))
-          (\TEDIT.SET.SEL.LOOKS SEL 'NORMAL)
-          (\FIXSEL SEL TEXTOBJ)                              (* ; "Really fix the selection")
-          (replace THACTION of EVENT with 'Insert)
-                                                             (* ; 
-                                 "Make the UNDO be UNDOable, by changing the event to a insertion.")
-      ])
-
-(TEDIT.REDO
-  [LAMBDA (TEXTOBJ)                                      (* ; "Edited 30-May-91 21:27 by jds")
-
-    (* ;; "REDO the last thing this guy did.")
-
-    (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-           EVENT CH)
-          (COND
-             ((FETCH (TEXTOBJ TXTREADONLY) OF TEXTOBJ)
-
-              (* ;; "The document is read-only; don't make any changes.")
-
-              NIL)
-             ((SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ))
-                                                             (* ; 
-                                          "There really is something to REDO Decide what, & do it.")
-              (RESETLST
-                  (RESETSAVE (CURSOR WAITINGCURSOR))
-                  (\SHOWSEL SEL NIL NIL)
-                  (SELECTQ (fetch THACTION of EVENT)
-                      ((Insert Copy Include)                 (* ; "It was an insertion")
-                           (TEDIT.REDO.INSERTION TEXTOBJ EVENT
-                                  (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of SEL)
-                                              (LEFT (fetch (SELECTION CH#) of SEL))
-                                              (RIGHT (fetch (SELECTION CHLIM) of SEL))
-                                              NIL))))
-                      (Delete                                (* ; "It was a deletion")
-                              (\TEDIT.DELETE SEL TEXTOBJ))
-                      (Replace                               (* ; 
-                                                        "It was a replacement (a del/insert combo)")
-                               (TEDIT.REDO.REPLACE TEXTOBJ EVENT))
-                      (LowerCase                             (* ; "He lower-cased something")
-                                 (\TEDIT.LCASE.SEL TEXTOBJ TEXTOBJ SEL))
-                      (UpperCase                             (* ; "He upper-cased something")
-                                 (\TEDIT.LCASE.SEL TEXTOBJ TEXTOBJ SEL))
-                      (Looks                                 (* ; "It was a looks change")
-                             (TEDIT.REDO.LOOKS TEXTOBJ EVENT (IMAX 1
-                                                                   (SELECTQ (fetch (SELECTION
-                                                                                        POINT)
-                                                                               of SEL)
-                                                                       (LEFT (fetch (SELECTION
-                                                                                         CH#)
-                                                                                of SEL))
-                                                                       (RIGHT (fetch (SELECTION
-                                                                                          CHLIM)
-                                                                                 of SEL))
-                                                                       NIL))))
-                      (ParaLooks                             (* ; "It was a Paragraph looks change")
-                                 (TEDIT.REDO.PARALOOKS TEXTOBJ EVENT
-                                        (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of SEL)
-                                                    (LEFT (fetch (SELECTION CH#) of SEL))
-                                                    (RIGHT (fetch (SELECTION CHLIM) of SEL))
-                                                    NIL))))
-                      (Find                                  (* ; "EXACT-MATCH SEARCH COMMAND")
-                            (RESETLST
-                                (RESETSAVE (CURSOR WAITINGCURSOR))
-                                (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T)
-                                (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-                                (\SHOWSEL SEL NIL NIL)
-                                (SETQ CH (TEDIT.FIND TEXTOBJ (fetch THAUXINFO of EVENT)))
-                                (COND
-                                   (CH (TEDIT.PROMPTPRINT TEXTOBJ "done.")
-                                       (replace (SELECTION CH#) of SEL with CH)
-                                       [replace (SELECTION CHLIM) of SEL
-                                          with (IPLUS CH (NCHARS (fetch THAUXINFO
-                                                                        of EVENT]
-                                       (replace (SELECTION DCH) of SEL
-                                          with (NCHARS (fetch THAUXINFO of EVENT)))
-                                       (replace (SELECTION POINT) of SEL with
-                                                                                 'RIGHT)
-                                       (\FIXSEL SEL TEXTOBJ)
-                                       (TEDIT.NORMALIZECARET TEXTOBJ)
-                                       (\SHOWSEL SEL NIL T))
-                                   (T (TEDIT.PROMPTPRINT TEXTOBJ "[Not found]"))))
-                            (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; "Drop the cached piece.  WHY??")
-                            )
-                      ((Move ReplaceMove)                    (* ; "He moved some text")
-                           (TEDIT.REDO.MOVE TEXTOBJ EVENT (fetch THLEN of EVENT)
-                                  (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of SEL)
-                                              (LEFT (fetch (SELECTION CH#) of SEL))
-                                              (RIGHT (fetch (SELECTION CHLIM) of SEL))
-                                              NIL))
-                                  (fetch THFIRSTPIECE of EVENT)))
-                      (Get                                   (* ; "He did a GET -- not undoable.")
-                           (TEDIT.PROMPTPRINT TEXTOBJ "You can't REDO a GET." T))
-                      (Put                                   (* ; "He did a PUT -- not undoable.")
-                           (TEDIT.PROMPTPRINT TEXTOBJ "You can't REDO a PUT." T))
-                      (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "REDO of the action " (fetch THACTION
-                                                                                  of EVENT)
-                                                        " isn't implemented.")
-                             T))
-                  (\SHOWSEL SEL NIL T)))
-             (T (TEDIT.PROMPTPRINT TEXTOBJ "Nothing to REDO." T])
-
-(TEDIT.REDO.INSERTION
-  [LAMBDA (TEXTOBJ EVENT CH#)                 (* ; 
-                                                "Edited  3-Apr-95 15:55 by sybalsky:mv:envos")
-                                                             (* ; 
-                                                        "REDO a prior Insert/Copy/Include of text.")
-    (PROG (INSPC INSPC# NPC (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-                 (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-                 (LEN (fetch THLEN of EVENT))
-                 (FIRSTPIECE (create PIECE using (CAR (fetch THFIRSTPIECE of EVENT))
-                                                     PNEW _ T))
-                 (OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-                 OBJ COPYFN ORIGFIRSTPC)
-          (SETQ ORIGFIRSTPC FIRSTPIECE)
-          (replace THFIRSTPIECE of EVENT with (LIST FIRSTPIECE))
-                                                             (* ; 
-                                         "So we can UNDO this, and remove the right set of pieces.")
-          (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; 
-                                                 "Force any further insertions to make new pieces.")
-          (SETQ NPC (fetch (PIECE NEXTPIECE) of FIRSTPIECE))
-          (SETQ INSPC (\CHTOPC CH# PCTB T))
-          [SETQ INSPC (COND
-                         ((IEQP CH# START-OF-PIECE)          (* ; 
-                                                    "We're inserting just before an existing piece")
-                          INSPC)
-                         (T                                  (* ; 
-                                     "We must split this piece, and insert before the second part.")
-                            (\SPLITPIECE INSPC (- CH# START-OF-PIECE)
-                                   TEXTOBJ]
-          (bind (TL _ 0) while (ILESSP TL LEN)
-             do 
-
-                   (* ;; "Loop thru the pieces of the prior insertion, inserting copies of enough of them to cover the length of the insertion.")
-
-                   [COND
-                      ((SETQ OBJ (fetch (PIECE POBJ) of FIRSTPIECE))
-                                                             (* ; "This piece describes an object")
-                       [COND
-                          [(SETQ COPYFN (IMAGEOBJPROP OBJ 'COPYFN))
-                           (SETQ OBJ (APPLY* COPYFN OBJ (fetch (TEXTOBJ STREAMHINT) of 
-                                                                                              TEXTOBJ
-                                                               )
-                                            (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)))
-                           (COND
-                              ((EQ OBJ 'DON'T)
-                               (TEDIT.PROMPTPRINT TEXTOBJ "COPY of this object not allowed." T)
-                               (RETFROM 'TEDIT.COPY))
-                              (T (replace (PIECE POBJ) of FIRSTPIECE with OBJ]
-                          (OBJ (replace (PIECE POBJ) of FIRSTPIECE with (COPY OBJ]
-                       (COND
-                          ((SETQ COPYFN (IMAGEOBJPROP OBJ 'WHENCOPIEDFN))
-                                                             (* ; 
-                                                       "If there's an eventfn for copying, use it.")
-                           (APPLY* COPYFN OBJ (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW)
-                                                                  of TEXTOBJ))
-                                                     'DSP)
-                                  (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)
-                                  (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ]
-                   (\INSERTPIECE FIRSTPIECE INSPC TEXTOBJ)   (* ; "Insert the piece back in")
-                   (SETQ TL (IPLUS TL (fetch (PIECE PLEN) of FIRSTPIECE))) 
-                                                             (* ; 
-                                                         "Keep track of how much we've re-inserted")
-                   (SETQ FIRSTPIECE (create PIECE using NPC PNEW _ T)) 
-                                                             (* ; 
-                                                           "Move to the next piece to insert")
-                   (AND NPC (SETQ NPC (fetch (PIECE NEXTPIECE) of NPC))) 
-                                                             (* ; 
-                                       "Done here because \INSERTPIECE creams the NEXTPIECE field.")
-                 )
-          (\TEDIT.DIFFUSE.PARALOOKS (fetch (PIECE PREVPIECE) of ORIGFIRSTPC)
-                 INSPC)                                      (* ; 
-                                            "propagate paragraph formatting into the new insertion")
-          (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IPLUS (fetch (TEXTOBJ TEXTLEN)
-                                                                           of TEXTOBJ)
-                                                                        LEN))
-                                                             (* ; 
-                                            "Reset the text length and EOF ptr of the text stream.")
-          (\FIXILINES TEXTOBJ SEL CH# LEN OTEXTLEN)          (* ; 
-                                                           "Fix the line descriptors & selection")
-          (TEDIT.UPDATE.SCREEN TEXTOBJ)                      (* ; 
-                                                         "Fix up the display for all this foofaraw")
-          (replace (SELECTION CH#) of SEL with CH#)
-                                                             (* ; 
-                                                 "Make the selection point at the re-inserted text")
-          (replace (SELECTION CHLIM) of SEL with (IPLUS CH# LEN))
-          (replace (SELECTION DCH) of SEL with LEN)
-          (\TEDIT.SET.SEL.LOOKS SEL 'NORMAL)
-          (\FIXSEL SEL TEXTOBJ)                              (* ; "Really fix the selection")
-          (replace THACTION of EVENT with 'Insert)
-                                                             (* ; 
-                                 "Make the UNDO be UNDOable, by changing the event to a insertion.")
-      ])
-
-(TEDIT.UNDO.MOVE
-  [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE)             (* ; "Edited 30-May-91 21:27 by jds")
-                                                             (* ; "UNDO a MOVE command")
-    (PROG ((TOOBJ (fetch THAUXINFO of EVENT))
-           (FROMOBJ (fetch THTEXTOBJ of EVENT))
-           (SOURCECH# (fetch THOLDINFO of EVENT))
-           (CH# (fetch THCH# of EVENT))
-           TOSEL TOTEXTLEN)
-          (\SHOWSEL (fetch (TEXTOBJ SEL) of TOOBJ)
-                 NIL NIL)                                    (* ; 
-                                   "Turn off the selections in the old source and target documents")
-          (\SHOWSEL (fetch (TEXTOBJ SEL) of FROMOBJ)
-                 NIL NIL)
-          (\DELETECH CH# (IPLUS CH# LEN)
-                 LEN FROMOBJ)                                (* ; 
-                                  "Delete the characters we moved, from the place we moved them to")
-          (\FIXDLINES (fetch (TEXTOBJ LINES) of FROMOBJ)
-                 (fetch (TEXTOBJ SEL) of FROMOBJ)
-                 CH#
-                 (IPLUS CH# LEN)
-                 FROMOBJ)
-          (replace (SELECTION CH#) of (fetch (TEXTOBJ SEL) of FROMOBJ)
-             with (replace (SELECTION CHLIM) of (fetch (TEXTOBJ SEL) of FROMOBJ)
-                         with CH#))                      (* ; 
-                  "Make this document's selection be a point sel at the place the text used to be.")
-          (replace (SELECTION DCH) of (fetch (TEXTOBJ SEL) of FROMOBJ) with
-                                                                                       0)
-          (replace (SELECTION POINT) of (fetch (TEXTOBJ SEL) of FROMOBJ)
-             with 'LEFT)                                 (* ; 
-                                                     "Mark lines for update, and fix the selection")
-          (SETQ TOTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TOOBJ))
-                                                             (* ; 
-          "The pre-insertion len of the place the text is returning to, for the line udpater below")
-          (\TEDIT.INSERT.PIECES TOOBJ SOURCECH# (fetch THFIRSTPIECE of EVENT)
-                 LEN)
-
-     (* ;; "Put the pieces we moved back where they came from (no need to copy them, since we did that on the original move.)")
-
-          (\FIXILINES TOOBJ (fetch (TEXTOBJ SEL) of TOOBJ)
-                 SOURCECH# LEN TOTEXTLEN)                    (* ; 
-                                          "Mark lines that need updating, and fix up the selection")
-          (add (fetch (TEXTOBJ TEXTLEN) of TOOBJ)
-                 LEN)                                        (* ; 
-                                              "Update the text length of the erstwhile move source")
-          (TEDIT.UPDATE.SCREEN FROMOBJ)                      (* ; 
-                                                      "Update the erstwhile text location's image.")
-          (COND
-             ((NEQ FROMOBJ TOOBJ)                            (* ; 
-            "If they aren't the same document, we need to update the other document image as well.")
-              (TEDIT.UPDATE.SCREEN TOOBJ)))
-          (\FIXSEL (fetch (TEXTOBJ SEL) of TOOBJ)
-                 TOOBJ)                                      (* ; 
-                                                 "Fix up the selections so their images will be OK")
-          (\FIXSEL (fetch (TEXTOBJ SEL) of FROMOBJ)
-                 FROMOBJ)
-          (\COPYSEL (fetch (TEXTOBJ SEL) of FROMOBJ)
-                 TEDIT.SELECTION)                            (* ; 
-                                    "It's handy to think of this as the last selection made, also.")
-          (replace THACTION of EVENT with 'Move)
-          (replace THTEXTOBJ of EVENT with TOOBJ)
-          (replace THAUXINFO of EVENT with FROMOBJ)
-          (replace THOLDINFO of EVENT with CH#)
-          (replace THCH# of EVENT with SOURCECH#)
-          (\SHOWSEL (fetch (TEXTOBJ SEL) of TOOBJ)
-                 NIL T)
-          (\SHOWSEL (fetch (TEXTOBJ SEL) of FROMOBJ)
-                 NIL T])
-
-(TEDIT.UNDO.REPLACE
-  [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE)  (* ; 
-                                                "Edited 22-Mar-95 16:47 by sybalsky:mv:envos")
-    (PROG ((OLDEVENT (fetch THOLDINFO of EVENT))
-           (CH# (fetch THCH# of EVENT))
-           (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)))
-          (\SHOWSEL SEL NIL NIL)
-          (TEDIT.UNDO.INSERTION TEXTOBJ EVENT LEN CH# FIRSTPIECE)
-          (\SHOWSEL SEL NIL NIL)
-          (TEDIT.UNDO.DELETION TEXTOBJ OLDEVENT (fetch THLEN of OLDEVENT)
-                 CH#
-                 (CAR (fetch THFIRSTPIECE of OLDEVENT)))
-          (replace THOLDINFO of OLDEVENT with EVENT)
-          (replace THACTION of OLDEVENT with 'Replace)
-          (replace THOLDINFO of EVENT with NIL)
-          (\TEDIT.HISTORYADD TEXTOBJ OLDEVENT)
-          (replace (SELECTION CH#) of SEL with CH#)
-          (replace (SELECTION CHLIM) of SEL with (IPLUS CH# (fetch THLEN of
-                                                                                         OLDEVENT)))
-          (replace (SELECTION DCH) of SEL with (fetch THLEN of OLDEVENT))
-          (replace (SELECTION POINT) of SEL with (fetch THPOINT of EVENT))
-          (replace THPOINT of OLDEVENT with (fetch THPOINT of EVENT))
-          (\FIXSEL SEL TEXTOBJ)
-          (\SHOWSEL SEL NIL T])
-
-(TEDIT.REDO.REPLACE
-  [LAMBDA (TEXTOBJ EVENT)                                (* ; "Edited 30-May-91 21:28 by jds")
-    (PROG ((OLDEVENT (fetch THOLDINFO of EVENT))
-           (CH# (fetch (SELECTION CH#) of (fetch (TEXTOBJ SEL) of TEXTOBJ)))
-           (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)))
-          (\SHOWSEL SEL NIL NIL)
-          (\DELETECH (fetch (SELECTION CH#) of SEL)
-                 (fetch (SELECTION CHLIM) of SEL)
-                 (IDIFFERENCE (fetch (SELECTION CHLIM) of SEL)
-                        (fetch (SELECTION CH#) of SEL))
-                 TEXTOBJ)
-          (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ)
-                 SEL
-                 (fetch (SELECTION CH#) of SEL)
-                 (fetch (SELECTION CHLIM) of SEL)
-                 TEXTOBJ)
-          (replace (SELECTION POINT) of SEL with 'LEFT)
-          (TEDIT.REDO.INSERTION TEXTOBJ EVENT CH#)
-          (replace THOLDINFO of EVENT with (SETQ OLDEVENT (fetch (TEXTOBJ TXTHISTORY)
-                                                                         of TEXTOBJ)))
-          (replace THACTION of OLDEVENT with 'Replace)
-          (replace THACTION of EVENT with 'Replace)
-          (replace THCH# of EVENT with CH#)
-          (\TEDIT.HISTORYADD TEXTOBJ EVENT])
-
-(TEDIT.REDO.MOVE
-  [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE)             (* ; "Edited 30-May-91 21:28 by jds")
-    (PROG ((FROMOBJ TEXTOBJ)
-           (SOURCECH# (fetch THOLDINFO of EVENT))
-           (OLDCH# (fetch THCH# of EVENT))
-           (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-           (MOVESEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ))
-           OLDCHLIM)
-          (replace (SELECTION CH#) of MOVESEL with OLDCH#)
-          (replace (SELECTION CHLIM) of MOVESEL with (IPLUS OLDCH# LEN))
-          (replace (SELECTION DCH) of MOVESEL with LEN)
-          (replace (SELECTION SET) of MOVESEL with T)
-          (\FIXSEL MOVESEL TEXTOBJ)
-          (\TEDIT.SET.SEL.LOOKS MOVESEL 'MOVE)
-          (TEDIT.MOVE MOVESEL SEL])
-)
-(PUTPROPS TEDITHISTORY COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1990 1991 1993 
-1995))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1696 5135 (\TEDIT.HISTORYADD 1706 . 3591) (\TEDIT.CUMULATE.EVENTS 3593 . 5133)) (5188 
-38576 (TEDIT.UNDO 5198 . 9210) (TEDIT.UNDO.INSERTION 9212 . 10798) (TEDIT.UNDO.DELETION 10800 . 16735)
- (TEDIT.REDO 16737 . 23674) (TEDIT.REDO.INSERTION 23676 . 30392) (TEDIT.UNDO.MOVE 30394 . 34827) (
-TEDIT.UNDO.REPLACE 34829 . 36330) (TEDIT.REDO.REPLACE 36332 . 37757) (TEDIT.REDO.MOVE 37759 . 38574)))
-))
-STOP
diff --git a/obsolete/library/new/TEDITHISTORY.LCOM b/obsolete/library/new/TEDITHISTORY.LCOM
deleted file mode 100644
index a7cdd2f6..00000000
Binary files a/obsolete/library/new/TEDITHISTORY.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITLOOKS.LCOM b/obsolete/library/new/TEDITLOOKS.LCOM
deleted file mode 100644
index a214e28f..00000000
Binary files a/obsolete/library/new/TEDITLOOKS.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITMENU b/obsolete/library/new/TEDITMENU
deleted file mode 100644
index 70d40cc7..00000000
--- a/obsolete/library/new/TEDITMENU
+++ /dev/null
@@ -1,4538 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "24-Apr-95 15:10:41" {DSK}<lispcore>library>new>TEDITMENU.;1 275626 
-
-      changes to%:  (FNS \TEDIT.TABTYPE.SET)
-
-      previous date%: "25-Aug-94 10:54:56" {DSK}<king>export>lispcore>library>TEDITMENU.;4)
-
-
-(* ; "
-Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT TEDITMENUCOMS)
-
-(RPAQQ TEDITMENUCOMS
-       [(FILES TEDITDCL)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
-               (FILES (LOADCOMP)
-                      TEDITDCL))
-        [COMS                                                (* ; "Simple Menu Button support")
-              (FNS MB.BUTTONEVENTINFN MB.DISPLAY MB.SETIMAGE MB.SELFN MB.SIZEFN MB.WHENOPERATEDFN 
-                   MB.COPYFN MB.GETFN MB.PUTFN MB.SHOWSELFN MBUTTON.CREATE MBUTTON.CHANGENAME 
-                   MBUTTON.FIND.BUTTON MBUTTON.FIND.NEXT.BUTTON MBUTTON.FIND.NEXT.FIELD MBUTTON.INIT
-                   MBUTTON.NEXT.FIELD.AS.NUMBER MBUTTON.NEXT.FIELD.AS.PIECES 
-                   MBUTTON.NEXT.FIELD.AS.TEXT MBUTTON.NEXT.FIELD.AS.ATOM MBUTTON.SET.FIELD 
-                   MBUTTON.SET.NEXT.FIELD MBUTTON.SET.NEXT.BUTTON.STATE TEDITMENU.STREAM 
-                   \TEDITMENU.SELSCREENER)
-              (GLOBALVARS MBUTTONIMAGEFNS)
-              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MBUTTON.INIT))
-                     (ADDVARS (IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN]
-        [COMS 
-              (* ;; 
-            "Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD")
-
-              (FNS MB.CREATE.THREESTATEBUTTON MB.THREESTATE.DISPLAY MB.THREESTATE.SHOWSELFN 
-                   MB.THREESTATE.WHENOPERATEDFN MB.THREESTATEBUTTON.FN THREESTATE.INIT)
-              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (THREESTATE.INIT]
-        [COMS                                                (* ; "One-of-N Menu button sets")
-              (FNS MB.CREATE.NWAYBUTTON MB.NB.DISPLAYFN MB.NB.WHENOPERATEDFN MB.NB.SIZEFN 
-                   MB.NWAYBUTTON.SELFN MB.NWAYMENU.NEWBUTTON NWAYBUTTON.INIT MB.NB.PACKITEMS 
-                   MB.NWAYBUTTON.ADDITEM)
-              (GLOBALVARS NWAYBUTTONIMAGEFNS)
-              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (NWAYBUTTON.INIT))
-                     (ADDVARS (IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN]
-        [COMS 
-              (* ;; "Two-state, toggling menu buttons.")
-
-              (FNS \TEXTMENU.TOGGLE.CREATE \TEXTMENU.TOGGLE.DISPLAY \TEXTMENU.TOGGLE.SHOWSELFN 
-                   \TEXTMENU.TOGGLE.WHENOPERATEDFN \TEXTMENU.TOGGLEFN \TEXTMENU.TOGGLE.INIT 
-                   \TEXTMENU.SET.TOGGLE)
-              (GLOBALVARS \TOGGLEIMAGEFNS)
-              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTMENU.TOGGLE.INIT))
-                     (ADDVARS (IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN]
-        [COMS 
-              (* ;; "Margin Setting and display")
-
-              (FNS DRAWMARGINSCALE MARGINBAR MARGINBAR.CREATE MB.MARGINBAR.SELFN MB.MARGINBAR.SIZEFN
-                   MB.MARGINBAR.DISPLAYFN MDESCALE MSCALE MB.MARGINBAR.SHOWTAB MB.MARGINBAR.TABTRACK
-                   \TEDIT.TABTYPE.SET MARGINBAR.INIT)
-              (BITMAPS \TEDIT.LEFTTAB \TEDIT.CENTERTAB \TEDIT.RIGHTTAB \TEDIT.DECIMALTAB 
-                     \TEDIT.DOTTED.LEFTTAB \TEDIT.DOTTED.CENTERTAB \TEDIT.DOTTED.RIGHTTAB 
-                     \TEDIT.DOTTED.DECIMALTAB TEDIT.EXTENDEDRIGHTMARK)
-              (GLOBALVARS MARGINBARIMAGEFNS)
-              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MARGINBAR.INIT))
-                     (ADDVARS (IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN]
-        (COMS 
-              (* ;; "Text menu creation and support")
-
-              (FNS \TEXTMENU.START \TEXTMENU.DOC.CREATE TEXTMENU.CLOSEFN)
-              (BITMAPS TEXTMENUICON TEXTMENUICONMASK))
-        [COMS                                                (* ; "TEdit-specific support")
-              (FNS \TEDITMENU.CREATE \TEDIT.EXPANDED.MENU MB.DEFAULTBUTTON.FN 
-                   \TEDITMENU.RECORD.UNFORMATTED MB.DEFAULTBUTTON.ACTIONFN)
-              (FNS \TEDIT.CHARLOOKSMENU.CREATE \TEDIT.EXPANDEDCHARLOOKS.MENU \TEDIT.APPLY.BOLDNESS 
-                   \TEDIT.APPLY.CHARLOOKS \TEDIT.APPLY.OLINE \TEDIT.SHOW.CHARLOOKS 
-                   \TEDIT.NEUTRALIZE.CHARLOOKS \TEDIT.FILL.IN.CHARLOOKS.MENU 
-                   \TEDIT.NEUTRALIZE.CHARLOOKS.MENU \TEDIT.PARSE.CHARLOOKS.MENU \TEDIT.APPLY.SLOPE 
-                   \TEDIT.APPLY.STRIKEOUT \TEDIT.APPLY.ULINE)
-              (FNS \TEDITPARAMENU.CREATE \TEDIT.EXPANDEDPARA.MENU \TEDIT.APPLY.PARALOOKS 
-                   \TEDIT.SHOW.PARALOOKS \TEDIT.NEUTRALIZE.PARALOOKS.MENU \TEDIT.RECORD.TABLEADERS)
-              (FNS \TEDIT.SHOW.PAGEFORMATTING \TEDITPAGEMENU.CREATE \TEDIT.APPLY.PAGEFORMATTING 
-                   TEDIT.UNPARSE.PAGEFORMAT)
-              (COMS                                          (* ; "Initialization Code")
-                    (GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU 
-                           TEDIT.MENUDIVIDER.SPEC TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC 
-                           TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC TEDIT.EXPANDED.PAGEMENU)
-                    (FNS \TEDIT.MENU.INIT)
-                    (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEDIT.MENU.INIT)
-                                                       (\TEDITMENU.CREATE)
-                                                       (\TEDIT.CHARLOOKSMENU.CREATE)
-                                                       (\TEDITPARAMENU.CREATE)
-                                                       (\TEDITPAGEMENU.CREATE]
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA])
-
-(FILESLOAD TEDITDCL)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \SCRATCHLEN 64)
-
-
-(CONSTANTS (\SCRATCHLEN 64))
-)
-
-
-(FILESLOAD (LOADCOMP)
-       TEDITDCL)
-)
-
-
-
-(* ; "Simple Menu Button support")
-
-(DEFINEQ
-
-(MB.BUTTONEVENTINFN
-  [LAMBDA (OBJ STREAM SEL RELX RELY SELWINDOW TEXTSTREAM)(* ; "Edited 30-May-91 22:15 by jds")
-
-         (* There was a buttn event inside a menu button.
-       Make sure that the button gets turned OFF when the mouse moves outside it.)
-
-    (PROG [(OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX]
-          (replace (SELECTION SELKIND) of SEL with 'VOLATILE)
-          (COND
-             ((IMAGEOBJPROP OBJ 'MENUBUTTON.SELECTED)
-
-         (* This button is still active from an earlier hit.
-       Don't let it be selected again.)
-
-              (RETURN 'DON'T))
-             ((AND (IGEQ RELX 0)
-                   (IGEQ RELY 0)
-                   (ILEQ RELX (fetch XSIZE of OBJBOX))
-                   (ILEQ RELY (fetch YSIZE of OBJBOX)))
-                                                             (* We're really inside the thing.
-                                                           Return an indication that we're to 
-                                                           be left alone.)
-              (RETURN T))
-             (T                                              (* He's moved outside the button.
-                                                           Don't permit the selection.)
-                (RETURN 'DON'T])
-
-(MB.DISPLAY
-  [LAMBDA (OBJ STREAM MODE)                              (* ; "Edited 11-Jan-89 16:58 by jds")
-
-    (* ;; "Display the innards of a menu button")
-
-    (SELECTQ (IMAGESTREAMTYPE STREAM)
-        (DISPLAY 
-                 (* ;; "Going to the display.  Use the cached bitmap version of the button")
-
-                 [PROG (BITMAP DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX))
-                              (X (DSPXPOSITION NIL STREAM))
-                              (Y (DSPYPOSITION NIL STREAM)))
-                       [SETQ BITMAP (COND
-                                       ((IMAGEOBJPROP OBJ 'BITCACHE))
-                                       (T (MB.SETIMAGE OBJ)
-                                          (IMAGEOBJPROP OBJ 'BITCACHE]
-                       [BITBLT BITMAP 0 0 STREAM X (SETQ Y (IDIFFERENCE Y (fetch YDESC
-                                                                             of OBJBOX]
-                                                             (* ; "Display the button's image")
-                       (COND
-                          ((EQ (IMAGEOBJPROP OBJ 'STATE)
-                               'ON)                          (* ; 
-                                                           "If the button is ON, mark it so.")
-                           (BITBLT NIL 0 0 STREAM X Y (fetch XSIZE of OBJBOX)
-                                  (fetch YSIZE of OBJBOX)
-                                  'TEXTURE
-                                  'INVERT BLACKSHADE])
-        (PROG (BITMAP DS (FONT (IMAGEOBJPROP OBJ 'MBFONT))
-                     (TEXT (IMAGEOBJPROP OBJ 'MBTEXT))
-                     OLOOKS)                                 (* ; 
-                                         "Going to some output image stream.  Use the actual text.")
-              (SETQ OLOOKS (DSPFONT (FONTCOPY FONT 'DEVICE STREAM)
-                                  STREAM))                   (* ; 
-                                                         "Change to the font for this menu button.")
-              (PRIN1 TEXT STREAM)                            (* ; "Print the button text")
-              (DSPFONT OLOOKS STREAM)                        (* ; 
-                                                           "And put the font back as it was.")
-          ])
-
-(MB.SETIMAGE
-  [LAMBDA (OBJ)                                              (* jds "23-Aug-84 13:22")
-    (PROG ((MBFONT (IMAGEOBJPROP OBJ 'MBFONT))
-           (MBTEXT (IMAGEOBJPROP OBJ 'MBTEXT))
-           BOX BITMAP DS)
-          (SETQ BOX (create IMAGEBOX
-                           XSIZE _ (STRINGWIDTH MBTEXT MBFONT)
-                           YSIZE _ (FONTPROP MBFONT 'HEIGHT)
-                           YDESC _ (FONTPROP MBFONT 'DESCENT)
-                           XKERN _ 0))
-          (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of BOX)
-                              (fetch YSIZE of BOX)))
-          (IMAGEOBJPROP OBJ 'BITCACHE BITMAP)
-          (IMAGEOBJPROP OBJ 'BOUNDBOX BOX)
-          (SETQ DS (DSPCREATE BITMAP))
-          (DSPXOFFSET 0 DS)
-          (DSPYOFFSET 0 DS)
-          (DSPFONT MBFONT DS)
-          (MOVETO 0 (FONTPROP MBFONT 'DESCENT)
-                 DS)
-          (PRIN1 MBTEXT DS)
-          (RETURN OBJ])
-
-(MB.SELFN
-  [LAMBDA (OBJ SEL W FN)                                 (* ; "Edited 30-May-91 22:15 by jds")
-                                                             (* Calls a menu-button's associated 
-                                                           function, then turns off the 
-                                                           highlighting of the menu button.)
-    (PROG [(TSEL (create SELECTION))
-           (BUTTONFN (OR FN (IMAGEOBJPROP OBJ 'MBFN]
-          (\COPYSEL SEL TSEL)                                (* Save the selection that points to 
-                                                           the menu button.)
-          (replace (SELECTION SELKIND) of SEL with 'CHAR)
-          (replace (SELECTION SET) of SEL with NIL)
-          (replace (SELECTION ONFLG) of SEL with NIL)
-                                                             (* Call the button's function)
-          (COND
-             ((NEQ (AND BUTTONFN (APPLY* BUTTONFN OBJ SEL W))
-                   'DON'T)                                   (* If the button fn left the 
-                                                           selection alone,)
-              (\FIXSEL TSEL (fetch (SELECTION \TEXTOBJ) of TSEL))
-              (\SHOWSEL TSEL NIL NIL)))                      (* Turn off the button hilite)
-      ])
-
-(MB.SIZEFN
-  [LAMBDA (OBJ STREAM CURX RIGHTMARGIN)                      (* jds "30-Aug-84 11:24")
-                                                             (* Tell the size of a menu button)
-    (PROG ((FONT (IMAGEOBJPROP OBJ 'MBFONT))
-           BOX)
-          [COND
-             ((DISPLAYSTREAMP STREAM)                        (* We're formatting for the DISPLAY)
-              )
-             [(EQ 'INTERPRESS (IMAGESTREAMTYPE STREAM))
-              (SETQ FONT (FONTCOPY FONT 'DEVICE 'INTERPRESS]
-             ((EQ 'PRESS (IMAGESTREAMTYPE STREAM))
-              (SETQ FONT (FONTCOPY FONT 'DEVICE 'PRESS]
-          (SETQ BOX (create IMAGEBOX
-                           XSIZE _ (STRINGWIDTH (IMAGEOBJPROP OBJ 'MBTEXT)
-                                          FONT)
-                           YSIZE _ (FONTPROP FONT 'HEIGHT)
-                           YDESC _ (FONTPROP FONT 'DESCENT)
-                           XKERN _ 0))
-          (IMAGEOBJPROP OBJ 'BOUNDBOX BOX)
-          (RETURN BOX])
-
-(MB.WHENOPERATEDFN
-  [LAMBDA (OBJ DS OPERATION SEL)                             (* jds " 7-Feb-84 14:20")
-    (SELECTQ OPERATION
-        (HIGHLIGHTED (MB.SHOWSELFN OBJ SEL T DS))
-        (UNHIGHLIGHTED (MB.SHOWSELFN OBJ SEL NIL DS))
-        (SELECTED (MB.SELFN OBJ SEL DS))
-        (DESELECTED)
-        NIL])
-
-(MB.COPYFN
-  [LAMBDA (OBJ)                                              (* jds "23-May-84 11:32")
-                                                             (* Copy a menu button object.)
-    (create IMAGEOBJ
-           OBJECTDATUM _ (COPY (fetch (IMAGEOBJ OBJECTDATUM) of OBJ))
-           IMAGEOBJPLIST _ (COPY (fetch (IMAGEOBJ IMAGEOBJPLIST) of OBJ))
-           IMAGEOBJFNS _ (fetch (IMAGEOBJ IMAGEOBJFNS) of OBJ])
-
-(MB.GETFN
-  [LAMBDA (OBJ FILE)                                         (* ; "Edited 20-Aug-87 16:17 by jds")
-                                                             (* READ a menu button from a file.)
-    (ERROR)
-    (PROG [(TEXT (IMAGEOBJPROP OBJ 'MBTEXT))
-           (MBFN (IMAGEOBJPROP OBJ 'MBFN))
-           (FONT (IMAGEOBJPROP OBJ 'MBFONT]
-          (\STRINGOUT FILE TEXT)
-          (\ATMOUT FILE MBFN)
-          (\ATMOUT FILE (FONTPROP FONT 'FAMILY))
-          (\SMALLPOUT FILE (FONTPROP FONT 'SIZE))
-          (for ATTR in (FONTPROP FONT 'FACE) do (\ATMOUT FILE ATTR])
-
-(MB.PUTFN
-  [LAMBDA (OBJ FILE)                                         (* ; "Edited 20-Aug-87 16:17 by jds")
-          
-          (* ;; 
-          "Write a menu button from a file; suitable for re-reading using the image objects GETFN.")
-
-    (PROG [(TEXT (IMAGEOBJPROP OBJ 'MBTEXT))
-           (MBFN (IMAGEOBJPROP OBJ 'MBFN))
-           (FONT (IMAGEOBJPROP OBJ 'MBFONT]
-          (HELP)
-          (\STRINGOUT FILE TEXT)                             (* ; "The button's image")
-
-          (\ATMOUT FILE MBFN)                                (* ; "The FN called when hit")
-
-          (\ATMOUT FILE (FONTPROP FONT 'FAMILY))
-          (\SMALLPOUT FILE (FONTPROP FONT 'SIZE))
-          (for ATTR in (FONTPROP FONT 'FACE) do (\ATMOUT FILE ATTR])
-
-(MB.SHOWSELFN
-  [LAMBDA (OBJ SEL ON DS)                                (* ; "Edited 11-Jan-89 16:35 by jds")
-    (LET [(OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX]
-         (OR (IMAGEOBJPROP OBJ 'BITCACHE)
-             (MB.DISPLAY OBJ))                           (* ; 
-                                                           "MAKE SURE THE DISPLAY FORM EXISTS")
-         (BITBLT (IMAGEOBJPROP OBJ 'BITCACHE)
-                0 0 DS 0 0 (fetch (IMAGEBOX XSIZE) of OBJBOX)
-                (fetch (IMAGEBOX YSIZE) of OBJBOX)
-                'INPUT
-                'REPLACE)
-         (COND
-            ((OR ON (EQ (IMAGEOBJPROP OBJ 'STATE)
-                        'ON))
-             (BITBLT NIL 0 (fetch (IMAGEBOX YDESC) of OBJBOX)
-                    DS 0 0 (fetch (IMAGEBOX XSIZE) of OBJBOX)
-                    (fetch (IMAGEBOX YSIZE) of OBJBOX)
-                    'TEXTURE
-                    'INVERT BLACKSHADE])
-
-(MBUTTON.CREATE
-  [LAMBDA (MBTEXT MBFN MBFONT IMAGEFNS)                  (* ; "Edited 11-Jan-89 16:10 by jds")
-
-    (* ;; "Create a MENU BUTTON image object, and fill in its image and function-hook fields")
-
-    (LET* ([REAL-FONT (OR MBFONT (FONTCLASSCOMPONENT DEFAULTFONT 'DISPLAY]
-           (OBJ (IMAGEOBJCREATE NIL (OR IMAGEFNS MBUTTONIMAGEFNS)))
-           (BOX (create IMAGEBOX
-                       XSIZE _ (STRINGWIDTH MBTEXT REAL-FONT)
-                       YSIZE _ (FONTPROP REAL-FONT 'HEIGHT)
-                       YDESC _ (FONTPROP REAL-FONT 'DESCENT)
-                       XKERN _ 0))
-           BITMAP DS)
-          (IMAGEOBJPROP OBJ 'MBFN MBFN)                      (* ; 
-                                              "The function to be called when the button is pushed")
-          (IMAGEOBJPROP OBJ 'MBTEXT MBTEXT)                  (* ; 
-                                                           "The text displayed in the button")
-          (IMAGEOBJPROP OBJ 'MBFONT REAL-FONT)               (* ; "The font that text appears in")
-          (MB.SETIMAGE OBJ)                              (* ; 
-                               "Set up the image for the button, so we don't create it repeatedly.")
-          OBJ])
-
-(MBUTTON.CHANGENAME
-  [LAMBDA (TEXTOBJ OBJ NEWNAME)                              (* jds "23-Aug-84 13:26")
-          
-          (* Change the text that appears in a button, and redisplay the button if it's 
-          visible)
-
-    (PROG (BOX BITMAP DS)
-          (IMAGEOBJPROP OBJ 'MBTEXT NEWNAME)
-          (MB.SETIMAGE OBJ)
-          (TEDIT.OBJECT.CHANGED TEXTOBJ OBJ])
-
-(MBUTTON.FIND.BUTTON
-  [LAMBDA (LABEL TEXTSTREAM CH#)                         (* ; "Edited 22-Apr-93 15:40 by jds")
-                                                             (* "27-Sep-84 00:52" gbn)
-
-         (* * returns the piece no containing the imageobj with MBTEXT prop LABEL)
-
-    (PROG ((LABELATOM (MKATOM LABEL))
-           OBJ STARTPCNO (PCTB (fetch (TEXTOBJ PCTB) of (TEXTOBJ TEXTSTREAM)))
-           START-OF-PIECE PC)
-          (RETURN (first (SETQ PC (\CHTOPC (OR CH# 1)
-                                             PCTB T)) while (AND PC (NOT (ATOM PC)))
-                     do (SETQ OBJ (fetch (PIECE POBJ) of PC))
-                           (COND
-                              ([AND OBJ (EQ LABELATOM (MKATOM (IMAGEOBJPROP OBJ 'MBTEXT]
-                               (RETURN PCNO)))
-                           (add START-OF-PIECE (fetch (PIECE PLEN) of PC))
-                           (SETQ PC (fetch (PIECE NEXTPIECE) of PC])
-
-(MBUTTON.FIND.NEXT.BUTTON
-  [LAMBDA (TEXTOBJ CH#)                                  (* ; "Edited 22-Apr-93 16:39 by jds")
-
-    (* ;; "Finds the next instance of an OBJECT which looks like a menu button, 3-state button, or menuobj.  If none is found, return NIL")
-
-    (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-           START-OF-PIECE)
-          (RETURN (bind PC OBJ first (SETQ PC (\CHTOPC CH# PCTB T))
-                     while (AND PC (NOT (ATOM PC)))
-                     do                                  (* ; 
-                                "Loo thru the piece table, looking for pieces with objects in them")
-                           (SETQ OBJ (fetch (PIECE POBJ) of PC))
-                           [COND
-                              ((AND OBJ (OR (type? MBUTTON OBJ)
-                                            (type? MARGINBAR OBJ)
-                                            (type? NWAYBUTTON OBJ)))
-                                                             (* ; 
-                                                     "Which are some kind of menu-buttonish object")
-                               (RETURN (CONS OBJ START-OF-PIECE]
-                           (add START-OF-PIECE (fetch (PIECE PLEN) of PC))
-                           (SETQ PC (fetch (PIECE NEXTPIECE) of PC])
-
-(MBUTTON.FIND.NEXT.FIELD
-  [LAMBDA (TEXTOBJ CH# DON'TFIX)                         (* ; "Edited 22-Apr-93 16:53 by jds")
-
-    (* ;; "Starting from CH#, find the next fill-in area (usually surrounded by a {-} pair), and select any text it contains.  Returns the TEXTOBJ's SCRATCHSEL with the text selected.  (If no insert point is found, NIL.)")
-
-    (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-           (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-           CH1 PCNO PCNO1 PC CH LEN START-OF-PIECE (DEPTH 0))
-          (COND
-             ((IGREATERP CH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-                                                             (* ; 
-                                                          "Can't look past the end of the document")
-              (RETURN NIL)))
-          (SETQ PC (\CHTOPC CH# PCTB T))
-          (while PC do                               (* ; 
-                                    "Look thru the pieces for one which starts a user-fill-in area")
-                              (COND
-                                 ((fetch (CHARLOOKS CLSELHERE) of (fetch (PIECE PLOOKS)
-                                                                             of PC))
-                                                             (* ; "Found it, so return")
-                                  (RETURN)))
-                              (add START-OF-PIECE (fetch (PIECE PLEN) of PC))
-                              (SETQ PC (fetch (PIECE NEXTPIECE) of PC)))
-          (COND
-             (PC                                             (* ; 
-                                                    "We found a starting point for a type-in field")
-                 (add START-OF-PIECE (fetch (PIECE PLEN) of PC))
-                 (SETQ CH1 START-OF-PIECE)                   (* ; 
-                                                           "Remember the starting character number")
-                 (SETQ PC (fetch (PIECE NEXTPIECE) of PC))
-                 (while PC do (COND
-                                         ((fetch (CHARLOOKS CLPROTECTED)
-                                             of (fetch (PIECE PLOOKS) of PC))
-                                          (RETURN)))
-                                     (add START-OF-PIECE (fetch (PIECE PLEN) of PC))
-                                     (SETQ PC (fetch (PIECE NEXTPIECE) of PC)))
-                 (SETQ LEN (IDIFFERENCE START-OF-PIECE CH1))
-                 (replace (SELECTION CH#) of SCRATCHSEL with CH1)
-                 (replace (SELECTION CHLIM) of SCRATCHSEL with (IPLUS CH1
-                                                                                  (IMAX 0 LEN)))
-                 (replace (SELECTION DCH) of SCRATCHSEL with LEN)
-                 (replace (SELECTION SELOBJ) of SCRATCHSEL with NIL)
-                 (replace (SELECTION POINT) of SCRATCHSEL with 'LEFT)
-                                                             (* ; 
-                                                   "So if it's used, it'll be in the correct spot.")
-                 (replace (SELECTION SELKIND) of SCRATCHSEL with 'CHAR))
-             (T                                              (* ; 
-                                                 "No fill-in blank found, so return an indication.")
-                (RETURN NIL)))
-          (COND
-             ((NOT DON'TFIX)
-              (\FIXSEL SCRATCHSEL TEXTOBJ)))
-          (RETURN SCRATCHSEL])
-
-(MBUTTON.INIT
-  [LAMBDA NIL                                                (* jds "12-Feb-85 14:32")
-    (SETQ MBUTTONIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.DISPLAY)
-                                 (FUNCTION MB.SIZEFN)
-                                 (FUNCTION MB.PUTFN)
-                                 (FUNCTION MB.GETFN)
-                                 'MB.COPYFN
-                                 (FUNCTION MB.BUTTONEVENTINFN)
-                                 'NILL
-                                 'NILL
-                                 'NILL
-                                 'NILL
-                                 'NILL
-                                 (FUNCTION MB.WHENOPERATEDFN)
-                                 'NIL
-                                 'TEditMenuButton])
-
-(MBUTTON.NEXT.FIELD.AS.NUMBER
-  [LAMBDA (TEXTOBJ CH#)                                 (* ; "Edited 12-Jun-90 19:00 by mitani")
-    (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T)
-    (NUMBERP (MKATOM (TEDIT.SEL.AS.STRING (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)
-                            (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ])
-
-(MBUTTON.NEXT.FIELD.AS.PIECES
-  [LAMBDA (TEXTOBJ CH#)                                  (* ; "Edited 30-Mar-94 16:02 by jds")
-
-    (* ;; 
-  "Find the next fill-in field in the menu after CH#, and return its contents as A LIST OF PIECES.")
-
-    (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T)
-    (TEDIT.SELECTED.PIECES TEXTOBJ (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)
-           NIL
-           'CL:IDENTITY])
-
-(MBUTTON.NEXT.FIELD.AS.TEXT
-  [LAMBDA (TEXTOBJ CH#)                                  (* ; "Edited 22-Apr-93 16:14 by jds")
-
-    (* ;; "Find the next fill-in field in the menu after CH#, and return its contents as a string.")
-
-    (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T)
-    (TEDIT.SEL.AS.STRING (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)
-           (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ])
-
-(MBUTTON.NEXT.FIELD.AS.ATOM
-  [LAMBDA (TEXTOBJ CH#)                                 (* ; "Edited 12-Jun-90 19:00 by mitani")
-
-         (* Find the next fill-in field, and return its contents as an atom.
-       If the field is empty, return NIL.)
-
-    (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T)              (* Move to the next fill-in blank.)
-    (PROG [(STR (TEDIT.SEL.AS.STRING (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)
-                       (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ]
-          (COND
-             ((ZEROP (NCHARS STR))                           (* The field is empty.)
-              (RETURN NIL))
-             (T                                              (* It's non-empty.
-                                                           Convert the string to an atom.)
-                (RETURN (MKATOM STR])
-
-(MBUTTON.SET.FIELD
-  [LAMBDA (TEXTSTREAM FIELD VALUE)                       (* ; "Edited 22-Apr-93 10:56 by jds")
-
-    (* ;; "Makes the contents of the field with name FIELD be VALUE.")
-
-    (PROG ((TEXTOBJ (TEXTOBJ TEXTSTREAM))
-           PCTB OBJ SAVED.SEL FIELD.SEL PCNO NEW-STRING)
-          (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-          (SETQ PCNO (MBUTTON.FIND.BUTTON FIELD TEXTSTREAM))
-          (COND
-             (PCNO [SETQ FIELD.SEL (MBUTTON.FIND.NEXT.FIELD TEXTOBJ (fetch (PCTNODE CHNUM)
-                                                                           of (FINDNODE-INDEX
-                                                                                   PCTB PCNO]
-                                                             (* ; 
-                                                          "select the field following this button.")
-                   (COND
-                      (FIELD.SEL                             (* ; 
-                                                        "there are contents to set for this button")
-                             (\FIXSEL FIELD.SEL TEXTOBJ)
-                             (TEDIT.SETSEL TEXTSTREAM (fetch (SELECTION CH#) of FIELD.SEL)
-                                    (fetch (SELECTION DCH) of FIELD.SEL)
-                                    (fetch (SELECTION POINT) of FIELD.SEL)
-                                    T)
-                             (SETQ NEW-STRING (MKSTRING VALUE))
-                             (COND
-                                ((ZEROP (NCHARS NEW-STRING)) (* ; 
-                                                           "Nothing to replace, so just delete it.")
-                                 (TEDIT.DELETE TEXTSTREAM))
-                                (T                           (* ; 
-                                                           "there IS new info, so insert it.")
-                                   (TEDIT.INSERT TEXTSTREAM (MKSTRING VALUE])
-
-(MBUTTON.SET.NEXT.FIELD
-  [LAMBDA (TEXTOBJ CH# NEWVALUE DONTUPDATESCREEN)        (* ; "Edited 30-May-91 22:15 by jds")
-
-         (* SET the text content of the next fill-in field in this document to be 
-       NEWVALUE)
-
-    (PROG ((SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)))
-          (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH#)          (* Find the next menu fill-in field)
-          (\FIXSEL SCRATCHSEL TEXTOBJ)
-
-         (* Fix up the SELECTION that describes its contents, so we've got the right 
-       screen coordinates &c)
-
-          (OR (ZEROP (fetch (SELECTION DCH) of SCRATCHSEL))
-              (\TEDIT.DELETE SCRATCHSEL TEXTOBJ T))          (* If there is text in that fill-in, 
-                                                           delete it to make room for ours)
-          (COND
-             (NEWVALUE                                       (* Only insert something if there IS 
-                                                           something to insert.)
-                    (TEDIT.\INSERT (MKSTRING NEWVALUE)
-                           SCRATCHSEL TEXTOBJ)))             (* Then fill it with out new value.)
-      ])
-
-(MBUTTON.SET.NEXT.BUTTON.STATE
-  [LAMBDA (TEXTOBJ STARTINGCH NEWSTATE)                      (* jds "31-Jul-85 22:09")
-          
-          (* * Find the next menu button in the document, and set its state to NEWSTATE.
-          Return 1 + the CH# of the button, for further searchers)
-
-    (PROG* ((NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ STARTINGCH))
-            (BUTTON (CAR NEXTB)))
-           (IMAGEOBJPROP BUTTON 'STATE NEWSTATE)
-           (RETURN (ADD1 (CDR NEXTB])
-
-(TEDITMENU.STREAM
-  [LAMBDA (TEXTSTREAM)                                       (* jds "13-Aug-84 14:10")
-          
-          (* returns the textstream of the teditmenu attached to this stream if any)
-
-    (PROG (MENUW (MAINWINDOW (\TEDIT.MAINW TEXTSTREAM)))
-          [SETQ MENUW (for W in (ATTACHEDWINDOWS MAINWINDOW)
-                         thereis (AND (WINDOWPROP W 'TEDITMENU)
-                                      (EQUAL (WINDOWPROP W 'TITLE)
-                                             "TEdit Menu"]
-          (RETURN (COND
-                     (MENUW (TEXTSTREAM MENUW])
-
-(\TEDITMENU.SELSCREENER
-  [LAMBDA (TEXTOBJ SEL SELECTMODE FINAL?)                (* ; "Edited 30-May-91 22:15 by jds")
-
-         (* Called to screen potential selections in the TEdit menu window;
-       if an edit op is in progress, no selection will be permitted.-)
-
-    (PROG ((MAINW (WINDOWPROP (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-                         'MAINWINDOW))
-           MAINTEXT)
-          (SETQ MAINTEXT (WINDOWPROP MAINW 'TEXTOBJ))
-          (COND
-             ((AND (EQ (fetch (SELECTION CH#) of SEL)
-                       (fetch (SELECTION CH#) of TEDIT.SCRATCHSELECTION))
-                   (EQ (fetch (SELECTION DCH) of SEL)
-                       (fetch (SELECTION DCH) of TEDIT.SCRATCHSELECTION))
-                   (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT))
-              (\COPYSEL SEL TEDIT.SCRATCHSELECTION)
-              (RETURN 'DON'T))
-             ((EQ (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT)
-                  T)
-              (TEDIT.PROMPTPRINT TEXTOBJ "Edit operation in progress; please wait." T)
-              (RETURN 'DON'T))
-             ((fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT)
-              (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT)
-                                                " in progress; please wait.")
-                     T)
-              (\COPYSEL SEL TEDIT.SCRATCHSELECTION)
-              (RETURN 'DON'T])
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS MBUTTONIMAGEFNS)
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(MBUTTON.INIT)
-
-
-(ADDTOVAR IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN))
-)
-
-
-
-(* ;; "Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD")
-
-(DEFINEQ
-
-(MB.CREATE.THREESTATEBUTTON
-  [LAMBDA (TEXT FONT STATECHANGEFN INITSTATE)                (* jds "24-Sep-86 00:49")
-    (PROG ((OBJ (IMAGEOBJCREATE NIL THREESTATEIMAGEFNS))
-           (BOX (create IMAGEBOX
-                       XSIZE _ (STRINGWIDTH TEXT FONT)
-                       YSIZE _ (FONTPROP FONT 'HEIGHT)
-                       YDESC _ (FONTPROP FONT 'DESCENT)
-                       XKERN _ 0))
-           DS BITMAP X Y)
-          (SETQ X (fetch XSIZE of BOX))
-          (SETQ Y (fetch YSIZE of BOX))
-          (IMAGEOBJPROP OBJ 'MBTEXT TEXT)
-          (IMAGEOBJPROP OBJ 'MBFONT FONT)
-          (IMAGEOBJPROP OBJ 'MBFN 'MB.THREESTATEBUTTON.FN)
-          (IMAGEOBJPROP OBJ 'STATECHANGEFN STATECHANGEFN)
-          (IMAGEOBJPROP OBJ 'STATE (OR INITSTATE 'NEUTRAL))
-          (SETQ BITMAP (BITMAPCREATE X Y))
-          (IMAGEOBJPROP OBJ 'BITCACHE BITMAP)
-          (SETQ DS (DSPCREATE BITMAP))
-          (DSPXOFFSET 0 DS)
-          (DSPYOFFSET 0 DS)
-          (DSPFONT FONT DS)
-          (MOVETO 0 (FONTPROP FONT 'DESCENT)
-                 DS)
-          (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT)
-                 DS)
-          (RETURN OBJ])
-
-(MB.THREESTATE.DISPLAY
-  [LAMBDA (OBJ STREAM MODE)                                  (* jds "30-Aug-84 13:53")
-                                                             (* Display the innards of a menu 
-                                                             button)
-    (PROG (DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX))
-              (FONT (IMAGEOBJPROP OBJ 'MBFONT))
-              (CURX (DSPXPOSITION NIL STREAM))
-              (CURY (DSPYPOSITION NIL STREAM))
-              BITMAP X Y)
-          (OR OBJBOX (SETQ OBJBOX (MB.SIZEFN OBJ STREAM)))   (* Make sure the size is set.)
-          (SETQ X (fetch XSIZE of OBJBOX))
-          (SETQ Y (fetch YSIZE of OBJBOX))
-          (COND
-             ((SETQ BITMAP (IMAGEOBJPROP OBJ 'BITCACHE))     (* The image bitmap exists already.
-                                                             Use it.)
-              )
-             (T                                              (* Need to create an image for this 
-                                                             object.)
-                (SETQ BITMAP (BITMAPCREATE X Y))
-                (IMAGEOBJPROP OBJ 'BITCACHE BITMAP)
-                (SETQ DS (DSPCREATE BITMAP))
-                (DSPXOFFSET 0 DS)
-                (DSPYOFFSET 0 DS)
-                (DSPFONT FONT DS)
-                (MOVETO 0 (FONTPROP FONT 'DESCENT)
-                       DS)
-                (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT)
-                       DS)))
-          (BITBLT BITMAP 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX))
-                 X Y 'INPUT 'PAINT)
-          (SELECTQ (IMAGEOBJPROP OBJ 'STATE)
-              (ON 
-          
-          (* The button is ON. Display it as white text on black background)
-
-                  (BITBLT NIL 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX))
-                         X Y 'TEXTURE 'INVERT BLACKSHADE))
-              (OFF 
-          
-          (* The button is OFF. Mark it with a diagonal line thru it.)
-
-                   (DRAWLINE CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX))
-                          (SUB1 (IPLUS CURX X))
-                          (SUB1 (IPLUS (IDIFFERENCE CURY (fetch YDESC of OBJBOX))
-                                       Y))
-                          1
-                          'PAINT STREAM))
-              (NEUTRAL                                       (* The button is neutral.
-                                                             Just display it regular.))
-              NIL])
-
-(MB.THREESTATE.SHOWSELFN
-  [LAMBDA (OBJ SEL ON DS)                                (* ; "Edited 30-May-91 22:16 by jds")
-    (PROG [(IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX)
-                         (IMAGEBOX OBJ DS]
-          (COND
-             (ON (SELECTQ (IMAGEOBJPROP OBJ 'STATE)
-                         (ON                                 (* Switch from ON to NEUTRAL)
-                             (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX)
-                                    (fetch YSIZE of IMAGEBOX)
-                                    'TEXTURE
-                                    'INVERT BLACKSHADE))
-                         (OFF                                (* Switch from OFF to ON)
-                              (BITBLT (IMAGEOBJPROP OBJ 'BITCACHE)
-                                     0 0 DS 0 0 (fetch XSIZE of IMAGEBOX)
-                                     (fetch YSIZE of IMAGEBOX)
-                                     'INPUT
-                                     'REPLACE)
-                              (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX)
-                                     (fetch YSIZE of IMAGEBOX)
-                                     'TEXTURE
-                                     'INVERT BLACKSHADE))
-                         (NEUTRAL                            (* Switch from NEUTRAL to OFF)
-                                  (DRAWLINE 0 0 (SUB1 (fetch XSIZE of IMAGEBOX))
-                                         (SUB1 (fetch YSIZE of IMAGEBOX))
-                                         1
-                                         'PAINT DS))
-                         NIL))
-             ((fetch (SELECTION SET) of SEL)
-              (SELECTQ (IMAGEOBJPROP OBJ 'STATE)
-                  (ON                                        (* Switch from NEUTRAL to ON)
-                      (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX)
-                             (fetch YSIZE of IMAGEBOX)
-                             'TEXTURE
-                             'INVERT BLACKSHADE))
-                  (OFF                                       (* Switch from ON to OFF)
-                       (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX)
-                              (fetch YSIZE of IMAGEBOX)
-                              'TEXTURE
-                              'INVERT BLACKSHADE)
-                       (DRAWLINE 0 0 (SUB1 (fetch XSIZE of IMAGEBOX))
-                              (SUB1 (fetch YSIZE of IMAGEBOX))
-                              1
-                              'PAINT DS))
-                  (NEUTRAL                                   (* Switch from OFF to NEUTRAL)
-                           (BITBLT (IMAGEOBJPROP OBJ 'BITCACHE)
-                                  0 0 DS 0 0 (fetch XSIZE of IMAGEBOX)
-                                  (fetch YSIZE of IMAGEBOX)
-                                  'INPUT
-                                  'REPLACE))
-                  NIL])
-
-(MB.THREESTATE.WHENOPERATEDFN
-  [LAMBDA (OBJ DS OPERATION SEL)                         (* ; "Edited 30-May-91 22:16 by jds")
-                                                             (* Handle operations on a 
-                                                           three-state button)
-    (SELECTQ OPERATION
-        (HIGHLIGHTED                                         (* It is being hilighted)
-                     (MB.THREESTATE.SHOWSELFN OBJ SEL T DS))
-        (UNHIGHLIGHTED                                       (* And being de-hilighted)
-                       (MB.THREESTATE.SHOWSELFN OBJ SEL NIL DS))
-        (SELECTED                                            (* It's being selected)
-                  (MB.THREESTATEBUTTON.FN OBJ SEL DS)    (* Run the state-changing function)
-                  (replace (SELECTION SET) of SEL with NIL)
-                                                             (* And mar the selection turned off, 
-                                                           so others can use it without 
-                                                           trashing us)
-                  (replace (SELECTION ONFLG) of SEL with NIL)
-                  (replace (SELECTION SET) of TEDIT.SELECTION with NIL))
-        (DESELECTED)
-        NIL])
-
-(MB.THREESTATEBUTTON.FN
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited 30-May-91 22:16 by jds")
-                                                             (* MBFN for TEdit default menu item 
-                                                           buttons.)
-    (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-           (STATECHANGEFN (IMAGEOBJPROP OBJ 'STATECHANGEFN))
-           OFILE CH NEWSTATE)
-          (SETQ NEWSTATE (SELECTQ (IMAGEOBJPROP OBJ 'STATE)
-                             (OFF 'ON)
-                             (ON 'NEUTRAL)
-                             (NEUTRAL 'OFF)
-                             'ON))
-          (if STATECHANGEFN
-              then                                       (* apply the user supplied state 
-                                                           change fn if she supplied one)
-                    (APPLY* STATECHANGEFN OBJ NEWSTATE (TEXTSTREAM TEXTOBJ)))
-          (IMAGEOBJPROP OBJ 'STATE NEWSTATE)
-          (replace (SELECTION ONFLG) of SEL with NIL])
-
-(THREESTATE.INIT
-  [LAMBDA NIL                                                (* jds " 9-Feb-86 15:17")
-                                                             (* Initialize the IMAGEFNS for 3-state 
-                                                             menu button IMAGEOBJs)
-    (SETQ THREESTATEIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.THREESTATE.DISPLAY)
-                                    (FUNCTION MB.SIZEFN)
-                                    (FUNCTION MB.PUTFN)
-                                    (FUNCTION MB.GETFN)
-                                    (FUNCTION MB.COPYFN)
-                                    (FUNCTION MB.BUTTONEVENTINFN)
-                                    'NILL
-                                    'NILL
-                                    'NILL
-                                    'NILL
-                                    'NILL
-                                    (FUNCTION MB.THREESTATE.WHENOPERATEDFN)
-                                    'NILL
-                                    '3StateMenuButton])
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(THREESTATE.INIT)
-)
-
-
-
-(* ; "One-of-N Menu button sets")
-
-(DEFINEQ
-
-(MB.CREATE.NWAYBUTTON
-  [LAMBDA (BUTTONS FONT CHANGESTATEFN INITSTATE MAXITEMS/LINE)
-                                                             (* gbn "24-Sep-84 15:31")
-    (PROG ((OBJECT (IMAGEOBJCREATE NIL NWAYBUTTONIMAGEFNS))
-           HEIGHT IMAGES IMAGE DS DESCENT SPACING SIDEEFFECTFNS WIDTHS TWIDTHS)
-          (SETQ FONT (OR FONT (FONTCREATE 'HELVETICA 10)))
-          (SETQ HEIGHT (FONTPROP FONT 'HEIGHT))
-          (SETQ DESCENT (FONTPROP FONT 'DESCENT))
-          (SETQ WIDTHS (for BUTTON in BUTTONS collect (STRINGWIDTH (COND
-                                                                      ((NLISTP BUTTON)
-                                                                       BUTTON)
-                                                                      (T (CAR BUTTON)))
-                                                             FONT)))
-          (SETQ IMAGES (for WIDTH in WIDTHS as BUTTON in BUTTONS collect (BITMAPCREATE WIDTH HEIGHT))
-           )
-          (SETQ SPACING (STRINGWIDTH "   " FONT))
-          [SETQ SIDEEFFECTFNS (for BUTTON in BUTTONS collect (AND (LISTP BUTTON)
-                                                                  (CADR BUTTON]
-          (SETQ DS (DSPCREATE))
-          (DSPXOFFSET 0 DS)
-          (DSPYOFFSET 0 DS)
-          (DSPFONT FONT DS)
-          (DSPRIGHTMARGIN 32000 DS)
-          (for IMAGE in IMAGES as BUTTON in BUTTONS do (DSPDESTINATION IMAGE DS)
-                                                       (MOVETO 0 DESCENT DS)
-                                                       (PRIN1 (COND
-                                                                 ((NLISTP BUTTON)
-                                                                  BUTTON)
-                                                                 (T (CAR BUTTON)))
-                                                              DS))
-          (IMAGEOBJPROP OBJECT 'MINWIDTH (for WIDTH in WIDTHS largest WIDTH))
-                                                             (* We always need at least one 
-                                                             button's width)
-          (IMAGEOBJPROP OBJECT 'MINHEIGHT (IPLUS HEIGHT 2))  (* And at least one button's height)
-          [IMAGEOBJPROP OBJECT 'MAXWIDTH (COND
-                                            [MAXITEMS/LINE (SETQ TWIDTHS (SORT (COPY WIDTHS)))
-                                                   (IPLUS (CAR TWIDTHS)
-                                                          (for WIDTH in (CDR TWIDTHS) as I
-                                                             from 1 to (SUB1 MAXITEMS/LINE)
-                                                             sum (IPLUS WIDTH SPACING]
-                                            (T (IPLUS (CAR WIDTHS)
-                                                      (for WIDTH in (CDR WIDTHS)
-                                                         sum (IPLUS WIDTH SPACING]
-          
-          (* At most, we're as wide as the N widest buttons put together)
-
-          (IMAGEOBJPROP OBJECT 'MAXHEIGHT (ITIMES (IPLUS HEIGHT 2)
-                                                 (LENGTH BUTTONS)))
-          (IMAGEOBJPROP OBJECT 'ITEMSPACE SPACING)
-          (IMAGEOBJPROP OBJECT 'BUTTONS BUTTONS)
-          (IMAGEOBJPROP OBJECT 'BUTTONIMAGES IMAGES)
-          (IMAGEOBJPROP OBJECT 'BUTTONHEIGHT (IPLUS HEIGHT 2))
-          (IMAGEOBJPROP OBJECT 'BUTTONWIDTHS WIDTHS)
-          (IMAGEOBJPROP OBJECT 'NBUTTONS (LENGTH BUTTONS))
-          (IMAGEOBJPROP OBJECT 'STATE INITSTATE)
-          (IMAGEOBJPROP OBJECT 'SELECTEDBUTTON NIL)
-          (IMAGEOBJPROP OBJECT 'SIDEEFFECTFNS SIDEEFFECTFNS)
-          (IMAGEOBJPROP OBJECT 'DESCENT DESCENT)
-          (IMAGEOBJPROP OBJECT 'MBFONT FONT)
-          (IMAGEOBJPROP OBJECT 'MAXITEMS/LINE MAXITEMS/LINE)
-          (RETURN OBJECT])
-
-(MB.NB.DISPLAYFN
-  [LAMBDA (OBJ STREAM MODE)                                  (* jds "28-Aug-84 15:07")
-                                                             (* Display the innards of a menu 
-                                                             button)
-    (PROG (BITMAP DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX))
-                 (X (DSPXPOSITION NIL STREAM))
-                 (Y (DSPYPOSITION NIL STREAM))
-                 (BUTTONX (IMAGEOBJPROP OBJ 'BUTTONX))
-                 (BUTTONY (IMAGEOBJPROP OBJ 'BUTTONY))
-                 (BUTTONLIST (IMAGEOBJPROP OBJ 'BUTTONS))
-                 (BUTTONIMAGES (IMAGEOBJPROP OBJ 'BUTTONIMAGES))
-                 STATE)
-          [COND
-             ((SETQ BITMAP (IMAGEOBJPROP OBJ 'IMAGECACHE))   (* The button image exists already)
-              )
-             (T                                              (* Have to make one.)
-                (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of OBJBOX)
-                                    (fetch YSIZE of OBJBOX)))
-                (IMAGEOBJPROP OBJ 'IMAGECACHE BITMAP)
-                (SETQ DS (DSPCREATE BITMAP))
-                (DSPXOFFSET 0 DS)
-                (DSPYOFFSET 0 DS)
-                (DSPFONT (IMAGEOBJPROP OBJ 'MBFONT)
-                       DS)
-                (for X in BUTTONX as Y in BUTTONY as IMAGE in BUTTONIMAGES
-                   do                                        (* Display the images)
-                      (BITBLT IMAGE 0 0 DS X Y NIL NIL 'INPUT 'REPLACE]
-          [BITBLT BITMAP 0 0 STREAM X (SETQ Y (IDIFFERENCE Y (fetch YDESC of OBJBOX]
-                                                             (* Display the button's image)
-          (COND
-             ((SETQ STATE (IMAGEOBJPROP OBJ 'STATE))         (* There's a selected button.)
-              (for BXVAL in BUTTONX as BYVAL in BUTTONY as IMAGE in BUTTONIMAGES as BUTTON
-                 in BUTTONLIST when (EQ STATE BUTTON) do (BITBLT IMAGE 0 0 STREAM (IPLUS X BXVAL)
-                                                                (IPLUS Y BYVAL)
-                                                                NIL NIL 'INVERT 'REPLACE])
-
-(MB.NB.WHENOPERATEDFN
-  [LAMBDA (OBJ DS OPERATION SEL)                         (* ; "Edited 30-May-91 22:16 by jds")
-    (SELECTQ OPERATION
-        (HIGHLIGHTED                                         (* (MB.SHOWSELFN OBJ SEL T DS)))
-        (UNHIGHLIGHTED                                       (* (MB.SHOWSELFN OBJ SEL NIL DS)))
-        (SELECTED                                            (* There may be a side-effect to 
-                                                           occur upon selection.)
-                  [PROG ((STATE (IMAGEOBJPROP OBJ 'STATE))
-                         FN)
-                        (for BUTTON in (IMAGEOBJPROP OBJ 'BUTTONS) as SIDEFN
-                           in (IMAGEOBJPROP OBJ 'SIDEEFFECTFNS) when (EQ STATE BUTTON)
-                           do (COND
-                                     (SIDEFN (MB.SELFN OBJ SEL DS SIDEFN]
-                  (replace (SELECTION SET) of SEL with NIL))
-        (DESELECTED)
-        NIL])
-
-(MB.NB.SIZEFN
-  [LAMBDA (OBJ STREAM CURX RIGHTMARGIN)                      (* jds " 6-Sep-84 14:19")
-                                                             (* Tell the size of an n-way menu)
-    (PROG ((OLDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX))
-           BOX
-           (MAXITEMS/LINE (IMAGEOBJPROP OBJ 'MAXITEMS/LINE))
-           (MAXWIDTH (IMAGEOBJPROP OBJ 'MAXWIDTH))
-           (MINWIDTH (IMAGEOBJPROP OBJ 'MINWIDTH))
-           (MAXHEIGHT (IMAGEOBJPROP OBJ 'MAXHEIGHT))
-           (MINHEIGHT (IMAGEOBJPROP OBJ 'MINHEIGHT))
-           (LINEHEIGHT (IMAGEOBJPROP OBJ 'LINEHEIGHT))
-           (BUTTONHEIGHT (IMAGEOBJPROP OBJ 'BUTTONHEIGHT))
-           (BUTTONWIDTHS (IMAGEOBJPROP OBJ 'BUTTONWIDTHS))
-           (SPACING (IMAGEOBJPROP OBJ 'ITEMSPACE))
-           (SLACK (IDIFFERENCE RIGHTMARGIN CURX))
-           BUTTONX BUTTONY BUTTONINFO WIDTH HEIGHT)
-          [COND
-             ((AND (IGEQ SLACK MAXWIDTH)
-                   (NOT MAXITEMS/LINE))
-          
-          (* There's space for all the items on one line.
-          Use it)
-
-              (SETQ WIDTH MAXWIDTH)
-              (SETQ HEIGHT MINHEIGHT)
-              [SETQ BUTTONX (bind (CURX _ 0) for ITEM in BUTTONWIDTHS
-                               collect (PROG1 CURX (add CURX SPACING)
-                                              (add CURX ITEM]
-              (SETQ BUTTONY (for ITEM in BUTTONWIDTHS collect 0)))
-             [(ILEQ SLACK MINWIDTH)                          (* Have to stack it vertically.)
-              (SETQ WIDTH MINWIDTH)
-              (SETQ HEIGHT MAXHEIGHT)
-              (SETQ BUTTONX (for ITEM in BUTTONWIDTHS collect 0))
-              (SETQ BUTTONY (bind (CURY _ (ITIMES BUTTONHEIGHT (LENGTH BUTTONWIDTHS))) for ITEM
-                               in BUTTONWIDTHS collect (add CURY (IMINUS BUTTONHEIGHT]
-             (T (SETQ BUTTONINFO (MB.NB.PACKITEMS SLACK BUTTONWIDTHS SPACING MAXITEMS/LINE))
-                [SETQ BUTTONX (for LINE in BUTTONINFO join (COPY (CDR LINE]
-                [SETQ BUTTONY (bind (CURY _ (ITIMES BUTTONHEIGHT (LENGTH BUTTONINFO))) for LINE
-                                 in BUTTONINFO join (PROGN (SETQ CURY (IDIFFERENCE CURY BUTTONHEIGHT)
-                                                            )
-                                                           (for X in (CDR LINE) collect CURY]
-                [SETQ WIDTH (CAR (for LINE in BUTTONINFO largest (CAR LINE]
-                (SETQ HEIGHT (ITIMES BUTTONHEIGHT (LENGTH BUTTONINFO]
-          (COND
-             ((AND OLDBOX (IEQP WIDTH (fetch XSIZE of OLDBOX))
-                   (IEQP HEIGHT (fetch YSIZE of OLDBOX)))    (* If nothing changed, don't bother 
-                                                             reformatting.)
-              (RETURN OLDBOX))
-             (T                                              (* Otherwise invalidate the image 
-                                                             cache)
-                (IMAGEOBJPROP OBJ 'IMAGECACHE NIL)))
-          (SETQ BOX (create IMAGEBOX
-                           XSIZE _ WIDTH
-                           YSIZE _ HEIGHT
-                           YDESC _ (IMAGEOBJPROP OBJ 'DESCENT)
-                           XKERN _ 0))
-          (IMAGEOBJPROP OBJ 'BOUNDBOX BOX)
-          (IMAGEOBJPROP OBJ 'BUTTONX BUTTONX)
-          (IMAGEOBJPROP OBJ 'BUTTONY BUTTONY)
-          (RETURN BOX])
-
-(MB.NWAYBUTTON.SELFN
-  [LAMBDA (OBJ W SEL MOUSEX MOUSEY)                      (* ; "Edited 30-May-91 22:16 by jds")
-                                                             (* Selecting an NWAY button.)
-    (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-           (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX))
-           (OLDSTATE (IMAGEOBJPROP OBJ 'STATE))
-           (BUTTONLIST (IMAGEOBJPROP OBJ 'BUTTONS))
-           (BUTTONX (IMAGEOBJPROP OBJ 'BUTTONX))
-           (BUTTONIMAGES (IMAGEOBJPROP OBJ 'BUTTONIMAGES))
-           (BUTTONY (IMAGEOBJPROP OBJ 'BUTTONY))
-           (BUTTONWIDTHS (IMAGEOBJPROP OBJ 'BUTTONWIDTHS))
-           (BUTTONLIST (IMAGEOBJPROP OBJ 'BUTTONLIST))
-           (BUTTONHEIGHT (IMAGEOBJPROP OBJ 'BUTTONHEIGHT))
-           CH STATE)
-          [for BUTTON in BUTTONLIST as X in BUTTONX as Y in BUTTONY
-             as WIDTH in BUTTONWIDTHS as IMAGE in BUTTONIMAGES
-             do (COND
-                       ((INSIDE? (create REGION
-                                        LEFT _ X
-                                        BOTTOM _ Y
-                                        WIDTH _ WIDTH
-                                        HEIGHT _ BUTTONHEIGHT)
-                               MOUSEX MOUSEY)                (* The mouse is pointing here.
-                                                           Select this.)
-                        (SETQ STATE BUTTON)
-                        (BITBLT IMAGE 0 0 W X Y NIL NIL 'INVERT 'REPLACE))
-                       ((EQ OLDSTATE BUTTON)                 (* This was the old selection
-                                                           (and it's different, too)%.
-                                                           Unselect it)
-                        (BITBLT IMAGE 0 0 W X Y NIL NIL 'INPUT 'REPLACE]
-          (IMAGEOBJPROP OBJ 'STATE STATE)
-          (RETURN T])
-
-(MB.NWAYMENU.NEWBUTTON
-  [LAMBDA (TEXTOBJ CH# OLDBUTTON NEWBUTTON)                  (* jds " 8-Feb-84 19:41")
-          
-          (* Given a hook on an existing button, and an insertion point, insert a new 
-          button)
-
-    (PROG ((ARBITRATOR (IMAGEOBJPROP OLDBUTTON 'ARBITRATOR))
-           BUTTON)
-          (IMAGEOBJPROP BUTTON 'ARBITRATOR ARBITRATOR)
-          (TEDIT.INSERT.OBJECT BUTTON TEXTOBJ CH#)
-          (TEDIT.INSERT TEXTOBJ "  " (ADD1 CH#))
-          (TEDIT.LOOKS TEXTOBJ '(PROTECTED ON) (ADD1 CH#)
-                 2)
-          (RETURN BUTTON])
-
-(NWAYBUTTON.INIT
-  [LAMBDA (BUTTONS FONT INITSTATE)                           (* jds " 9-Feb-86 15:17")
-    (SETQ NWAYBUTTONIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.NB.DISPLAYFN)
-                                    (FUNCTION MB.NB.SIZEFN)
-                                    (FUNCTION MB.PUTFN)
-                                    (FUNCTION MB.GETFN)
-                                    (FUNCTION MB.COPYFN)
-                                    (FUNCTION MB.NWAYBUTTON.SELFN)
-                                    'NILL
-                                    'NILL
-                                    'NILL
-                                    'NILL
-                                    'NILL
-                                    (FUNCTION MB.NB.WHENOPERATEDFN)
-                                    'NILL
-                                    'NWayButton])
-
-(MB.NB.PACKITEMS
-  [LAMBDA (WIDTH ITEMWIDTHS SPACING MAXITEMS/LINE)           (* jds "24-Oct-84 17:42")
-          
-          (* * Pack items into lines WIDTH wide. Item widths are in ITEMWIDTHS, and each 
-          pair of items on a line is separated by SPACING.
-          Returns a list of lists, one per line packed, of the relative X starts of the 
-          items)
-
-    (PROG ((CURX 0)
-           (LINES NIL)
-           (CURLINE NIL)
-           (CURLINEITEMS 0)
-           ITEM)
-          (while ITEMWIDTHS do (SETQ ITEM (pop ITEMWIDTHS))
-                               (COND
-                                  ((OR [ILESSP WIDTH (IPLUS CURX ITEM (COND
-                                                                         (CURLINE SPACING)
-                                                                         (T 0]
-                                       (AND MAXITEMS/LINE (IGEQ CURLINEITEMS MAXITEMS/LINE)))
-                                                             (* Time for a new line)
-                                   (SETQ LINES (NCONC1 LINES (CONS CURX CURLINE)))
-                                                             (* Add to our list of lines so far)
-                                   (SETQ CURLINE NIL)        (* Empty the line accumulator)
-                                   (SETQ CURLINEITEMS 0)     (* reset the line item count)
-                                   (SETQ CURX 0)))
-                               (AND CURLINE (add CURX SPACING))
-                               (SETQ CURLINE (NCONC1 CURLINE CURX))
-                               (add CURX ITEM)
-                               (add CURLINEITEMS 1))
-          [AND CURLINE (SETQ LINES (NCONC1 LINES (CONS CURX CURLINE]
-                                                             (* Capture the last partial line, if 
-                                                             there is one.)
-          (RETURN LINES])
-
-(MB.NWAYBUTTON.ADDITEM
-  [LAMBDA (OBJECT NEWBUTTON)                                 (* jds "11-Jul-85 12:44")
-          
-          (* Given an existing n-way choice menu button, add another choice to the list)
-
-    (PROG ([BUTTONS (CONS NEWBUTTON (IMAGEOBJPROP OBJECT 'BUTTONS]
-           HEIGHT IMAGES IMAGE DS DESCENT SPACING SIDEEFFECTFNS WIDTHS FONT)
-          (SETQ FONT (IMAGEOBJPROP OBJECT 'MBFONT))
-          (SETQ HEIGHT (FONTPROP FONT 'HEIGHT))
-          (SETQ DESCENT (FONTPROP FONT 'DESCENT))
-          (SETQ WIDTHS (for BUTTON in BUTTONS collect (STRINGWIDTH (COND
-                                                                      ((NLISTP BUTTON)
-                                                                       BUTTON)
-                                                                      (T (CAR BUTTON)))
-                                                             FONT)))
-          (SETQ IMAGES (for WIDTH in WIDTHS as BUTTON in BUTTONS collect (BITMAPCREATE WIDTH HEIGHT))
-           )
-          (SETQ SPACING (STRINGWIDTH "   " FONT))
-          [SETQ SIDEEFFECTFNS (for BUTTON in BUTTONS collect (AND (LISTP BUTTON)
-                                                                  (CADR BUTTON]
-          (SETQ DS (DSPCREATE))
-          (DSPXOFFSET 0 DS)
-          (DSPYOFFSET 0 DS)
-          (DSPFONT FONT DS)
-          (DSPRIGHTMARGIN 32000 DS)
-          (for IMAGE in IMAGES as BUTTON in BUTTONS do (DSPDESTINATION IMAGE DS)
-                                                       (MOVETO 0 DESCENT DS)
-                                                       (PRIN1 (COND
-                                                                 ((NLISTP BUTTON)
-                                                                  BUTTON)
-                                                                 (T (CAR BUTTON)))
-                                                              DS))
-          (IMAGEOBJPROP OBJECT 'MINWIDTH (for WIDTH in WIDTHS largest WIDTH))
-          (IMAGEOBJPROP OBJECT 'MINHEIGHT (IPLUS HEIGHT 2))
-          [IMAGEOBJPROP OBJECT 'MAXWIDTH (IPLUS (CAR WIDTHS)
-                                                (for WIDTH in (CDR WIDTHS)
-                                                   sum (IPLUS WIDTH SPACING]
-          (IMAGEOBJPROP OBJECT 'MAXHEIGHT (ITIMES (IPLUS HEIGHT 2)
-                                                 (LENGTH BUTTONS)))
-          (IMAGEOBJPROP OBJECT 'ITEMSPACE SPACING)
-          (IMAGEOBJPROP OBJECT 'BUTTONS BUTTONS)
-          (IMAGEOBJPROP OBJECT 'BUTTONIMAGES IMAGES)
-          (IMAGEOBJPROP OBJECT 'BUTTONHEIGHT (IPLUS HEIGHT 2))
-          (IMAGEOBJPROP OBJECT 'BUTTONWIDTHS WIDTHS)
-          (IMAGEOBJPROP OBJECT 'NBUTTONS (LENGTH BUTTONS))
-          (IMAGEOBJPROP OBJECT 'SELECTEDBUTTON NIL)
-          (IMAGEOBJPROP OBJECT 'SIDEEFFECTFNS SIDEEFFECTFNS)
-          (IMAGEOBJPROP OBJECT 'DESCENT DESCENT)
-          (RETURN OBJECT])
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS NWAYBUTTONIMAGEFNS)
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(NWAYBUTTON.INIT)
-
-
-(ADDTOVAR IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN))
-)
-
-
-
-(* ;; "Two-state, toggling menu buttons.")
-
-(DEFINEQ
-
-(\TEXTMENU.TOGGLE.CREATE
-  [LAMBDA (TEXT FONT STATECHANGEFN INITSTATE)                (* gbn "24-Sep-84 14:45")
-          
-          (* Creates a TOGGLE menu button, that can turn off and on alternately.)
-
-    (PROG ((OBJ (IMAGEOBJCREATE NIL \TOGGLEIMAGEFNS))
-           (BOX (create IMAGEBOX
-                       XSIZE _ (STRINGWIDTH TEXT FONT)
-                       YSIZE _ (FONTPROP FONT 'HEIGHT)
-                       YDESC _ (FONTPROP FONT 'DESCENT)
-                       XKERN _ 0))
-           DS BITMAP X Y)
-          (SETQ X (fetch XSIZE of BOX))
-          (SETQ Y (fetch YSIZE of BOX))
-          (IMAGEOBJPROP OBJ 'MBTEXT TEXT)
-          (IMAGEOBJPROP OBJ 'MBFONT FONT)
-          (IMAGEOBJPROP OBJ 'MBFN '\TEXTMENU.TOGGLEFN)
-          (IMAGEOBJPROP OBJ 'STATECHANGEFN STATECHANGEFN)
-          
-          (* a function to be called on finalization of selection of this button to 
-          provide for user side-effects)
-
-          (IMAGEOBJPROP OBJ 'STATE (OR INITSTATE 'OFF))
-          (SETQ BITMAP (BITMAPCREATE X Y))
-          (IMAGEOBJPROP OBJ 'BITCACHE BITMAP)
-          (SETQ DS (DSPCREATE BITMAP))
-          (DSPXOFFSET 0 DS)
-          (DSPYOFFSET 0 DS)
-          (DSPFONT FONT DS)
-          (MOVETO 0 (FONTPROP FONT 'DESCENT)
-                 DS)
-          (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT)
-                 DS)
-          (RETURN OBJ])
-
-(\TEXTMENU.TOGGLE.DISPLAY
-  [LAMBDA (OBJ STREAM MODE)                                  (* gbn "27-Sep-84 01:23")
-                                                             (* "27-Sep-84 01:11" gbn)
-                                                             (* Display the innards of a menu 
-                                                             toggle)
-    (PROG (DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX))
-              (FONT (IMAGEOBJPROP OBJ 'MBFONT))
-              (CURX (DSPXPOSITION NIL STREAM))
-              (CURY (DSPYPOSITION NIL STREAM))
-              BITMAP X Y)
-          (OR OBJBOX (SETQ OBJBOX (MB.SIZEFN OBJ STREAM)))   (* Make sure the size is set.)
-          (SETQ X (fetch XSIZE of OBJBOX))
-          (SETQ Y (fetch YSIZE of OBJBOX))
-          (COND
-             ([type? BITMAP (SETQ BITMAP (IMAGEOBJPROP OBJ 'BITCACHE]
-                                                             (* The image bitmap exists already.
-                                                             Use it.)
-              )
-             (T                                              (* Need to create an image for this 
-                                                             object.)
-                (SETQ BITMAP (BITMAPCREATE X Y))
-                (IMAGEOBJPROP OBJ 'BITCACHE BITMAP)
-                (SETQ DS (DSPCREATE BITMAP))
-                (DSPXOFFSET 0 DS)
-                (DSPYOFFSET 0 DS)
-                (DSPFONT FONT DS)
-                (MOVETO 0 (FONTPROP FONT 'DESCENT)
-                       DS)
-                (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT)
-                       DS)))
-          (BITBLT BITMAP 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX))
-                 X Y 'INPUT 'PAINT)
-          (SELECTQ (IMAGEOBJPROP OBJ 'STATE)
-              (ON 
-          
-          (* The button is ON. Display it as white text on black background)
-
-                  (BITBLT NIL 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX))
-                         X Y 'TEXTURE 'INVERT BLACKSHADE))
-              (OFF                                           (* The button is OFF.
-                                                             Just display it regular.))
-              (ERROR "Invalid state in toggle button " OBJ])
-
-(\TEXTMENU.TOGGLE.SHOWSELFN
-  [LAMBDA (OBJ SEL ON DS)                                (* ; "Edited 30-May-91 22:16 by jds")
-    (PROG [(IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX)
-                         (IMAGEBOX OBJ DS]
-          (COND
-             (ON (SELECTQ (IMAGEOBJPROP OBJ 'STATE)
-                         (ON                                 (* Switch from ON to
-                                                           (NEUTRAL (* Switch from OFF to 
-                                                           NEUTRAL) (BITBLT (IMAGEOBJPROP OBJ
-                                                           (QUOTE BITCACHE)) 0 0 DS 0 0
-                                                           (fetch XSIZE of IMAGEBOX)
-                                                           (fetch YSIZE of IMAGEBOX)
-                                                           (QUOTE INPUT) (QUOTE REPLACE))))
-                             (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX)
-                                    (fetch YSIZE of IMAGEBOX)
-                                    'TEXTURE
-                                    'INVERT BLACKSHADE))
-                         (OFF                                (* Switch from OFF to ON)
-                              (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX)
-                                     (fetch YSIZE of IMAGEBOX)
-                                     'TEXTURE
-                                     'INVERT BLACKSHADE))
-                         NIL))
-             ((fetch (SELECTION SET) of SEL)
-              (SELECTQ (IMAGEOBJPROP OBJ 'STATE)
-                  (ON                                        (* Switch from OFF to ON)
-                      (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX)
-                             (fetch YSIZE of IMAGEBOX)
-                             'TEXTURE
-                             'INVERT BLACKSHADE))
-                  (OFF                                       (* Switch from ON to OFF)
-                       (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX)
-                              (fetch YSIZE of IMAGEBOX)
-                              'TEXTURE
-                              'INVERT BLACKSHADE))
-                  NIL])
-
-(\TEXTMENU.TOGGLE.WHENOPERATEDFN
-  [LAMBDA (OBJ DS OPERATION SEL)                         (* ; "Edited 30-May-91 22:16 by jds")
-                                                             (* Handle operations on a 
-                                                           three-state button)
-    (SELECTQ OPERATION
-        (HIGHLIGHTED                                         (* It is being hilighted)
-                     (\TEXTMENU.TOGGLE.SHOWSELFN OBJ SEL T DS))
-        (UNHIGHLIGHTED                                       (* And being de-hilighted)
-                       (\TEXTMENU.TOGGLE.SHOWSELFN OBJ SEL NIL DS))
-        (SELECTED                                            (* It's being selected)
-                  (\TEXTMENU.TOGGLEFN OBJ SEL DS)        (* Run the state-changing function)
-                  (replace (SELECTION SET) of SEL with NIL)
-                                                             (* And mar the selection turned off, 
-                                                           so others can use it without 
-                                                           trashing us)
-                  (replace (SELECTION ONFLG) of SEL with NIL)
-                  (replace (SELECTION SET) of TEDIT.SELECTION with NIL))
-        (DESELECTED)
-        NIL])
-
-(\TEXTMENU.TOGGLEFN
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited 30-May-91 22:16 by jds")
-                                                             (* MBFN for TOGGLE buttons--cycle 
-                                                           back and forthe betwen states.)
-    (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-           (STATECHANGEFN (IMAGEOBJPROP OBJ 'STATECHANGEFN))
-           OFILE CH NEWSTATE)
-          (SETQ NEWSTATE (SELECTQ (IMAGEOBJPROP OBJ 'STATE)
-                             (OFF 'ON)
-                             (ON 'OFF)
-                             'ON))
-          (COND
-             (STATECHANGEFN                                  (* apply the user supplied state 
-                                                           change fn if he supplied one)
-                    (APPLY* STATECHANGEFN OBJ NEWSTATE (TEXTSTREAM TEXTOBJ)
-                           SEL)))
-          (IMAGEOBJPROP OBJ 'STATE NEWSTATE)
-          (replace (SELECTION ONFLG) of SEL with NIL])
-
-(\TEXTMENU.TOGGLE.INIT
-  [LAMBDA NIL                                                (* jds " 9-Feb-86 15:18")
-    (SETQ \TOGGLEIMAGEFNS (IMAGEFNSCREATE (FUNCTION \TEXTMENU.TOGGLE.DISPLAY)
-                                 (FUNCTION MB.SIZEFN)
-                                 (FUNCTION MB.PUTFN)
-                                 (FUNCTION MB.GETFN)
-                                 (FUNCTION MB.COPYFN)
-                                 (FUNCTION MB.BUTTONEVENTINFN)
-                                 'NILL
-                                 'NILL
-                                 'NILL
-                                 'NILL
-                                 'NILL
-                                 (FUNCTION \TEXTMENU.TOGGLE.WHENOPERATEDFN)
-                                 'NILL
-                                 'ToggleButton])
-
-(\TEXTMENU.SET.TOGGLE
-  [LAMBDA (TEXT VALUE TEXTSTREAM)                       (* ; "Edited 12-Jun-90 19:02 by mitani")
-
-         (* * finds the button with MBTEXT field TEXT in TEXTSTREAM and sets its state 
-       to VALUE)
-
-    (PROG ((PCNO (MBUTTON.FIND.BUTTON TEXT TEXTSTREAM))
-           OBJ PC)
-          (COND
-             ((NOT PCNO)
-              (ERROR TEXT " was not found as a button.")))
-          [SETQ OBJ (fetch (PIECE POBJ) of (SETQ PC (fetch (PCTNODE PCE)
-                                                               of (FINDNODE-INDEX
-                                                                       (fetch (TEXTOBJ PCTB)
-                                                                          of (TEXTOBJ TEXTSTREAM)
-                                                                              )
-                                                                       PCNO]
-          (IMAGEOBJPROP OBJ 'STATE VALUE)
-          (IMAGEOBJPROP OBJ 'BITCACHE 'JUNK)
-          (for WINDOW inside (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ TEXTSTREAM))
-             do (\TEDIT.REPAINTFN WINDOW))
-          (RETURN VALUE])
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \TOGGLEIMAGEFNS)
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(\TEXTMENU.TOGGLE.INIT)
-
-
-(ADDTOVAR IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN))
-)
-
-
-
-(* ;; "Margin Setting and display")
-
-(DEFINEQ
-
-(DRAWMARGINSCALE
-  [LAMBDA (W UNIT)                                      (* ; "Edited 12-Jun-90 18:59 by mitani")
-
-    (* ;; " Draw the margin-bar scale -- the markings across the bottom of the margin bar that show you the margin values.  Draws the scale in window W, according to UNIT = 1 for points, or 12 for picas.")
-
-    (PROG ((WREG (DSPCLIPPINGREGION NIL W))
-           (OLDOP (DSPOPERATION 'REPLACE W)))
-          (DSPFILL (create REGION
-                          LEFT _ 0
-                          BOTTOM _ 0
-                          WIDTH _ (fetch (REGION WIDTH) of WREG)
-                          HEIGHT _ 24)
-                 WHITESHADE
-                 'REPLACE W)                                 (* ; "CLEAR IT OUT FIRST.")
-          (SELECTQ UNIT
-              (1                                             (* ; "Straight Points")
-                 [for X from 4 by 3 to (fetch (REGION WIDTH) of WREG)
-                    do 
-
-                          (* ;; "Put a tick every 3 points, with a number every inch.")
-
-                          (COND
-                             ((ZEROP (IREMAINDER (IDIFFERENCE X 4)
-                                            72))
-                              (BITBLT NIL 0 0 W X 8 1 16 'TEXTURE 'REPLACE BLACKSHADE)
-                              (MOVETO (IDIFFERENCE X (LRSH (STRINGWIDTH (IDIFFERENCE X 4))
-                                                           1))
-                                     10 W)
-                              (PRIN1 (IDIFFERENCE X 4)
-                                     W))
-                             (T (BITBLT NIL 0 0 W X 20 1 4 'TEXTURE 'REPLACE BLACKSHADE])
-              (12                                            (* ; "Picas")
-                  (for X from 4 by 12 to (fetch (REGION WIDTH) of WREG)
-                     as NOMX from 0
-                     do 
-
-                           (* ;; "Put a tick every half-pica, with a number every inch.")
-
-                           (COND
-                              ((ZEROP (IREMAINDER NOMX 6))
-                               (BITBLT NIL 0 0 W X 8 1 16 'TEXTURE 'REPLACE BLACKSHADE)
-                               (MOVETO (IDIFFERENCE X (LRSH (STRINGWIDTH NOMX)
-                                                            1))
-                                      10 W)
-                               (PRIN1 NOMX W))
-                              (T (BITBLT NIL 0 0 W X 20 1 4 'TEXTURE 'REPLACE BLACKSHADE)))
-                           (BITBLT NIL 0 0 W (IPLUS X 6)
-                                  22 1 2 'TEXTURE 'REPLACE BLACKSHADE)))
-              NIL)
-          (BITBLT NIL 0 0 W 4 23 (fetch (REGION WIDTH) of WREG)
-                 1
-                 'TEXTURE
-                 'REPLACE BLACKSHADE)
-          (MOVETO 0 0 W)
-          (RELDRAWTO (IDIFFERENCE (fetch (REGION WIDTH) of WREG)
-                            2)
-                 0 1 'PAINT W)
-          (RELDRAWTO 0 (IDIFFERENCE (fetch (REGION HEIGHT) of WREG)
-                              2)
-                 1
-                 'PAINT W)
-          (RELDRAWTO (IMINUS (IDIFFERENCE (fetch (REGION WIDTH) of WREG)
-                                    2))
-                 0 1 'PAINT W)
-          (RELDRAWTO 0 (IMINUS (IDIFFERENCE (fetch (REGION HEIGHT) of WREG)
-                                      2))
-                 1
-                 'PAINT W)
-          (DSPOPERATION OLDOP W])
-
-(MARGINBAR
-  [LAMBDA (W L1 LN R TABS UNIT UPDATE RIGHTLIM)         (* ; "Edited 12-Jun-90 18:59 by mitani")
-                                                             (* Given a set of margins and a 
-                                                           unit, show the margin bar properly)
-    (PROG ((OLDOP (DSPOPERATION 'ERASE W))
-           (SCALEDL1 (MSCALE L1 UNIT))
-           (SCALEDLN (MSCALE LN UNIT))
-           (SCALEDR (MSCALE R UNIT))
-           (FLOATINGRIGHT NIL)
-           (EXTENDEDRIGHT NIL)
-           UNSETL1 UNSETLN)
-          (OR UPDATE (DRAWMARGINSCALE W UNIT))
-          (DSPFONT (FONTCREATE 'GACHA 10)
-                 W)
-          (SETQ L1 (MKSTRING (ABS L1)))
-          (SETQ LN (MKSTRING (ABS LN)))
-          (SETQ R (MKSTRING (ABS R)))
-          [COND
-             [(ILESSP SCALEDR 4)                             (* Unset right margin.
-                                                           Show specially, but at its usual 
-                                                           place.)
-              (SETQ FLOATINGRIGHT T)
-              (SETQ SCALEDR (IPLUS 4 (IDIFFERENCE 4 SCALEDR]
-             ((ILEQ SCALEDR 4)                               (* Floating right margin => marked 
-                                                           specially)
-              (SETQ FLOATINGRIGHT T)
-              (SETQ SCALEDR RIGHTLIM))
-             ((IGREATERP SCALEDR RIGHTLIM)                   (* Not floating, so just limit it to 
-                                                           the rightmost that can be seen.)
-              (SETQ EXTENDEDRIGHT T)
-              (SETQ SCALEDR (IDIFFERENCE RIGHTLIM 8]
-          [COND
-             ((ILESSP SCALEDL1 4)                            (* Unset right FIRST LEFT margin.
-                                                           Show specially, but at its usual 
-                                                           place.)
-              (SETQ UNSETL1 T)
-              (SETQ SCALEDL1 (IPLUS 4 (IDIFFERENCE 4 SCALEDL1]
-          [COND
-             ((ILESSP SCALEDLN 4)                            (* Unset LEFT margin.
-                                                           Show specially, but at its usual 
-                                                           place.)
-              (SETQ UNSETLN T)
-              (SETQ SCALEDLN (IPLUS 4 (IDIFFERENCE 4 SCALEDLN]
-          (BITBLT NIL 0 0 W 1 26 (IDIFFERENCE (fetch (REGION WIDTH) of (DSPCLIPPINGREGION
-                                                                                NIL W))
-                                        3)
-                 32
-                 'TEXTURE
-                 'REPLACE WHITESHADE)
-          (BITBLT NIL 0 0 W SCALEDL1 42 (IDIFFERENCE SCALEDR SCALEDL1)
-                 16
-                 'TEXTURE
-                 'REPLACE BLACKSHADE)
-          (BITBLT NIL 0 0 W SCALEDLN 26 (IDIFFERENCE SCALEDR SCALEDLN)
-                 16
-                 'TEXTURE
-                 'REPLACE BLACKSHADE)
-          (COND
-             (UNSETL1                                        (* 1st left margin isn't set, tho it 
-                                                           has a value. Mark it neutral)
-                    (BITBLT NIL 0 0 W SCALEDL1 42 (IPLUS (STRINGWIDTH L1 W)
-                                                         2)
-                           16
-                           'TEXTURE
-                           'REPLACE EDITGRAY)
-                    (DSPOPERATION 'PAINT W)
-                    (MOVETO (IPLUS SCALEDL1 2)
-                           44 W)
-                    (PRIN1 L1 W)
-                    (DSPOPERATION 'ERASE W))
-             (T (MOVETO (IPLUS SCALEDL1 2)
-                       44 W)
-                (PRIN1 L1 W)))
-          (COND
-             (UNSETLN                                        (* left margin isn't set, tho it has 
-                                                           a value. Mark it neutral)
-                    (BITBLT NIL 0 0 W SCALEDLN 26 (IPLUS (STRINGWIDTH LN W)
-                                                         2)
-                           16
-                           'TEXTURE
-                           'REPLACE EDITGRAY)
-                    (DSPOPERATION 'PAINT W)
-                    (MOVETO (IPLUS SCALEDLN 2)
-                           28 W)
-                    (PRIN1 LN W)
-                    (DSPOPERATION 'ERASE W))
-             (T (MOVETO (IPLUS SCALEDLN 2)
-                       28 W)
-                (PRIN1 LN W)))
-          [COND
-             (FLOATINGRIGHT                                  (* Floating right margin is marked 
-                                                           by a light gray marker)
-                    (BITBLT NIL 0 0 W (IDIFFERENCE SCALEDR (IPLUS (STRINGWIDTH R W)
-                                                                  2))
-                           26
-                           (IPLUS (STRINGWIDTH R W)
-                                  2)
-                           32
-                           'TEXTURE
-                           'REPLACE EDITGRAY)
-                    (DSPOPERATION 'PAINT W))
-             (EXTENDEDRIGHT                                  (* A non-visible right margin is 
-                                                           marked by two wavy lines indicating 
-                                                           a break)
-                    (BITBLT TEDIT.EXTENDEDRIGHTMARK 0 0 W SCALEDR 26 8 32 'INPUT 'REPLACE]
-          (MOVETO (IDIFFERENCE SCALEDR (IPLUS (STRINGWIDTH R W)
-                                              2))
-                 36 W)
-          (PRIN1 R W)
-          (DSPOPERATION OLDOP W)
-          (COND
-             ((EQ TABS 'NEUTRAL)                             (* All tabs have been neutralized.
-                                                           Just lay down a grey pattern over 
-                                                           them.)
-              (DSPFILL (create REGION
-                              LEFT _ 2
-                              BOTTOM _ 1
-                              HEIGHT _ 8
-                              WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of (
-                                                                                    DSPCLIPPINGREGION
-                                                                                     NIL W))
-                                             4))
-                     EDITGRAY
-                     'REPLACE W))
-             (T (DSPFILL (create REGION
-                                LEFT _ 2
-                                BOTTOM _ 1
-                                HEIGHT _ 8
-                                WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH)
-                                                        of (DSPCLIPPINGREGION NIL W))
-                                               4))
-                       WHITESHADE
-                       'REPLACE W)
-                (for TAB in TABS do              (* Run thru the tabs, putting them 
-                                                           down in place.)
-                                               (MB.MARGINBAR.SHOWTAB W TAB UNIT 'PAINT])
-
-(MARGINBAR.CREATE
-  [LAMBDA (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE) (* ; "Edited 12-Jun-90 18:59 by mitani")
-                                                             (* Create an instance of the 
-                                                           margin-setting ruler for TEdit's 
-                                                           use.)
-    (PROG ((BOX (create IMAGEBOX
-                       XSIZE _ 1008
-                       YSIZE _ 62
-                       YDESC _ 0
-                       XKERN _ 4))
-           OBJ OBJDATUM BITMAP DS)
-          (SETQ OBJ
-           (IMAGEOBJCREATE (SETQ OBJDATUM
-                            (create MARGINBAR
-                                   MARL1 _ MARL1
-                                   MARLN _ MARLN
-                                   MARR _ MARR
-                                   MARTABS _ MARTABS
-                                   MARUNIT _ MARUNIT
-                                   MARTABTYPE _ MARTABTYPE))
-                  MARGINBARIMAGEFNS))
-
-         (* Create an IMAGEOBJ, containing an instance of the record to hold margin and 
-       tab info)
-
-          (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of BOX)
-                              (fetch YSIZE of BOX))) (* A cache for the ruler's screen 
-                                                           image)
-          (IMAGEOBJPROP OBJ 'BITCACHE BITMAP)
-          (SETQ DS (DSPCREATE BITMAP))                       (* And a displaystream for modifying 
-                                                           that image)
-          (IMAGEOBJPROP OBJ 'DSPCACHE DS)
-          (DSPXOFFSET 0 DS)
-          (DSPYOFFSET 0 DS)
-          (DSPCLIPPINGREGION (create REGION
-                                    LEFT _ 0
-                                    BOTTOM _ 0
-                                    WIDTH _ (fetch XSIZE of BOX)
-                                    HEIGHT _ (fetch YSIZE of BOX))
-                 DS)
-          (MARGINBAR DS (fetch (MARGINBAR MARL1) of OBJDATUM)
-                 (fetch (MARGINBAR MARLN) of OBJDATUM)
-                 (fetch (MARGINBAR MARR) of OBJDATUM)
-                 (fetch (MARGINBAR MARTABS) of OBJDATUM)
-                 (fetch (MARGINBAR MARUNIT) of OBJDATUM)
-                 NIL
-                 (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL DS)))
-
-         (* Fill in the cache with the original value This does the time-consuming part 
-       of drawing the ticks on the ruler and such, which would make drawing it on the 
-       fly unbearable.)
-
-          (IMAGEOBJPROP OBJ 'NEEDSUPDATE T)
-
-         (* And tell the display function that it needs to be updated when first 
-       displayed. Which is the faster part.)
-
-          (RETURN OBJ])
-
-(MB.MARGINBAR.SELFN
-  [LAMBDA (OBJ SELWINDOW SEL RELX RELY STREAM ORIGX ORIGY)
-                                                            (* ; "Edited 12-Jun-90 18:59 by mitani")
-                                                             (* ; 
-                                            "Let the user adjust margins and tabs using the mouse.")
-    (PROG [(OBJDATUM (IMAGEOBJPROP OBJ 'OBJECTDATUM))
-           (IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX)
-                         (IMAGEBOX OBJ STREAM 'DISPLAY]
-          (PROG ((L1 (fetch MARL1 of OBJDATUM))
-                 (LN (fetch MARLN of OBJDATUM))
-                 (R (fetch MARR of OBJDATUM))
-                 (TABS (fetch MARTABS of OBJDATUM))
-                 [SCALEDTABS (COND
-                                ((LISTP (fetch MARTABS of OBJDATUM))
-                                                             (* ; 
-                               "Only scale the tabs if there are any, and they're not neutralized.")
-                                 (for TAB in (fetch MARTABS of OBJDATUM)
-                                    collect (MSCALE (fetch TABX of TAB)
-                                                       (fetch MARUNIT of OBJDATUM]
-                 (UNIT (fetch MARUNIT of OBJDATUM))
-                 (CLIP (create REGION
-                              LEFT _ 0
-                              BOTTOM _ 0
-                              WIDTH _ (fetch XSIZE of IMAGEBOX)
-                              HEIGHT _ (fetch YSIZE of IMAGEBOX)))
-                 (RIGHTLIM (IDIFFERENCE (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL 
-                                                                                SELWINDOW))
-                                  4))
-                 TAB TABX OL1 OLN OR)
-                (SETQ OL1 L1)
-                (SETQ OLN LN)
-                (SETQ OR R)
-                [COND
-                   [(INSIDE? (create REGION
-                                    LEFT _ (IDIFFERENCE (MSCALE (ABS L1)
-                                                               UNIT)
-                                                  2)
-                                    BOTTOM _ 42
-                                    WIDTH _ 16
-                                    HEIGHT _ 16)
-                           RELX RELY)                        (* ; "Move the 1st-line left margin.")
-                    (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT))
-                                    (INSIDE? CLIP (LASTMOUSEX STREAM)
-                                           (LASTMOUSEY STREAM)))
-                       do (SETQ L1 (MAX 0 (MDESCALE (LASTMOUSEX STREAM)
-                                                     UNIT)))
-                             [COND
-                                ((\TEDIT.MOUSESTATE RIGHT)   (* ; 
-                                                           "Right mouse button UNsets the margin.")
-                                 (SETQ L1 (MINUS L1]
-                             (COND
-                                ((NOT (EQUAL OL1 L1))
-                                 (MARGINBAR STREAM L1 LN R TABS UNIT T RIGHTLIM)
-                                 (SETQ OL1 L1]
-                   [(INSIDE? (create REGION
-                                    LEFT _ (IDIFFERENCE (MSCALE (ABS LN)
-                                                               UNIT)
-                                                  2)
-                                    BOTTOM _ 26
-                                    WIDTH _ 16
-                                    HEIGHT _ 16)
-                           RELX RELY)                        (* ; "Move the skirt's left margin")
-                    (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT))
-                                    (INSIDE? CLIP (LASTMOUSEX STREAM)
-                                           (LASTMOUSEY STREAM)))
-                       do (SETQ LN (MAX 0 (MDESCALE (LASTMOUSEX STREAM)
-                                                     UNIT)))
-                             [COND
-                                ((\TEDIT.MOUSESTATE RIGHT)   (* ; 
-                                                           "Right mouse button UNsets the margin.")
-                                 (SETQ LN (MINUS LN]
-                             (COND
-                                ((NOT (EQUAL OLN LN))
-                                 (MARGINBAR STREAM L1 LN R TABS UNIT T RIGHTLIM)
-                                 (SETQ OLN LN]
-                   [(OR (INSIDE? (create REGION
-                                        LEFT _ (IDIFFERENCE (IMIN (MSCALE (ABS R)
-                                                                         UNIT)
-                                                                  (fetch XSIZE of IMAGEBOX)
-                                                                  (fetch (REGION WIDTH)
-                                                                     of (DSPCLIPPINGREGION NIL 
-                                                                                   SELWINDOW)))
-                                                      16)
-                                        BOTTOM _ 26
-                                        WIDTH _ 16
-                                        HEIGHT _ 32)
-                               RELX RELY)
-                        (AND (ZEROP (IABS (FIXR R)))
-                             (INSIDE? (create REGION
-                                             LEFT _ (IDIFFERENCE (IMIN (fetch XSIZE of 
-                                                                                             IMAGEBOX
-                                                                              )
-                                                                       (fetch (REGION WIDTH)
-                                                                          of (DSPCLIPPINGREGION
-                                                                                  NIL SELWINDOW)))
-                                                           16)
-                                             BOTTOM _ 26
-                                             WIDTH _ 16
-                                             HEIGHT _ 32)
-                                    RELX RELY)))             (* ; "Move the right margin")
-                    (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT))
-                                    (INSIDE? CLIP (LASTMOUSEX STREAM)
-                                           (LASTMOUSEY STREAM)))
-                       do (SETQ R (MAX 0 (MDESCALE (LASTMOUSEX STREAM)
-                                                    UNIT)))
-                             [COND
-                                ((\TEDIT.MOUSESTATE RIGHT)   (* ; 
-                                                           "Right mouse button UNsets the margin.")
-                                 (SETQ R (MINUS R]
-                             (COND
-                                ((NOT (EQUAL OR R))
-                                 (MARGINBAR STREAM L1 LN R TABS UNIT T RIGHTLIM)
-                                 (SETQ OR R]
-                   ((INSIDE? (create REGION
-                                    LEFT _ 0
-                                    BOTTOM _ 0
-                                    WIDTH _ (fetch (REGION WIDTH) of CLIP)
-                                    HEIGHT _ 16)
-                           RELX RELY)                        (* ; "We're in the tab ruler region")
-                    (COND
-                       ((MOUSESTATE LEFT)                    (* ; "MOVE a tab")
-                        [SETQ TAB (for TABX in SCALEDTABS as TAB in TABS
-                                     smallest (ABS (IDIFFERENCE TABX (LASTMOUSEX STREAM]
-                        (AND TAB (MB.MARGINBAR.TABTRACK STREAM OBJDATUM TAB)))
-                       [(MOUSESTATE MIDDLE)                  (* ; "ADD/CHANGE a tab")
-                        (COND
-                           ((EQ (fetch MARTABS of OBJDATUM)
-                                'NEUTRAL)                    (* ; 
-                            "The tabs used to be NEUTRAL.  Clear the tab region, and start afresh.")
-                            (replace MARTABS of OBJDATUM with NIL)
-                                                             (* ; 
-                                                           "So we don't come this way again.")
-                            (DSPFILL (create REGION
-                                            LEFT _ 2
-                                            BOTTOM _ 1
-                                            HEIGHT _ 8
-                                            WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH)
-                                                                    of (DSPCLIPPINGREGION NIL 
-                                                                                  SELWINDOW))
-                                                           4))
-                                   WHITESHADE
-                                   'REPLACE SELWINDOW)       (* ; 
-                           "Make the tab region look non-neutral, too, so that tabs look OK on it.")
-                            ))
-                        (COND
-                           ((AND [SETQ TAB (for TABX in SCALEDTABS as TAB in TABS
-                                              smallest (ABS (IDIFFERENCE TABX (LASTMOUSEX STREAM]
-                                 (SETQ TABX (MSCALE (CAR TAB)
-                                                   UNIT))
-                                 (IGEQ (LASTMOUSEX STREAM)
-                                       (IDIFFERENCE TABX 2))
-                                 (ILEQ (LASTMOUSEX STREAM)
-                                       (IPLUS TABX 2)))
-                            (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'ERASE)
-                            (replace TABKIND of TAB with (OR (fetch MARTABTYPE
-                                                                            of OBJDATUM)
-                                                                         'LEFT))
-                            (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'PAINT)
-                            (MB.MARGINBAR.TABTRACK STREAM OBJDATUM TAB))
-                           ([OR (NOT TAB)
-                                (NOT (EQP (fetch TABX of TAB)
-                                          (MDESCALE (LASTMOUSEX STREAM)
-                                                 UNIT]       (* ; "Really create a new tab")
-                            [SETQ TAB (create TAB
-                                             TABX _ (MDESCALE (LASTMOUSEX STREAM)
-                                                           UNIT)
-                                             TABKIND _ (OR (fetch MARTABTYPE of OBJDATUM)
-                                                           'LEFT]
-                            (SETQ TABS (CONS TAB TABS))
-                            (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'PAINT)
-                            (MB.MARGINBAR.TABTRACK STREAM OBJDATUM TAB]
-                       ((MOUSESTATE RIGHT)                   (* ; "DELETE a tab.")
-                        (COND
-                           ((AND [SETQ TAB (for TABX in SCALEDTABS as TAB in TABS
-                                              smallest (ABS (IDIFFERENCE TABX (LASTMOUSEX STREAM]
-                                 (SETQ TABX (MSCALE (CAR TAB)
-                                                   UNIT))
-                                 (IGEQ (LASTMOUSEX STREAM)
-                                       (IDIFFERENCE TABX 2))
-                                 (ILEQ (LASTMOUSEX STREAM)
-                                       (IPLUS TABX 2)))
-                            (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'ERASE)
-                            (SETQ TABS (LDIFFERENCE TABS (LIST TAB]
-                (replace MARL1 of OBJDATUM with L1)
-                (replace MARLN of OBJDATUM with LN)
-                (replace MARR of OBJDATUM with R)
-                (replace MARTABS of OBJDATUM with TABS)))
-    T])
-
-(MB.MARGINBAR.SIZEFN
-  [LAMBDA (OBJ)                                              (* jds " 5-Sep-84 14:10")
-    (PROG ((BOX (create IMAGEBOX
-                       XSIZE _ 1008
-                       YSIZE _ 62
-                       YDESC _ 0
-                       XKERN _ 4)))
-          (IMAGEOBJPROP OBJ 'BOUNDBOX BOX)
-          (RETURN BOX])
-
-(MB.MARGINBAR.DISPLAYFN
-  [LAMBDA (OBJ STREAM MODE)                             (* ; "Edited 12-Jun-90 18:59 by mitani")
-                                                             (* Display the innards of a menu 
-                                                           button)
-    (PROG ((IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX)
-                         (IMAGEBOX OBJ STREAM MODE)))
-           (OBJDATUM (IMAGEOBJPROP OBJ 'OBJECTDATUM))
-           BITMAP
-           (DS (DSPCREATE))
-           WASON)
-          (COND
-             [[SETQ WASON (SETQ BITMAP (IMAGEOBJPROP OBJ 'BITCACHE]
-
-         (* The marginbar existed already as an image.
-       Don't bother re-creating it, and remember that we're allowed to MODIFY the old 
-       image instead of creating a new one.)
-
-              (SETQ DS (IMAGEOBJPROP OBJ 'DSPCACHE]
-             (T                                              (* Have to create an image for the 
-                                                           margin bar)
-                (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of IMAGEBOX)
-                                    (fetch YSIZE of IMAGEBOX)))
-                                                             (* Create a cache bitmap)
-                (IMAGEOBJPROP OBJ 'BITCACHE BITMAP)
-                (SETQ DS (DSPCREATE BITMAP))
-                (IMAGEOBJPROP OBJ 'DSPCACHE DS)
-                (DSPXOFFSET 0 DS)
-                (DSPYOFFSET 0 DS)
-                (DSPCLIPPINGREGION (create REGION
-                                          LEFT _ 0
-                                          BOTTOM _ 0
-                                          WIDTH _ (fetch XSIZE of IMAGEBOX)
-                                          HEIGHT _ (fetch YSIZE of IMAGEBOX))
-                       DS)))
-          (MARGINBAR DS (fetch (MARGINBAR MARL1) of OBJDATUM)
-                 (fetch (MARGINBAR MARLN) of OBJDATUM)
-                 (fetch (MARGINBAR MARR) of OBJDATUM)
-                 (fetch (MARGINBAR MARTABS) of OBJDATUM)
-                 (fetch (MARGINBAR MARUNIT) of OBJDATUM)
-                 (OR WASON (IMAGEOBJPROP OBJ 'NEEDSUPDATE NIL))
-                 (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL STREAM)))
-                                                             (* Update the image, if it needs it)
-          (BITBLT BITMAP 0 0 STREAM (IDIFFERENCE (DSPXPOSITION NIL STREAM)
-                                           4)
-                 (IDIFFERENCE (DSPYPOSITION NIL STREAM)
-                        (fetch YDESC of IMAGEBOX])
-
-(MDESCALE
-  [LAMBDA (VAL UNIT)                                         (* jds " 4-NOV-83 17:29")
-          
-          (* Convert a value from screen offset units to marginbar units)
-
-    (COND
-       ((IEQP UNIT 12)
-        (QUOTIENT (IQUOTIENT (LLSH (IDIFFERENCE VAL 4)
-                                   1)
-                         UNIT)
-               2.0))
-       (T (QUOTIENT (DIFFERENCE VAL 4)
-                 UNIT])
-
-(MSCALE
-  [LAMBDA (VAL UNIT)                                         (* jds " 4-NOV-83 17:31")
-                                                             (* Convert from marginbar units to a 
-                                                             screen X offset)
-    (IPLUS 4 (FIXR (TIMES VAL (OR UNIT 1])
-
-(MB.MARGINBAR.SHOWTAB
-  [LAMBDA (W TAB UNIT MODE)                                  (* jds "22-Mar-85 17:36")
-          
-          (* Paint/erase/otherwise display the sign for a TAB in window WINDOW, using 
-          units UNIT)
-
-    (PROG ((TABX (MSCALE (fetch TABX of TAB)
-                        UNIT)))
-          (SELECTQ (fetch TABKIND of TAB)
-              (LEFT                                          (* Flush-left tab.)
-                    (BITBLT \TEDIT.LEFTTAB 0 0 W (IDIFFERENCE TABX 2)
-                           1 NIL NIL 'INPUT MODE))
-              (CENTERED                                      (* Centered Tab)
-                        (BITBLT \TEDIT.CENTERTAB 0 0 W (IDIFFERENCE TABX 5)
-                               1 NIL NIL 'INPUT MODE))
-              (RIGHT                                         (* Flush-right Tab)
-                     (BITBLT \TEDIT.RIGHTTAB 0 0 W (IDIFFERENCE TABX 7)
-                            1 NIL NIL 'INPUT MODE))
-              (DECIMAL                                       (* Decimal aligned tab)
-                       (BITBLT \TEDIT.DECIMALTAB 0 0 W (IDIFFERENCE TABX 7)
-                              1 NIL NIL 'INPUT MODE))
-              (DOTTEDLEFT                                    (* Decimal aligned tab)
-                          (BITBLT \TEDIT.DOTTED.LEFTTAB 0 0 W (IDIFFERENCE TABX 7)
-                                 1 NIL NIL 'INPUT MODE))
-              (DOTTEDCENTERED                                (* Decimal aligned tab)
-                   (BITBLT \TEDIT.DOTTED.CENTERTAB 0 0 W (IDIFFERENCE TABX 7)
-                          1 NIL NIL 'INPUT MODE))
-              (DOTTEDRIGHT                                   (* Decimal aligned tab)
-                           (BITBLT \TEDIT.DOTTED.RIGHTTAB 0 0 W (IDIFFERENCE TABX 7)
-                                  1 NIL NIL 'INPUT MODE))
-              (DOTTEDDECIMAL                                 (* Decimal aligned tab)
-                             (BITBLT \TEDIT.DOTTED.DECIMALTAB 0 0 W (IDIFFERENCE TABX 7)
-                                    1 NIL NIL 'INPUT MODE))
-              NIL])
-
-(MB.MARGINBAR.TABTRACK
-  [LAMBDA (STREAM OBJ TAB)                                   (* jds " 8-Feb-84 20:38")
-          
-          (* Given that the mouse is down over a tab, track the tab as the mouse moves.)
-
-    (PROG ((UNIT (fetch MARUNIT of OBJ))
-           (CLIP (DSPCLIPPINGREGION NIL STREAM))
-           (OLDX (MSCALE (fetch TABX of TAB)
-                        (fetch MARUNIT of OBJ)))
-           X)
-          (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT))
-                      (INSIDE? CLIP (LASTMOUSEX STREAM)
-                             (LASTMOUSEY STREAM))) do (COND
-                                                         ([NOT (IEQP OLDX (SETQ X (LASTMOUSEX STREAM]
-                                                          (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT
-                                                                 'ERASE)
-                                                          (replace TABX of TAB
-                                                             with (MDESCALE X UNIT))
-                                                          (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT
-                                                                 'PAINT)
-                                                          (SETQ OLDX X])
-
-(\TEDIT.TABTYPE.SET
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited 30-May-91 22:17 by jds")
-                                                             (* Change the kind of TAB that will 
-                                                           be set in the succeeding marginbar.)
-    (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-           (CH# (ADD1 (fetch (SELECTION CH#) of SEL)))
-           STATE DOTTEDBUTTON)
-          (SETQ STATE (IMAGEOBJPROP OBJ 'STATE))             (* Find out roughly what kind of TAB 
-                                                           this is to be.)
-          [SETQ STATE (U-CASE (COND
-                                 ((LISTP STATE)
-                                  (CAR STATE))
-                                 (T STATE]                   (* Make sure it's upper case, and an 
-                                                           atom.)
-          (SETQ DOTTEDBUTTON (CAR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)))
-                                                             (* Find out if this is to be a tab 
-                                                           with a dotted leader.)
-          [COND
-             ((EQ (IMAGEOBJPROP DOTTEDBUTTON 'STATE)
-                  'ON)                                       (* Yes. Make this a DOTTEDxxx tab.)
-              (SETQ STATE (PACK* 'DOTTED STATE]
-          (TEDIT.MAPPIECES TEXTOBJ [FUNCTION (LAMBDA (CH# PC PCNO FNARG)
-
-         (* Now run thru the rest of the document until we find the margin bar.
-       Replace the tab type of that margin bar with the new type.)
-
-                                               (COND
-                                                  ((AND (IGREATERP CH# (CAR FNARG))
-                                                        (fetch (PIECE POBJ) of PC)
-                                                        (type? MARGINBAR (fetch (PIECE POBJ)
-                                                                                of PC)))
-                                                   (replace MARTABTYPE
-                                                      of (IMAGEOBJPROP (fetch (PIECE POBJ)
-                                                                              of PC)
-                                                                    'OBJECTDATUM) with
-                                                                                  (CDR FNARG))
-                                                   'STOP]
-                 (CONS CH# STATE])
-
-(MARGINBAR.INIT
-  [LAMBDA NIL                                                (* jds " 9-Feb-86 15:18")
-    (SETQ MARGINBARIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.MARGINBAR.DISPLAYFN)
-                                   (FUNCTION MB.MARGINBAR.SIZEFN)
-                                   (FUNCTION MB.MARGINBAR.PUTFN)
-                                   (FUNCTION MB.MARGINBAR.GETFN)
-                                   (FUNCTION MB.COPYFN)
-                                   (FUNCTION MB.MARGINBAR.SELFN)
-                                   'NILL
-                                   'NILL
-                                   'NILL
-                                   'NILL
-                                   'NILL
-                                   'NILL
-                                   'NILL
-                                   'NILL
-                                   'MarginRuler])
-)
-
-(RPAQQ \TEDIT.LEFTTAB #*(10 8)B@@@B@@@G@@@JH@@B@@@B@@@CN@@@@@@)
-
-(RPAQQ \TEDIT.CENTERTAB #*(10 8)@D@@@D@@@N@@AE@@@D@@@D@@AO@@@@@@)
-
-(RPAQQ \TEDIT.RIGHTTAB #*(10 8)@A@@@A@@@CH@@ED@@A@@@A@@AO@@@@@@)
-
-(RPAQQ \TEDIT.DECIMALTAB #*(10 8)@A@@@A@@@CH@@ED@@A@@@CH@@CH@@@@@)
-
-(RPAQQ \TEDIT.DOTTED.LEFTTAB #*(16 8)@@H@@@H@@AL@@BJ@@@H@CFH@CFOH@@@@)
-
-(RPAQQ \TEDIT.DOTTED.CENTERTAB #*(16 8)@@A@@@A@@@CH@@ED@@A@CFA@CFGL@@@@)
-
-(RPAQQ \TEDIT.DOTTED.RIGHTTAB #*(16 8)@@@D@@@D@@@N@@AE@@@DCF@DCFGL@@@@)
-
-(RPAQQ \TEDIT.DOTTED.DECIMALTAB #*(16 8)@@@D@@@D@@@N@@AE@@@D@MHN@MHN@@@@)
-
-(RPAQQ TEDIT.EXTENDEDRIGHTMARK #*(8 32)FF@@FF@@FF@@FF@@LL@@LL@@LL@@LL@@LL@@LL@@LL@@LL@@FF@@FF@@FF@@FF@@CC@@CC@@CC@@CC@@CC@@CC@@CC@@CC@@FF@@FF@@FF@@FF@@LL@@LL@@LL@@LL@@
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS MARGINBARIMAGEFNS)
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(MARGINBAR.INIT)
-
-
-(ADDTOVAR IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN))
-)
-
-
-
-(* ;; "Text menu creation and support")
-
-(DEFINEQ
-
-(\TEXTMENU.START
-  [LAMBDA (MENU MAINWINDOW TITLE HEIGHT)      (* ; 
-                                                "Edited  4-Jun-93 11:59 by sybalsky:mv:envos")
-
-    (* ;; "Create a TEdit-based menu for a given main window.")
-
-    (PROG ([WREG (COND
-                    (MAINWINDOW (WINDOWPROP MAINWINDOW 'REGION))
-                    (T (GETREGION]
-           (CH#1 NIL)
-           MENUW MENUTEXT)
-          (COND
-             ((AND MAINWINDOW (WINDOWPROP MAINWINDOW 'TEDITMENU))
-                                                             (* ; 
-                                       "This is a menu window.  It can't have a menu, so bail out.")
-              (RETURN))
-             ([AND MAINWINDOW (for WW in (ATTACHEDWINDOWS MAINWINDOW)
-                                 thereis (EQUAL (OR TITLE "TEdit Menu")
-                                                    (WINDOWPROP WW 'TEDITMENU]
-                                                             (* ; 
-                                       "If this main window already has a menu, don't add another.")
-              (RETURN)))
-          (SETQ MENUW (CREATEW (SETQ WREG (COND
-                                             (MAINWINDOW (create REGION
-                                                                LEFT _ (fetch (REGION LEFT)
-                                                                          of WREG)
-                                                                BOTTOM _ (fetch (REGION TOP)
-                                                                            of WREG)
-                                                                WIDTH _ (fetch (REGION WIDTH)
-                                                                           of WREG)
-                                                                HEIGHT _ (OR HEIGHT 133)))
-                                             (T WREG)))
-                             (OR TITLE "TEdit Menu")))
-          (WINDOWADDPROP MENUW 'CLOSEFN 'TEXTMENU.CLOSEFN)
-          (WINDOWPROP MENUW 'TEDITMENU (OR TITLE "TEdit Menu"))
-                                                             (* ; 
-                                                           "Mark this as a TEDIT MENU window")
-          (ATTACHWINDOW MENUW MAINWINDOW 'TOP 'JUSTIFY 'LOCALCLOSE)
-          (SETQ MENUTEXT MENU)
-          (replace (TEXTOBJ MENUFLG) of (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-             with T)
-          [AND MAINWINDOW (WINDOWPROP MENUW 'PROMPTWINDOW (WINDOWPROP MAINWINDOW 'PROMPTWINDOW]
-          [TEDIT MENUTEXT MENUW NIL (LIST 'TITLEMENUFN 'DON'T 'PROMPTWINDOW (fetch (TEXTOBJ
-                                                                                        PROMPTWINDOW)
-                                                                               of (TEXTOBJ 
-                                                                                           MAINWINDOW
-                                                                                             ]
-          (AND MAINWINDOW (TTY.PROCESS (WINDOWPROP MAINWINDOW 'PROCESS])
-
-(\TEXTMENU.DOC.CREATE
-  [LAMBDA (MENUDESC MENUPROPS)                          (* ; "Edited 12-Jun-90 19:00 by mitani")
-
-         (* Create the TEXTSTREAM for a menu, given a description.
-       That stream is passed to \TEXTMENU.START to get the menu up on screen)
-
-    (PROG ((CH#1 NIL)
-           MENUW MENUTEXT)
-          [SETQ MENUTEXT (OPENTEXTSTREAM "" NIL NIL NIL (OR MENUPROPS '(FONT (MODERN 10]
-          (bind (CH# _ 1)
-                 OBJ for DESC in MENUDESC
-             do (SELECTQ (CAR DESC)
-                        (*                                   (* This is a comment within a menu 
-                                                           description -- Ignore it.))
-                        (MB.BUTTON                           (* A menu button --
-                                                           hitting it calls a function)
-                                   (TEDIT.INSERT.OBJECT (MBUTTON.CREATE
-                                                         (MKATOM (fetch (MB.BUTTON MBLABEL)
-                                                                    of DESC))
-                                                         (fetch (MB.BUTTON MBBUTTONEVENTFN)
-                                                            of DESC)
-                                                         (fetch (MB.BUTTON MBFONT) of DESC))
-                                          MENUTEXT CH#)
-                                   (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                          '(PROTECTED OFF)
-                                          CH# 1)
-                                   (add CH# 1))
-                        (MB.3STATE                           (* 3-state button;
-                                                           hitting it changes state among ON, 
-                                                           OFF, and NEUTRAL.)
-                                   (TEDIT.INSERT.OBJECT (MB.CREATE.THREESTATEBUTTON
-                                                         (MKATOM (fetch (MB.3STATE MBLABEL)
-                                                                    of DESC))
-                                                         (fetch (MB.3STATE MBFONT) of DESC)
-                                                         (fetch (MB.3STATE MBCHANGESTATEFN)
-                                                            of DESC)
-                                                         (fetch (MB.3STATE MBINITSTATE)
-                                                            of DESC))
-                                          MENUTEXT CH#)
-                                   (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                          '(PROTECTED OFF)
-                                          CH# 1)
-                                   (add CH# 1))
-                        (MB.TOGGLE                           (* TOGGLE button; hitting it 
-                                                           switches between ON and OFF.)
-                                   (TEDIT.INSERT.OBJECT (\TEXTMENU.TOGGLE.CREATE
-                                                         (MKATOM (fetch (MB.TOGGLE MBTEXT)
-                                                                    of DESC))
-                                                         (fetch (MB.TOGGLE MBFONT) of DESC)
-                                                         (fetch (MB.TOGGLE MBCHANGESTATEFN)
-                                                            of DESC)
-                                                         (fetch (MB.TOGGLE MBINITSTATE)
-                                                            of DESC))
-                                          MENUTEXT CH#)
-                                   (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                          '(PROTECTED OFF)
-                                          CH# 1)
-                                   (add CH# 1))
-                        (MB.NWAY                             (* N-way buttons; choosing one turns 
-                                                           the others off.)
-                                 (SETQ OBJ (MB.CREATE.NWAYBUTTON (fetch (MB.NWAY MBBUTTONS)
-                                                                        of DESC)
-                                                  (fetch (MB.NWAY MBFONT) of DESC)
-                                                  (fetch (MB.NWAY MBCHANGESTATEFN) of DESC)
-                                                  (fetch (MB.NWAY MBINITSTATE) of DESC)
-                                                  (fetch (MB.NWAY MBMAXITEMSPERLINE) of
-                                                                                         DESC)))
-                                 (TEDIT.INSERT.OBJECT OBJ MENUTEXT CH#)
-                                 (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                        '(PROTECTED OFF)
-                                        CH# 1)
-                                 (add CH# 1))
-                        (MENU                                (* Real menu, except the selection 
-                                                           sticks)
-                              (TEDIT.INSERT.OBJECT (MB.CREATE.FULLMENU (CADR DESC))
-                                     MENUTEXT CH#)
-                              (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                     '(PROTECTED OFF)
-                                     CH# 1)
-                              (add CH# 1))
-                        (MB.MARGINBAR                        (* Margin ruler for TEdit formatting)
-                                      (TEDIT.INSERT.OBJECT (MARGINBAR.CREATE -0.5 -0.5 -39.5 NIL
-                                                                  12)
-                                             MENUTEXT CH#)
-                                      (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                             '(PROTECTED OFF)
-                                             CH# 1)
-                                      (add CH# 1))
-                        (MB.TEXT                             (* Arbitrary text, which will be 
-                                                           protected from the user.)
-                                 (TEDIT.INSERT MENUTEXT (fetch (MB.TEXT MBSTRING) of DESC)
-                                        CH#)
-                                 [AND (fetch (MB.TEXT MBFONT) of DESC)
-                                      (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                             (LIST 'MBFONT (fetch (MB.TEXT MBFONT) of DESC))
-                                             CH#
-                                             (NCHARS (fetch (MB.TEXT MBSTRING) of DESC]
-                                 (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                        '(PROTECTED ON)
-                                        CH#
-                                        (NCHARS (fetch (MB.TEXT MBSTRING) of DESC)))
-                                 (add CH# (NCHARS (fetch (MB.TEXT MBSTRING) of DESC))))
-                        (MB.INSERT                           (* An insertion point, with optional 
-                                                           text to put there)
-                                   (TEDIT.INSERT MENUTEXT "  {}" CH#)
-                                   (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                          '(PROTECTED ON)
-                                          CH# 4)
-                                   (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                          '(PROTECTED ON SELECTPOINT ON)
-                                          (IPLUS CH# 2)
-                                          1)
-                                   (OR CH#1 (SETQ CH#1 (IPLUS CH# 3)))
-                                   [COND
-                                      ((fetch (MB.INSERT MBINITENTRY) of DESC)
-                                                             (* There is an initial entry to be 
-                                                           made. Make it)
-                                       [COND
-                                          ((IMAGEOBJP (fetch (MB.INSERT MBINITENTRY) of
-                                                                                         DESC))
-                                                             (* It is an imageobj.)
-                                           (TEDIT.INSERT.OBJECT (fetch (MB.INSERT MBINITENTRY)
-                                                                   of DESC)
-                                                  MENUTEXT
-                                                  (IPLUS CH# 3)))
-                                          (T                 (* It's regular text.)
-                                             (TEDIT.INSERT MENUTEXT (MKSTRING (fetch (MB.INSERT
-                                                                                          MBINITENTRY
-                                                                                          )
-                                                                                 of DESC))
-                                                    (IPLUS CH# 3]
-                                       [TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-                                              '(PROTECTED OFF SELECTPOINT OFF)
-                                              (IPLUS CH# 3)
-                                              (NCHARS (MKSTRING (fetch (MB.INSERT MBINITENTRY)
-                                                                   of DESC]
-                                       (add CH# (NCHARS (fetch (MB.INSERT MBINITENTRY)
-                                                               of DESC]
-                                   (add CH# 4))
-                        (\ILLEGAL.ARG DESC)))
-          (replace (TEXTOBJ MENUFLG) of (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT)
-             with T)                                     (* Remember that this is a menu)
-          [COND
-             (CH#1                                           (* We actually inserted some text, 
-                                                           so it makes sense to put up a 
-                                                           selection)
-                   (push (fetch (TEXTOBJ EDITPROPS) of (fetch (TEXTSTREAM TEXTOBJ)
-                                                                      of MENUTEXT))
-                          (LIST 'SEL CH#1]                   (* And where the first selection 
-                                                           should be.)
-          (RETURN MENUTEXT])
-
-(TEXTMENU.CLOSEFN
-  [LAMBDA (W)                                           (* ; "Edited 12-Jun-90 18:59 by mitani")
-
-    (* ;; "CLOSE a TEdit menu window: Detach the menu, then reshape the remaining windows to take up the remaining space")
-
-    (PROG ((MAINW (WINDOWPROP W 'MAINWINDOW))
-           TEXTOBJ HEIGHT OHEIGHT OBOTTOM WBOTTOM WINDOWS)
-          (FREEATTACHEDWINDOW W)                             (* (DETACHWINDOW W)
-                                                           (* ; "So detach this window.")
-                                                           (COND ((IGREATERP (FLENGTH
-                                                           (ATTACHEDWINDOWS MAINW)) 1)
-                                                           (SETQ OHEIGHT (fetch
-                                                           (REGION HEIGHT) of
-                                                           (WINDOWPROP W (QUOTE REGION))))
-                                                           (SETQ OBOTTOM (fetch
-                                                           (REGION BOTTOM) of
-                                                           (WINDOWPROP W (QUOTE REGION))))
-                                                           (CLOSEW W) (SETQ WINDOWS
-                                                           (SORT (ATTACHEDWINDOWS MAINW)
-                                                           (FUNCTION (LAMBDA (WW)
-                                                           (fetch (REGION BOTTOM) of
-                                                           (WINDOWPROP WW (QUOTE REGION)))))))
-                                                           (for WW in WINDOWS when
-                                                           (IGEQ (SETQ WBOTTOM
-                                                           (fetch (REGION BOTTOM) of
-                                                           (WINDOWPROP WW (QUOTE REGION)))) 
-                                                           OBOTTOM) do (MOVEW WW
-                                                           (fetch (REGION LEFT) of
-                                                           (WINDOWPROP WW (QUOTE REGION)))
-                                                           (IDIFFERENCE WBOTTOM OHEIGHT))))))
-          (COND
-             ((SETQ TEXTOBJ (WINDOWPROP W 'TEXTOBJ))         (* ; 
-                   "Then, if this window still has a textobj under it, kill off that edit process.")
-              (TEDIT.KILL TEXTOBJ)
-
-              (* ;; "This has to be TEDIT.KILL to avoid problems with the TTY being handed from main back to menu, causing main never to finish off;  menu would quit and hand TTY to top level window.")
-
-              ])
-)
-
-(RPAQQ TEXTMENUICON #*(16 24)@@@@@@@@@@@@H@@@L@@AK@@GHLAIHCFAJ@HAKFKIJJJAJBKIJBJAH@KIJDHAKDJIJLJIJDJIJDJIH@KIF@HFAHIH@FN@@@H@
-)
-
-(RPAQQ TEXTMENUICONMASK #*(16 24)@@@@@@@@@@@@H@@@L@@AO@@GOLAOOOGOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOGOONAOOH@GN@@@H@
-)
-
-
-
-(* ; "TEdit-specific support")
-
-(DEFINEQ
-
-(\TEDITMENU.CREATE
-  [LAMBDA NIL                                                (* gbn "27-Sep-84 01:04")
-                                                             (* Creates the TEdit Expanded Menu)
-    (SETQ TEDIT.EXPANDED.MENU (\TEXTMENU.DOC.CREATE TEDIT.EXPANDEDMENU.SPEC])
-
-(\TEDIT.EXPANDED.MENU
-  [LAMBDA (STREAM)                                           (* ; "Edited 20-Aug-87 16:51 by jds")
-                                                             (* "27-Sep-84 01:04" gbn)
-    (PROG (CHARMENUTEXTSTREAM)
-          (\TEXTMENU.START (SETQ CHARMENUTEXTSTREAM (COPYTEXTSTREAM TEDIT.EXPANDED.MENU T))
-                 (\TEDIT.PRIMARYW (TEXTOBJ STREAM))
-                 "TEdit Menu"
-                 (HEIGHTIFWINDOW 60 T))
-          (COND
-             ((OR (TEXTPROP STREAM 'CLEARGET)
-                  (TEXTPROP STREAM 'CLEARPUT))               (* initialise the button)
-              (\TEXTMENU.SET.TOGGLE "Unformatted" 'ON CHARMENUTEXTSTREAM])
-
-(MB.DEFAULTBUTTON.FN
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited 30-Mar-94 15:46 by jds")
-                                                             (* ; 
-                                                        "MBFN for TEdit default menu item buttons.")
-    (PROG* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-            (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                             'TEXTOBJ))
-            (MAINSEL (fetch (TEXTOBJ SEL) of MAINTEXT))
-            OFILE CH PROC)
-           (COND
-              ((EQ (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT)
-                   T)
-               (TEDIT.PROMPTPRINT MAINTEXT "Edit operation in progress; please wait." T)
-               (RETURN))
-              ((fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT)
-               (TEDIT.PROMPTPRINT MAINTEXT (CONCAT (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT)
-                                                  " operation in progress; please wait.")
-                      T)
-               [AND (NEQ (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT)
-                         (IMAGEOBJPROP OBJ 'MBTEXT]
-               (RETURN)))
-           [COND
-              ((AND (SETQ PROC (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                                      'PROCESS))
-                    (PROCESSP PROC))                         (* ; 
-                  "THE MAIN window has a live process behind it;  go evaluate the button fn there.")
-               (PROCESS.EVAL PROC (LIST 'MB.DEFAULTBUTTON.ACTIONFN OBJ SEL W TEXTOBJ MAINTEXT MAINSEL
-                                        )))
-              ((AND (SETQ PROC (WINDOWPROP W 'PROCESS))
-                    (PROCESSP PROC))                         (* ; 
-                      "This window has a live process behind it;  go evaluate the button fn there.")
-               (PROCESS.EVAL PROC (LIST 'MB.DEFAULTBUTTON.ACTIONFN OBJ SEL W TEXTOBJ MAINTEXT MAINSEL
-                                        )))
-              (T (ADD.PROCESS (LIST 'MB.DEFAULTBUTTON.ACTIONFN OBJ SEL W TEXTOBJ MAINTEXT MAINSEL]
-           (COND
-              ((fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)
-               (GIVE.TTY.PROCESS W)
-               (DISMISS 20)))
-           [COND
-              ((OR (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ)
-                   (EQ (WINDOWPROP W 'PROCESS)
-                       (TTY.PROCESS)))                       (* ; 
-                             "If the TEDIT MENU still has the tty, give it back to the real TEdit.")
-               (SETQ TEDIT.SELPENDING NIL)
-               (GIVE.TTY.PROCESS (WINDOWPROP W 'MAINWINDOW]
-
-     (* ;; "Tell the menu button handler not to turn off this button--it's still active and will turn itself off.")
-
-           (RETURN 'DON'T])
-
-(\TEDITMENU.RECORD.UNFORMATTED
-  [LAMBDA (BUTTON NEWSTATE TEXTSTREAM)                       (* jds " 7-Feb-85 09:44")
-    (PROG ((FLG (COND
-                   ((EQ NEWSTATE 'ON)
-                    T)
-                   (T NIL)))
-           (TEXTOBJ (TEXTOBJ TEXTSTREAM)))
-          (TEXTPROP TEXTOBJ 'UNFORMATTEDPUT/GET FLG])
-
-(MB.DEFAULTBUTTON.ACTIONFN
-  [LAMBDA (OBJ SEL W TEXTOBJ MAINTEXT MAINSEL)           (* ; "Edited 30-Mar-94 16:04 by jds")
-                                                             (* ; 
-                                                        "MBFN for TEdit default menu item buttons.")
-    (PROG (OFILE CH %#COPIES PRINTHOST PRINTOPTIONS %#SIDES MSG)
-          [ERSETQ (RESETLST
-                      [RESETSAVE (\TEDIT.MARKACTIVE MAINTEXT)
-                             '(AND (\TEDIT.MARKINACTIVE OLDVALUE]
-                      [RESETSAVE (\TEDIT.MARKACTIVE TEXTOBJ)
-                             '(AND (\TEDIT.MARKINACTIVE OLDVALUE]
-                      [RESETSAVE (PROG1 OBJ
-                                     (IMAGEOBJPROP OBJ 'MENUBUTTON.SELECTED T))
-                             '(AND (IMAGEOBJPROP OLDVALUE 'MENUBUTTON.SELECTED NIL]
-                      (replace (TEXTOBJ EDITOPACTIVE) of MAINTEXT
-                         with (OR (IMAGEOBJPROP OBJ 'MBTEXT)
-                                      T))                    (* ; 
-                                                        "So we can tell the guy WHAT op is active.")
-                      (SELECTQ (IMAGEOBJPROP OBJ 'MBTEXT)
-                          (Put [SETQ OFILE (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT
-                                                                 TEXTOBJ
-                                                                 (fetch (SELECTION CH#)
-                                                                    of SEL]
-                               [COND
-                                  (OFILE                     (* ; 
-                                                     "Only try this if he really typed a file name")
-                                         (TEDIT.PUT MAINTEXT OFILE NIL (TEXTPROP TEXTOBJ 
-                                                                              'UNFORMATTEDPUT/GET])
-                          (Get [SETQ OFILE (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT
-                                                                 TEXTOBJ
-                                                                 (fetch (SELECTION CH#)
-                                                                    of SEL]
-                               [COND
-                                  (OFILE                     (* ; 
-                                                     "Only try this if he really typed a file name")
-                                         (TEDIT.GET MAINTEXT OFILE (TEXTPROP TEXTOBJ 
-                                                                          'UNFORMATTEDPUT/GET])
-                          (Include [SETQ OFILE (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT
-                                                                     TEXTOBJ
-                                                                     (fetch (SELECTION CH#)
-                                                                        of SEL]
-                                   (COND
-                                      (OFILE (TEDIT.INCLUDE MAINTEXT OFILE))))
-                          (Find (SETQ OFILE (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ
-                                                   (fetch (SELECTION CH#) of SEL)))
-                                [COND
-                                   ((ZEROP (NCHARS OFILE))   (* ; "NOTHING--HE HIT DEL.")
-                                    )
-                                   (OFILE                    (* ; 
-                                                           "There's something to do.  Go do it.")
-                                          (TEDIT.PROMPTPRINT MAINTEXT "Searching..." T)
-                                          [SETQ CH (CAR (ERSETQ (TEDIT.FIND MAINTEXT OFILE NIL NIL T]
-                                          (COND
-                                             (CH             (* ; "We found the target text.")
-                                                 (TEDIT.PROMPTPRINT MAINTEXT "Done.")
-                                                 (\SHOWSEL MAINSEL NIL NIL)
-                                                 (replace (SELECTION CH#) of MAINSEL
-                                                    with (CAR CH))
-                                                             (* ; 
-                                                           "Set up SELECTION to be the found text")
-                                                 (replace (SELECTION CHLIM) of MAINSEL
-                                                    with (ADD1 (CADR CH)))
-                                                 [replace (SELECTION DCH) of MAINSEL
-                                                    with (ADD1 (IDIFFERENCE (CADR CH)
-                                                                          (CAR CH]
-                                                 (replace (SELECTION POINT) of MAINSEL
-                                                    with 'RIGHT)
-                                                 (replace (TEXTOBJ CARETLOOKS) of MAINTEXT
-                                                    with (\TEDIT.GET.INSERT.CHARLOOKS MAINTEXT 
-                                                                    MAINSEL))
-                                                             (* ; 
-                                          "Set the caret looks to match those of the new selection")
-                                                 (TEDIT.RESET.EXTEND.PENDING.DELETE MAINSEL)
-                                                             (* ; "And never pending a deletion.")
-                                                 (\FIXSEL MAINSEL MAINTEXT)
-                                                 (TEDIT.NORMALIZECARET MAINTEXT MAINSEL)
-                                                 (\SHOWSEL MAINSEL NIL T))
-                                             (T (TEDIT.PROMPTPRINT MAINTEXT "(Not found)"])
-                          (Substitute [PROG* ((SAVECH# (fetch (SELECTION CH#) of SEL))
-                                              (REPLACEMENT (MBUTTON.NEXT.FIELD.AS.TEXT
-                                                            TEXTOBJ
-                                                            (fetch (SELECTION CH#) of SEL)))
-                                              [PATTERN (MBUTTON.NEXT.FIELD.AS.TEXT
-                                                        TEXTOBJ
-                                                        (fetch (SELECTION CHLIM)
-                                                           of (fetch (TEXTOBJ SCRATCHSEL)
-                                                                     of TEXTOBJ]
-                                              CONFIRM? KEEPLOOKS? LOC)
-                                             [SETQ LOC (MBUTTON.FIND.NEXT.BUTTON
-                                                        TEXTOBJ
-                                                        (fetch (SELECTION CHLIM)
-                                                           of (fetch (TEXTOBJ SCRATCHSEL)
-                                                                     of TEXTOBJ]
-                                             [SETQ CONFIRM? (EQ 'ON (IMAGEOBJPROP (CAR LOC)
-                                                                           'STATE]
-                                             [SETQ LOC (MBUTTON.FIND.NEXT.BUTTON
-                                                        TEXTOBJ
-                                                        (ADD1 (CDR LOC]
-                                             [SETQ KEEPLOOKS? (EQ 'ON (IMAGEOBJPROP (CAR LOC)
-                                                                             'STATE]
-                                             (COND
-                                                ((ZEROP (NCHARS PATTERN))
-                                                             (* ; "NOTHING--HE HIT DEL.")
-                                                 )
-                                                (PATTERN     (* ; 
-                                                           "There's something to do.  Go do it.")
-                                                       [COND
-                                                          (KEEPLOOKS? (SETQ REPLACEMENT
-                                                                       (
-                                                                      MBUTTON.NEXT.FIELD.AS.PIECES
-                                                                        TEXTOBJ SAVECH#]
-                                                       (RESETLST
-                                                           (RESETSAVE (CURSOR WAITINGCURSOR))
-                                                           (TEDIT.SUBSTITUTE (fetch (TEXTOBJ
-                                                                                         STREAMHINT)
-                                                                                of MAINTEXT)
-                                                                  PATTERN REPLACEMENT CONFIRM?))])
-                          (Quit                              (* ; "He wants to QUIT the edit.")
-                                (COND
-                                   ((\TEDIT.QUIT (\TEDIT.PRIMARYW MAINTEXT)
-                                           T)
-                                    (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ
-                                       with T))))
-                          (Page% Layout                      (* ; "Page layout menu")
-                                        (\TEXTMENU.START (COPYTEXTSTREAM TEDIT.EXPANDED.PAGEMENU
-                                                                    T)
-                                               (\TEDIT.PRIMARYW MAINTEXT)
-                                               "Page Layout Menu"
-                                               (HEIGHTIFWINDOW 135 5)))
-                          (Para% Looks                       (* ; "Page layout menu")
-                                       (\TEDIT.EXPANDEDPARA.MENU MAINTEXT))
-                          (Char% Looks                       (* ; "Page layout menu")
-                                       (\TEDIT.EXPANDEDCHARLOOKS.MENU MAINTEXT))
-                          (All                               (* ; "Select the entire document.")
-                               (COND
-                                  ((NOT (ZEROP (fetch (TEXTOBJ TEXTLEN) of MAINTEXT)))
-                                   (\SHOWSEL MAINSEL NIL NIL)
-                                   (TEDIT.RESET.EXTEND.PENDING.DELETE MAINSEL)
-                                   (replace (SELECTION CH#) of MAINSEL with 1)
-                                   (replace (SELECTION CHLIM) of MAINSEL
-                                      with (ADD1 (fetch (TEXTOBJ TEXTLEN) of MAINTEXT)))
-                                   (replace (SELECTION DCH) of MAINSEL
-                                      with (fetch (TEXTOBJ TEXTLEN) of MAINTEXT))
-                                   (replace (SELECTION POINT) of MAINSEL with
-                                                                                 'LEFT)
-                                   (replace (SELECTION SET) of MAINSEL with T)
-                                   (\FIXSEL MAINSEL MAINTEXT)
-                                   (\SHOWSEL MAINSEL NIL T))))
-                          (Hardcopy [SETQ PRINTHOST (\TEDIT.MAKEFILENAME (
-                                                                        MBUTTON.NEXT.FIELD.AS.TEXT
-                                                                          TEXTOBJ
-                                                                          (fetch (SELECTION
-                                                                                      CH#)
-                                                                             of SEL]
-                                    (COND
-                                       ((NOT PRINTHOST)      (* ; 
-                                   "If he didn't specify a particular host, defer to his defaults.")
-                                        (TEDIT.PROMPTPRINT MAINTEXT "Using default print server.")))
-                                    [SETQ %#COPIES (MBUTTON.NEXT.FIELD.AS.NUMBER
-                                                    TEXTOBJ
-                                                    (fetch (SELECTION CH#)
-                                                       of (fetch (TEXTOBJ SCRATCHSEL)
-                                                                 of TEXTOBJ]
-                                                             (* ; 
-                                                  "Grab the field that specifies number of copies.")
-                                    [COND
-                                       (%#COPIES (SETQ PRINTOPTIONS (LIST '%#COPIES %#COPIES]
-                                    (SETQ %#SIDES
-                                     (SELECTQ (IMAGEOBJPROP [CAR (MBUTTON.FIND.NEXT.BUTTON
-                                                                  TEXTOBJ
-                                                                  (fetch (SELECTION CHLIM)
-                                                                     of (fetch (TEXTOBJ
-                                                                                        SCRATCHSEL)
-                                                                               of TEXTOBJ]
-                                                     'STATE)
-                                         (One% Side 1)
-                                         (Duplex 2)
-                                         NIL))
-                                    [COND
-                                       (%#SIDES (push PRINTOPTIONS %#SIDES)
-                                              (push PRINTOPTIONS '%#SIDES]
-                                    [SETQ MSG (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT
-                                                                    TEXTOBJ
-                                                                    (fetch (SELECTION CH#)
-                                                                       of (fetch (TEXTOBJ
-                                                                                          SCRATCHSEL)
-                                                                                 of TEXTOBJ]
-                                    [COND
-                                       (MSG (push PRINTOPTIONS MSG)
-                                            (push PRINTOPTIONS 'MESSAGE]
-                                    (TEDIT.HARDCOPY MAINTEXT NIL NIL NIL PRINTHOST PRINTOPTIONS))
-                          (ERROR)))]
-          (replace (SELECTION SET) of SEL with T)(* ; 
-                                                       "Now turn the menu button highlighting off.")
-          (replace (SELECTION ONFLG) of SEL with T)
-          (\SHOWSEL SEL NIL NIL)
-          (replace (SELECTION SET) of SEL with NIL)
-                                                             (* ; 
-                                                           "And forget that anything is selected.")
-      ])
-)
-(DEFINEQ
-
-(\TEDIT.CHARLOOKSMENU.CREATE
-  [LAMBDA NIL                                                (* ; "Edited 20-Aug-87 16:50 by jds")
-                                                             (* ; "Creates the TEdit Expanded Menu")
-
-    (SETQ TEDIT.CHARLOOKS.MENU (\TEXTMENU.DOC.CREATE (APPEND (LIST (create MB.BUTTON
-                                                                          MBLABEL _ 'APPLY
-                                                                          MBBUTTONEVENTFN _
-                                                                          '\TEDIT.APPLY.CHARLOOKS)
-                                                                   (create MB.TEXT
-                                                                          MBSTRING _ "   ")
-                                                                   (create MB.BUTTON
-                                                                          MBLABEL _ 'SHOW
-                                                                          MBBUTTONEVENTFN _
-                                                                          '\TEDIT.SHOW.CHARLOOKS)
-                                                                   (create MB.TEXT
-                                                                          MBSTRING _ "   ")
-                                                                   (create MB.BUTTON
-                                                                          MBLABEL _ 'NEUTRAL
-                                                                          MBBUTTONEVENTFN _
-                                                                          '
-                                                                          \TEDIT.NEUTRALIZE.CHARLOOKS
-                                                                          )
-                                                                   (create MB.TEXT
-                                                                          MBSTRING _ "
-"))
-                                                            TEDIT.CHARLOOKSMENU.SPEC])
-
-(\TEDIT.EXPANDEDCHARLOOKS.MENU
-  [LAMBDA (STREAM)                                           (* ; "Edited 20-Aug-87 16:49 by jds")
-          
-          (* ;; "Open a character-looks menu.")
-
-    (\TEXTMENU.START (COPYTEXTSTREAM TEDIT.CHARLOOKS.MENU T)
-           (\TEDIT.PRIMARYW STREAM)
-           "Character Looks Menu"
-           (HEIGHTIFWINDOW 68 T])
-
-(\TEDIT.APPLY.BOLDNESS
-  [LAMBDA (BUTTON NEWLOOKS)                                  (* jds "30-Aug-84 13:55")
-    (SELECTQ (IMAGEOBJPROP BUTTON 'STATE)
-        (ON (CONS 'WEIGHT (CONS 'BOLD NEWLOOKS)))
-        (OFF (CONS 'WEIGHT (CONS 'MEDIUM NEWLOOKS)))
-        NEWLOOKS])
-
-(\TEDIT.APPLY.CHARLOOKS
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited 30-May-91 22:17 by jds")
-                                                             (* MBFN for TEdit default menu item 
-                                                           buttons.)
-    (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-           (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                            'TEXTOBJ))
-           (CH# (ADD1 (fetch (SELECTION CH#) of SEL)))
-           SCRATCHSEL OFILE CH NEWLOOKS SIZE SUPER SUB NEXTB BUTTON TEXT OFFSET)
-          [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#]
-                                                             (* Skip over the SHOW button)
-          [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#]
-                                                             (* And over the NEUTRAL button.)
-          (SETQ NEWLOOKS (\TEDIT.PARSE.CHARLOOKS.MENU TEXTOBJ CH#))
-                                                             (* Now Parse the menu, to give us a 
-                                                           looks spec.)
-          (TEDIT.LOOKS MAINTEXT NEWLOOKS (fetch (SELECTION CH#) of (fetch (TEXTOBJ SEL)
-                                                                              of MAINTEXT))
-                 (fetch (SELECTION DCH) of (fetch (TEXTOBJ SEL) of MAINTEXT)))
-                                                             (* Make the change in looks)
-          (\SHOWSEL SEL NIL NIL)                             (* And turn off the APPLY button.)
-          (TTY.PROCESS (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                              'PROCESS))                     (* Leave him typing in the real 
-                                                           document)
-      ])
-
-(\TEDIT.APPLY.OLINE
-  [LAMBDA (BUTTON NEWLOOKS)                                  (* jds "30-Aug-84 13:56")
-    (SELECTQ (IMAGEOBJPROP BUTTON 'STATE)
-        (ON (CONS 'OVERLINE (CONS 'ON NEWLOOKS)))
-        (OFF (CONS 'OVERLINE (CONS 'OFF NEWLOOKS)))
-        NEWLOOKS])
-
-(\TEDIT.SHOW.CHARLOOKS
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited 30-May-91 22:17 by jds")
-
-    (* ;; "Set the CHARLOOKS menu from the looks of the currently selected character.")
-
-    (LET* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-           (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                            'TEXTOBJ))
-           (MAINCH# (fetch (SELECTION CH#) of (fetch (TEXTOBJ SEL) of MAINTEXT)))
-           (CH# (ADD1 (fetch (SELECTION CH#) of SEL)))
-           (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-           PC OFILE CH NEWLOOKS NEXTB BUTTON TEXT OFFSET)
-          (COND
-             ((<= MAINCH# (fetch (TEXTOBJ TEXTLEN) of MAINTEXT))
-              [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#]
-                                                             (* ; "Skip over the NEUTRAL button.")
-              (\SHOWSEL SEL NIL NIL)
-              (replace (SELECTION SET) of SEL with NIL)
-              (SETQ PC (\CHTOPC MAINCH# (fetch (TEXTOBJ PCTB) of MAINTEXT)))
-                                                             (* ; 
-                                                        "The PIECE containing the text to describe")
-              (SETQ NEWLOOKS (fetch (PIECE PLOOKS) of PC))
-                                                             (* ; 
-                                                           "Get the looks for those characters.")
-              (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL (\TEDIT.FILL.IN.CHARLOOKS.MENU TEXTOBJ CH# 
-                                                         NEWLOOKS))
-                                                             (* ; 
-                                                           "Fill in the menu blanks with that info")
-              ])
-
-(\TEDIT.NEUTRALIZE.CHARLOOKS
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited 30-May-91 22:18 by jds")
-
-         (* Handle the NEUTRAL button on a character looks menu.
-       Sets all the menu settings neutral.)
-
-    (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-           (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                            'TEXTOBJ))
-           (CH# (ADD1 (fetch (SELECTION CH#) of SEL)))
-           PC SCRATCHSEL OFILE CH NEWLOOKS NEXTB BUTTON TEXT OFFSET)
-          (\SHOWSEL SEL NIL NIL)
-          (replace (SELECTION SET) of SEL with NIL)
-          (\TEDIT.NEUTRALIZE.CHARLOOKS.MENU TEXTOBJ CH#) (* Fill in the menu blanks with that 
-                                                           info)
-          (TEDIT.UPDATE.SCREEN TEXTOBJ)                      (* And update the screen image.)
-      ])
-
-(\TEDIT.FILL.IN.CHARLOOKS.MENU
-  [LAMBDA (TEXTOBJ CH# NEWLOOKS)                         (* ; "Edited 30-May-91 22:28 by jds")
-
-    (* ;; "Given a TEXTOBJ describing a charlooks menu, the CH# of the start of the charlooks menu, and a set of looks, fill in the menu fields.")
-
-    (PROG (PC SCRATCHSEL OFILE CH NEXTB BUTTON TEXT OFFSET)
-          (SETQ NEWLOOKS (\TEDIT.PARSE.CHARLOOKS.LIST NEWLOOKS NIL NIL))
-
-     (* ;; "Make sure the charlooks are in the proper internal format, so this fn can be called from every reasonable place.")
-
-          (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-          [for PROP in (LIST (fetch (CHARLOOKS CLBOLD) of NEWLOOKS)
-                                     (fetch (CHARLOOKS CLITAL) of NEWLOOKS)
-                                     (fetch (CHARLOOKS CLULINE) of NEWLOOKS)
-                                     (fetch (CHARLOOKS CLSTRIKE) of NEWLOOKS)
-                                     (fetch (CHARLOOKS CLOLINE) of NEWLOOKS))
-             do (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                   [COND
-                      (PROP                                  (* ; "Must set the property")
-                            (IMAGEOBJPROP (CAR NEXTB)
-                                   'STATE
-                                   'ON))
-                      (T                                     (* ; "Must reset it.")
-                         (IMAGEOBJPROP (CAR NEXTB)
-                                'STATE
-                                'OFF]
-                   (SETQ CH# (ADD1 (CDR NEXTB]
-          (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                                                             (* ; "Get to the start of the text.")
-          (SETQ BUTTON (CAR NEXTB))
-          [for ITEM in (IMAGEOBJPROP BUTTON 'BUTTONS)
-             do                                          (* ; 
-       "Loop thru the font FAMILY name button list, looking for one that matches this text's looks")
-                   (COND
-                      ((STRING-EQUAL [COND
-                                        ((AND (type? FONTCLASS (fetch (CHARLOOKS CLFONT)
-                                                                      of NEWLOOKS))
-                                              (NEQ (fetch FONTCLASSNAME
-                                                      of (fetch (CHARLOOKS CLFONT)
-                                                                of NEWLOOKS))
-                                                   'DEFAULTFONT))
-                                         (CONCAT (fetch FONTCLASSNAME of (fetch
-                                                                                  (CHARLOOKS CLFONT)
-                                                                                    of NEWLOOKS))
-                                                '-class))
-                                        ((FONTP (fetch (CHARLOOKS CLFONT) of NEWLOOKS))
-                                         (FONTPROP (fetch (CHARLOOKS CLFONT) of NEWLOOKS)
-                                                'FAMILY]
-                              ITEM)
-                       (IMAGEOBJPROP BUTTON 'STATE ITEM)
-                       (RETURN))) finally                (* ; 
-                                                     "This font wasn't found in the list.  Add it.")
-                                        [MB.NWAYBUTTON.ADDITEM
-                                         BUTTON
-                                         (COND
-                                            ((type? FONTCLASS (fetch (CHARLOOKS CLFONT)
-                                                                     of NEWLOOKS))
-                                             (PACK* (fetch FONTCLASSNAME
-                                                       of (fetch (CHARLOOKS CLFONT)
-                                                                 of NEWLOOKS))
-                                                    '-class))
-                                            ((FONTP (fetch (CHARLOOKS CLFONT) of NEWLOOKS))
-                                             (FONTPROP (fetch (CHARLOOKS CLFONT) of NEWLOOKS)
-                                                    'FAMILY] (* ; 
-                                                           "Add this family to the list of items")
-                                        (IMAGEOBJPROP BUTTON 'STATE (U-CASE
-                                                                     (FONTPROP (fetch
-                                                                                (CHARLOOKS CLFONT)
-                                                                                  of NEWLOOKS)
-                                                                            'FAMILY]
-                                                             (* ; 
-                                                           "Now find which text button was 'on'")
-          (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB))
-                 NIL)                                        (* ; 
-                                                           "Clean out the 'other font' field")
-          (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                 (fetch (CHARLOOKS CLSIZE) of NEWLOOKS))
-                                                             (* ; "Set the value in the SIZE field")
-          [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                     of SCRATCHSEL]
-                                                             (* ; 
-                                                 "Move forward to the SUPERSCRIPT/SUBSCRIPT button")
-          (SETQ BUTTON (CAR NEXTB))
-          (SETQ OFFSET (fetch (CHARLOOKS CLOFFSET) of NEWLOOKS))
-                                                             (* ; 
-                                                           "Remember the offset value for later")
-          [COND
-             ((OR (NOT (fetch (CHARLOOKS CLOFFSET) of NEWLOOKS))
-                  (ZEROP (fetch (CHARLOOKS CLOFFSET) of NEWLOOKS)))
-                                                             (* ; 
-                                     "There is no subscript or superscript.  Mark the text NORMAL.")
-              (IMAGEOBJPROP BUTTON 'STATE 'Normal)
-              (SETQ OFFSET NIL)                              (* ; 
-                                                           "Mark there as being no offset value")
-              )
-             ((ILESSP OFFSET 0)                              (* ; "SUBSCRIPTING")
-              (IMAGEOBJPROP BUTTON 'STATE 'Subscript))
-             ((IGREATERP OFFSET 0)                           (* ; "SUBSCRIPTING")
-              (IMAGEOBJPROP BUTTON 'STATE 'Superscript]
-          (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB))
-                 (AND OFFSET (IABS OFFSET)))                 (* ; 
-                                                "Now move up to the offset distance fill-in field.")
-          (\SHOWSEL SCRATCHSEL NIL NIL)
-          (replace (SELECTION SET) of SCRATCHSEL with NIL)
-          (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL])
-
-(\TEDIT.NEUTRALIZE.CHARLOOKS.MENU
-  [LAMBDA (TEXTOBJ CH#)                                  (* ; "Edited 30-May-91 22:18 by jds")
-
-    (* ;; 
-"Set all the fields in the CHARLOOKS menu specified by TEXTOBJ, starting at CH# to neutral values.")
-
-    (PROG ((SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-           PC OFILE CH NEXTB BUTTON TEXT OFFSET)
-          (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL [for PROP
-                                                 in '(BOLD ITAL ULINE STRIKE OLINE)
-                                                 do (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON
-                                                                     TEXTOBJ CH#))
-                                                       (IMAGEOBJPROP (CAR NEXTB)
-                                                              'STATE
-                                                              'NEUTRAL)
-                                                       (SETQ CH# (ADD1 (CDR NEXTB]
-                 (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                                                             (* ; "Get to the start of the text.")
-                 (SETQ BUTTON (CAR NEXTB))
-                 (IMAGEOBJPROP BUTTON 'STATE NIL)            (* ; 
-                                                           "Now find which text button was 'on'")
-                 (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB))
-                        NIL)                                 (* ; 
-                                                           "Clean out the 'other font' field")
-                 (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                  ))
-                        NIL)                                 (* ; "Set the value in the SIZE field")
-                 [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                            of SCRATCHSEL]
-                                                             (* ; 
-                                                 "Move forward to the SUPERSCRIPT/SUBSCRIPT button")
-                 (SETQ BUTTON (CAR NEXTB))                   (* ; 
-                                                           "Remember the offset value for later")
-                 (IMAGEOBJPROP BUTTON 'STATE NIL)
-                 (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB))
-                        NIL)                                 (* ; 
-                                                "Now move up to the offset distance fill-in field.")
-                 ])
-
-(\TEDIT.PARSE.CHARLOOKS.MENU
-  [LAMBDA (TEXTOBJ CH#)                                  (* ; "Edited 30-May-91 22:18 by jds")
-                                                             (* MBFN for TEdit default menu item 
-                                                           buttons.)
-    (PROG (SCRATCHSEL CH NEWLOOKS SIZE SUPER SUB NEXTB BUTTON TEXT OFFSET)
-          (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-          [for BUTTON in '(BOLD ITALIC UNDERLINE STRIKEOUT OVERSCORE)
-             do                                          (* Set the character properties 
-                                                           which are independent)
-                   (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                   (SELECTQ BUTTON
-                       (BOLD (SETQ NEWLOOKS (\TEDIT.APPLY.BOLDNESS (CAR NEXTB)
-                                                   NEWLOOKS)))
-                       (ITALIC (SETQ NEWLOOKS (\TEDIT.APPLY.SLOPE (CAR NEXTB)
-                                                     NEWLOOKS)))
-                       (UNDERLINE (SETQ NEWLOOKS (\TEDIT.APPLY.ULINE (CAR NEXTB)
-                                                        NEWLOOKS)))
-                       (STRIKEOUT (SETQ NEWLOOKS (\TEDIT.APPLY.STRIKEOUT (CAR NEXTB)
-                                                        NEWLOOKS)))
-                       (OVERSCORE (SETQ NEWLOOKS (\TEDIT.APPLY.OLINE (CAR NEXTB)
-                                                        NEWLOOKS)))
-                       NIL)
-                   (SETQ CH# (ADD1 (CDR NEXTB]
-          (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                                                             (* Get to the start of the text.)
-          (SETQ BUTTON (CAR NEXTB))
-          [AND BUTTON
-               (SELECTQ (IMAGEOBJPROP BUTTON 'STATE)
-                   (Other                                    (* Have to get and add in a new 
-                                                           font.)
-                          (COND
-                             ([SETQ TEXT (MBUTTON.NEXT.FIELD.AS.ATOM TEXTOBJ (ADD1 (CDR NEXTB]
-                                                             (* He wants some font not on the 
-                                                           list. Add it to the list.)
-                              (SETQ NEWLOOKS (CONS 'FAMILY (CONS (U-CASE TEXT)
-                                                                 NEWLOOKS)))
-                              (COND
-                                 ([NOT (FMEMB (U-CASE TEXT)
-                                              (U-CASE (IMAGEOBJPROP BUTTON 'BUTTONS]
-                                                             (* This font name isn't in the list 
-                                                           already; add it.)
-                                  (MB.NWAYBUTTON.ADDITEM BUTTON TEXT)
-                                  (IMAGEOBJPROP BUTTON 'STATE TEXT))
-                                 (T [IMAGEOBJPROP BUTTON 'STATE (for NAME
-                                                                   in (IMAGEOBJPROP BUTTON
-                                                                                 'BUTTONS)
-                                                                   suchthat (EQ (U-CASE TEXT)
-                                                                                    (U-CASE NAME]
-                                                             (* Select the newly-specified font.)
-                                    ))
-                              (TEDIT.DELETE TEXTOBJ SCRATCHSEL)
-                                                             (* Delete the new font's name from 
-                                                           the fill-in field.)
-                              (TEDIT.OBJECT.CHANGED TEXTOBJ BUTTON))
-                             (T                              (* He didn't specify a font.
-                                                           Complain but keep on.)
-                                (TEDIT.PROMPTPRINT TEXTOBJ 
-                                       "'Other' font not specified; no change made." T))))
-                   (COND
-                      ((STRPOS '-class (IMAGEOBJPROP BUTTON 'STATE))
-                                                             (* It's a font class.
-                                                           Grab the name and evaluate it.)
-                       (SETQ NEWLOOKS
-                        (CONS 'FONT (CONS [EVAL (MKATOM (SUBSTRING (IMAGEOBJPROP BUTTON 'STATE)
-                                                               1
-                                                               (SUB1 (STRPOS '-class
-                                                                            (IMAGEOBJPROP
-                                                                             BUTTON
-                                                                             'STATE]
-                                          NEWLOOKS)))
-                       (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH#))
-                      (T (SETQ NEWLOOKS (CONS 'FAMILY (CONS (U-CASE (IMAGEOBJPROP BUTTON 'STATE))
-                                                            NEWLOOKS)))
-                         (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH#)
-                                                             (* Skip over the "other text" 
-                                                           fill-in.)
-                         ]                                   (* Now find which text button was "on")
-          [SETQ SIZE (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                        of SCRATCHSEL]
-                                                             (* Read the contents of the SIZE 
-                                                           menu field)
-          [COND
-             (SIZE                                           (* He specified one.
-                                                           Set it.)
-                   (SETQ NEWLOOKS (CONS 'SIZE (CONS SIZE NEWLOOKS]
-          [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                     of SCRATCHSEL]
-                                                             (* Get a handle on the 
-                                                           SUPERSCRIPT/SUBSCRIPT button)
-          (SETQ BUTTON (CAR NEXTB))
-          (SETQ SUPER (IMAGEOBJPROP BUTTON 'STATE))          (* Decide which kind it is)
-          [SETQ OFFSET (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (CDR NEXTB]
-                                                             (* And get the offset distance, in 
-                                                           points.)
-          (SELECTQ SUPER
-              (Superscript 
-
-         (* He called for SUPERSCRIPTing. Offset the characters by either the distance 
-       he gave, or 2 pts.)
-
-                           (SETQ NEWLOOKS (CONS 'SUPERSCRIPT (CONS (OR OFFSET 2)
-                                                                   NEWLOOKS))))
-              (Subscript 
-
-         (* He called for SUBSCRIPTING. Offset the characters by either the distance he 
-       gave, or 2 pts if he gave no distance.)
-
-                         (SETQ NEWLOOKS (CONS 'SUBSCRIPT (CONS (OR OFFSET 2)
-                                                               NEWLOOKS))))
-              (Normal                                        (* NORMAL => Turn off all super and 
-                                                           subscripting)
-                      (SETQ NEWLOOKS (CONS 'SUPERSCRIPT (CONS 0 NEWLOOKS))))
-              NIL)
-          (RETURN NEWLOOKS])
-
-(\TEDIT.APPLY.SLOPE
-  [LAMBDA (BUTTON NEWLOOKS)                                  (* jds "30-Aug-84 13:56")
-    (SELECTQ (IMAGEOBJPROP BUTTON 'STATE)
-        (ON (CONS 'SLOPE (CONS 'ITALIC NEWLOOKS)))
-        (OFF (CONS 'SLOPE (CONS 'REGULAR NEWLOOKS)))
-        NEWLOOKS])
-
-(\TEDIT.APPLY.STRIKEOUT
-  [LAMBDA (BUTTON NEWLOOKS)                                  (* jds "30-Aug-84 13:56")
-    (SELECTQ (IMAGEOBJPROP BUTTON 'STATE)
-        (ON (CONS 'STRIKEOUT (CONS 'ON NEWLOOKS)))
-        (OFF (CONS 'STRIKEOUT (CONS 'OFF NEWLOOKS)))
-        NEWLOOKS])
-
-(\TEDIT.APPLY.ULINE
-  [LAMBDA (BUTTON NEWLOOKS)                                  (* jds "30-Aug-84 13:56")
-    (SELECTQ (IMAGEOBJPROP BUTTON 'STATE)
-        (ON (CONS 'UNDERLINE (CONS 'ON NEWLOOKS)))
-        (OFF (CONS 'UNDERLINE (CONS 'OFF NEWLOOKS)))
-        NEWLOOKS])
-)
-(DEFINEQ
-
-(\TEDITPARAMENU.CREATE
-  [LAMBDA NIL                                                (* jds " 2-Aug-84 15:32")
-                                                             (* Creates the TEdit Expanded 
-                                                             Paragraph Menu)
-    (SETQ TEDIT.EXPANDEDPARA.MENU (\TEXTMENU.DOC.CREATE TEDIT.PARAMENU.SPEC])
-
-(\TEDIT.EXPANDEDPARA.MENU
-  [LAMBDA (STREAM)                                           (* ; "Edited 20-Aug-87 16:51 by jds")
-
-    (\TEXTMENU.START (COPYTEXTSTREAM TEDIT.EXPANDEDPARA.MENU T)
-           (\TEDIT.PRIMARYW (TEXTOBJ STREAM))
-           "Paragraph-Looks Menu"
-           (HEIGHTIFWINDOW 141 T])
-
-(\TEDIT.APPLY.PARALOOKS
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited 22-Apr-93 16:45 by jds")
-
-    (* ;; "Handler for the Paragraph Menu's APPLY button.  Collects the specs from the paragraph menu and calls TEDIT.PARALOOKS to effect the change.")
-
-    (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-           (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                            'TEXTOBJ))
-           (CH# (ADD1 (fetch (SELECTION CH#) of SEL)))
-           SCRATCHSEL QUAD OFILE CH NEWLOOKS SIZE SUPER SUB LINELEAD PARALEAD DEFAULTTAB BUTTON NEXTB
-           BUTTONDATA L1 LN R PARATYPE SPECIALX SPECIALY)
-          [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#]
-                                                             (* ; "Skip the SHOW button")
-          [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#]
-                                                             (* ; "and the NEUTRAL button.")
-          (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-          (SETQ NEWLOOKS NIL)                                (* ; 
-                                               "The list we'll be collecting the looks changes in.")
-          (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                                                             (* ; 
-                                      "Get the JUSTIFICATION button: Left/Right/Centered/Justified")
-          (SETQ BUTTON (CAR NEXTB))
-          [COND
-             ((AND (SETQ QUAD (IMAGEOBJPROP BUTTON 'STATE))
-                   (NEQ QUAD 'OFF))                          (* ; "A justification was specified")
-              (SETQ NEWLOOKS (CONS 'QUAD (CONS (U-CASE (MKATOM QUAD))
-                                               NEWLOOKS]
-          [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB]
-                                                             (* ; "Go to the 'Page Heading' button")
-          (SETQ BUTTON (CAR NEXTB))
-          [COND
-             ((EQ (IMAGEOBJPROP BUTTON 'STATE)
-                  'ON)                                       (* ; 
-                                                           "This paragraph IS a page heading.")
-              (SETQ NEWLOOKS (CONS 'TYPE (CONS 'PAGEHEADING NEWLOOKS)))
-                                                             (* ; "Tell him that it's a heading.")
-              (SETQ NEWLOOKS (CONS 'SUBTYPE (CONS [MKATOM (MBUTTON.NEXT.FIELD.AS.TEXT
-                                                           TEXTOBJ
-                                                           (ADD1 (CDR NEXTB]
-                                                  NEWLOOKS)))(* ; "And say what kind.")
-              )
-             ((EQ (IMAGEOBJPROP BUTTON 'STATE)
-                  'OFF)                                      (* ; 
-                                                           "This paragraph IS NOT a page heading.")
-              (SETQ NEWLOOKS (CONS 'TYPE (CONS NIL NEWLOOKS)))
-                                                             (* ; 
-                                                           "Tell him that it's NOT a heading.")
-              (SETQ NEWLOOKS (CONS 'SUBTYPE (CONS NIL NEWLOOKS)))
-              (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ (ADD1 (CDR NEXTB)))
-                                                             (* ; "And say what kind.")
-              )
-             (T                                              (* ; 
-                                        "No change specified.  Skip over the heading-type fill-in.")
-                (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ (ADD1 (CDR NEXTB]
-          [COND
-             ((SETQ LINELEAD (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (fetch (SELECTION CH#)
-                                                                          of SCRATCHSEL)))
-                                                             (* ; "Get any line leading")
-              (SETQ NEWLOOKS (CONS 'LINELEADING (CONS LINELEAD NEWLOOKS]
-          [COND
-             ([SETQ PARALEAD (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION
-                                                                                         CH#)
-                                                                                of SCRATCHSEL]
-                                                             (* ; "Get any paragraph leading")
-              (SETQ NEWLOOKS (CONS 'PARALEADING (CONS PARALEAD NEWLOOKS]
-          [COND
-             ([SETQ SPECIALX (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION
-                                                                                         CH#)
-                                                                                of SCRATCHSEL]
-                                                             (* ; 
-                                                     "Get any special X position for the paragraph")
-              (SETQ NEWLOOKS (CONS 'SPECIALX (CONS (FIXR (TIMES 12 SPECIALX))
-                                                   NEWLOOKS]
-          [COND
-             ([SETQ SPECIALY (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION
-                                                                                         CH#)
-                                                                                of SCRATCHSEL]
-                                                             (* ; 
-                                                      "Get special Y positioning for the paragraph")
-              (SETQ NEWLOOKS (CONS 'SPECIALY (CONS (FIXR (TIMES 12 SPECIALY))
-                                                   NEWLOOKS]
-          (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                   )))
-          (SETQ BUTTON (CAR NEXTB))
-          [COND
-             [(EQ (IMAGEOBJPROP BUTTON 'STATE)
-                  'ON)                                       (* ; 
-                             "This paragraph starts on a new page (or col or box, as apprpopriate)")
-              (SETQ NEWLOOKS (CONS 'NEWPAGEBEFORE (CONS T NEWLOOKS]
-             ((EQ (IMAGEOBJPROP BUTTON 'STATE)
-                  'OFF)                                      (* ; 
-                                                           "This paragraph IS NOT a page heading.")
-              (SETQ NEWLOOKS (CONS 'NEWPAGEBEFORE (CONS NIL NEWLOOKS]
-          [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB]
-          (SETQ BUTTON (CAR NEXTB))
-          [COND
-             [(EQ (IMAGEOBJPROP BUTTON 'STATE)
-                  'ON)                                       (* ; 
-                                                      "The next paragraph starts on a new page....")
-              (SETQ NEWLOOKS (CONS 'NEWPAGEAFTER (CONS T NEWLOOKS]
-             ((EQ (IMAGEOBJPROP BUTTON 'STATE)
-                  'OFF)                                      (* ; 
-                                               "The next paragraph DOESN'T START on a new page....")
-              (SETQ NEWLOOKS (CONS 'NEWPAGEAFTER (CONS NIL NEWLOOKS]
-          [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB]
-          (SETQ BUTTON (CAR NEXTB))
-          (SELECTQ (IMAGEOBJPROP BUTTON 'STATE)
-              (ON (push NEWLOOKS T)
-                  (push NEWLOOKS 'HARDCOPY))
-              (OFF (push NEWLOOKS NIL)
-                   (push NEWLOOKS 'HARDCOPY))
-              NIL)
-
-(* ;;; "THE VARIOUS KINDS OF KEEP PROPERTIES (ONLY HEADING-KEEP FOR NOW THO)")
-
-          [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB]
-          (SETQ BUTTON (CAR NEXTB))
-          (SELECTQ (IMAGEOBJPROP BUTTON 'STATE)
-              (ON (push NEWLOOKS 'ON)
-                  (push NEWLOOKS 'HEADINGKEEP))
-              (OFF (push NEWLOOKS 'OFF)
-                   (push NEWLOOKS 'HEADINGKEEP))
-              NIL)
-
-(* ;;; "THE DEFAULT TAB WIDTH")
-
-          (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                   )))
-          (SETQ BUTTON (CAR NEXTB))
-          (SETQ DEFAULTTAB (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (CDR NEXTB)))
-          (while (NOT (type? MARGINBAR BUTTON)) do (SETQ NEXTB (
-                                                                          MBUTTON.FIND.NEXT.BUTTON
-                                                                            TEXTOBJ
-                                                                            (fetch (SELECTION
-                                                                                        CH#)
-                                                                               of SCRATCHSEL)))
-                                                              (SETQ BUTTON (CAR NEXTB)))
-          (SETQ BUTTONDATA (IMAGEOBJPROP BUTTON 'OBJECTDATUM))
-          [COND
-             ((IGEQ [SETQ L1 (FIXR (TIMES (fetch MARL1 of BUTTONDATA)
-                                          (fetch MARUNIT of BUTTONDATA]
-                    0)                                       (* ; 
-                                                       "The 1stleftmargin is set, and non-neutral.")
-              (SETQ NEWLOOKS (CONS '1STLEFTMARGIN (CONS L1 NEWLOOKS]
-          [COND
-             ((IGEQ [SETQ LN (FIXR (TIMES (fetch MARLN of BUTTONDATA)
-                                          (fetch MARUNIT of BUTTONDATA]
-                    0)                                       (* ; 
-                                                          "The LEFTMARGIN is set, and non-neutral.")
-              (SETQ NEWLOOKS (CONS 'LEFTMARGIN (CONS LN NEWLOOKS]
-          [COND
-             ((IGEQ [SETQ R (FIXR (TIMES (fetch MARR of BUTTONDATA)
-                                         (fetch MARUNIT of BUTTONDATA]
-                    0)                                       (* ; 
-                                                         "The RIGHTMARGIN is set, and non-neutral.")
-              (SETQ NEWLOOKS (CONS 'RIGHTMARGIN (CONS R NEWLOOKS]
-          [COND
-             ((NEQ (fetch MARTABS of BUTTONDATA)
-                   'NEUTRAL)                                 (* ; 
-                                          "If the tab settings are neutral, don't change anything.")
-              (SETQ NEWLOOKS
-               (CONS 'TABS
-                     (CONS [CONS DEFAULTTAB
-                                 (SORT (for TAB in (fetch MARTABS of BUTTONDATA)
-                                          collect (CONS (FIXR (TIMES (CAR TAB)
-                                                                         (fetch MARUNIT
-                                                                            of BUTTONDATA)))
-                                                            (CDR TAB)))
-                                       (FUNCTION (LAMBDA (A B)
-                                                   (ILEQ (CAR A)
-                                                         (CAR B]
-                           NEWLOOKS]
-          (TEDIT.PARALOOKS MAINTEXT NEWLOOKS (fetch (SELECTION CH#) of (fetch
-                                                                                (TEXTOBJ SEL)
-                                                                                  of MAINTEXT))
-                 (fetch (SELECTION DCH) of (fetch (TEXTOBJ SEL) of MAINTEXT)))
-          (\SHOWSEL SEL NIL NIL)
-          (TTY.PROCESS (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                              'PROCESS])
-
-(\TEDIT.SHOW.PARALOOKS
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited  6-Jul-92 09:42 by jds")
-
-    (* ;; "Fill in the PARAGRAPH LOOKS menu from the para looks for a selected character")
-
-    (PROG* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-            (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                             'TEXTOBJ))
-            (CH# (ADD1 (fetch (SELECTION CH#) of SEL)))
-            (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-            (OLDUPDATEFLG (fetch (TEXTOBJ TXTDON'TUPDATE) of TEXTOBJ))
-            FMTSPEC BUTTON NEXTB ARB BUTTONDATA)
-           (\SHOWSEL SEL NIL NIL)
-           (replace (SELECTION SET) of SEL with NIL)
-           (COND
-              ((ZEROP (fetch (TEXTOBJ TEXTLEN) of MAINTEXT))
-                                                             (* ; 
-                                    "If there is no text to take the formatting from, don't bother")
-               (RETURN)))
-           (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL
-                  [SETQ FMTSPEC (fetch (PIECE PPARALOOKS)
-                                   of (\CHTOPC [IMAX 1 (IMIN (fetch (TEXTOBJ TEXTLEN)
-                                                                    of MAINTEXT)
-                                                                 (fetch (SELECTION CH#)
-                                                                    of (fetch (TEXTOBJ SEL)
-                                                                              of MAINTEXT]
-                                                 (fetch (TEXTOBJ PCTB) of MAINTEXT]
-                                                             (* ; "Get to the start of the text.")
-                  [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#]
-                                                             (* ; "Skip the NEUTRAL button.")
-                  (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                                                             (* ; "Grab the justification button")
-                  (SETQ BUTTON (CAR NEXTB))
-                  [for ITEM in (IMAGEOBJPROP BUTTON 'BUTTONS)
-                     do (COND
-                               ([EQ (fetch (FMTSPEC QUAD) of FMTSPEC)
-                                    (U-CASE (COND
-                                               ((LISTP ITEM)
-                                                (CAR ITEM))
-                                               (T ITEM]      (* ; "Turn this button on.")
-                                (IMAGEOBJPROP BUTTON 'STATE ITEM)
-                                (RETURN]                     (* ; 
-                                                           "Now find which text button was 'on'")
-                  [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB]
-                                                             (* ; "Find the 'Page Heading' button")
-                  (SETQ BUTTON (CAR NEXTB))
-                  (COND
-                     ((EQ (fetch (FMTSPEC FMTPARATYPE) of FMTSPEC)
-                          'PAGEHEADING)                      (* ; 
-                       "This IS a page heading.  Turn the button ON and set the heading type field")
-                      (IMAGEOBJPROP BUTTON 'STATE 'ON)
-                      (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                   of SCRATCHSEL))
-                             (fetch (FMTSPEC FMTPARASUBTYPE) of FMTSPEC)))
-                     (T                                      (* ; 
-                                   "This isn't a page heading;  make sure the type field is empty.")
-                        (IMAGEOBJPROP BUTTON 'STATE 'OFF)
-                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                     of SCRATCHSEL))
-                               NIL)))
-                  (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                   ))
-                         (fetch (FMTSPEC LINELEAD) of FMTSPEC))
-                                                             (* ; "Update the LINE LEADING field")
-                  (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                   ))
-                         (fetch (FMTSPEC LEADBEFORE) of FMTSPEC))
-                                                             (* ; "Update the PARA LEADING field")
-                  [MBUTTON.SET.NEXT.FIELD
-                   TEXTOBJ
-                   (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                   (LET ((VAL (/ (FIXR (IQUOTIENT (OR (fetch (FMTSPEC FMTSPECIALX) of FMTSPEC
-                                                             )
-                                                      0)
-                                              3))
-                                 4)))
-                        (COND
-                           ((FIXP VAL)
-                            VAL)
-                           (T (FLOAT VAL]
-                  [MBUTTON.SET.NEXT.FIELD
-                   TEXTOBJ
-                   (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                   (LET ((VAL (/ (FIXR (IQUOTIENT (OR (fetch (FMTSPEC FMTSPECIALY) of FMTSPEC
-                                                             )
-                                                      0)
-                                              3))
-                                 4)))
-                        (COND
-                           ((FIXP VAL)
-                            VAL)
-                           (T (FLOAT VAL]
-                  [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION
-                                                                                      CH#)
-                                                                             of SCRATCHSEL]
-                  (SETQ BUTTON (CAR NEXTB))
-                  [COND
-                     ((fetch (FMTSPEC FMTNEWPAGEBEFORE) of FMTSPEC)
-                      (IMAGEOBJPROP BUTTON 'STATE 'ON)       (* ; "This para starts on a new page")
-                      )
-                     (T (IMAGEOBJPROP BUTTON 'STATE 'OFF]
-                  [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB]
-                  (SETQ BUTTON (CAR NEXTB))
-                  [COND
-                     ((fetch (FMTSPEC FMTNEWPAGEAFTER) of FMTSPEC)
-                      (IMAGEOBJPROP BUTTON 'STATE 'ON)       (* ; "This para starts on a new page")
-                      )
-                     (T (IMAGEOBJPROP BUTTON 'STATE 'OFF]
-
-                  (* ;; "HARDCOPY-DISPLAY MODE")
-
-                  [SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ (ADD1 (CDR NEXTB))
-                                     (COND
-                                        ((fetch (FMTSPEC FMTHARDCOPY) of FMTSPEC)
-                                                             (* ; 
-                                         "This para is to be formatted for hardcopy on the display")
-                                         'ON)
-                                        (T 'OFF]
-
-                  (* ;; "HEADING KEEP")
-
-                  [SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB
-                                     (COND
-                                        ((fetch (FMTSPEC FMTHEADINGKEEP) of FMTSPEC)
-                                                             (* ; 
-                                         "This para is to be formatted for hardcopy on the display")
-                                         'ON)
-                                        (T 'OFF]
-
-                  (* ;; "DEFAULT TAB WIDTH")
-
-                  (MBUTTON.SET.NEXT.FIELD TEXTOBJ NEXTB (CAR (fetch (FMTSPEC TABSPEC)
-                                                                    of FMTSPEC)))
-                                                             (* ; 
-                                                           "Update the DEFAULT TAB SPACING field")
-                  (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#)
-                                                                       of SCRATCHSEL)))
-                  (SETQ BUTTON (CAR NEXTB))
-                  (while (NOT (type? MARGINBAR BUTTON))
-                     do [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB]
-                           (SETQ BUTTON (CAR NEXTB)))
-                  (SETQ BUTTONDATA (IMAGEOBJPROP BUTTON 'OBJECTDATUM))
-                                                             (* ; 
-                                                     "(IMAGEOBJPROP BUTTON (QUOTE IMAGECACHE) NIL)")
-                                                             (* ; "Tell it to reformat itself.")
-                  (replace MARL1 of BUTTONDATA with (FQUOTIENT (fetch (FMTSPEC 
-                                                                                           1STLEFTMAR
-                                                                                             )
-                                                                              of FMTSPEC)
-                                                                       (fetch MARUNIT
-                                                                          of BUTTONDATA)))
-                  (replace MARLN of BUTTONDATA with (FQUOTIENT (fetch (FMTSPEC 
-                                                                                             LEFTMAR)
-                                                                              of FMTSPEC)
-                                                                       (fetch MARUNIT
-                                                                          of BUTTONDATA)))
-                  (replace MARR of BUTTONDATA with (FQUOTIENT (fetch (FMTSPEC 
-                                                                                            RIGHTMAR)
-                                                                             of FMTSPEC)
-                                                                      (fetch MARUNIT of
-                                                                                         BUTTONDATA))
-                         )
-                  (replace MARTABS of BUTTONDATA
-                     with (for TAB in (CDR (fetch (FMTSPEC TABSPEC) of FMTSPEC))
-                                 collect (CONS (FQUOTIENT (CAR TAB)
-                                                          (fetch MARUNIT of BUTTONDATA))
-                                                   (CDR TAB])
-
-(\TEDIT.NEUTRALIZE.PARALOOKS.MENU
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited 30-May-91 22:18 by jds")
-
-    (* ;; "Set all the fields of a PARAGRAPH LOOKS menu to neutral settings.")
-
-    (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-           (CH# (ADD1 (fetch (SELECTION CH#) of SEL)))
-           SCRATCHSEL FMTSPEC BUTTON NEXTB ARB BUTTONDATA)
-          (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-                                                             (* ; "Get to the start of the text.")
-          (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE
-                                                           TEXTOBJ CH# 'NIL))
-                                                             (* ; 
-                                                        "Neutralize the justification N-Way button")
-                 (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB 'NEUTRAL))
-                                                             (* ; "Find the 'Page Heading' button")
-                 (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                  ))
-                        NIL)
-                 (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                  ))
-                        NIL)                                 (* ; "Update the LINE LEADING field")
-                 (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                  ))
-                        NIL)                                 (* ; "Update the PARA LEADING field")
-                 (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                  ))
-                        NIL)
-                 (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                  ))
-                        NIL)
-                 (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ (ADD1 (fetch (SELECTION
-                                                                                          CH#)
-                                                                                 of SCRATCHSEL))
-                                    'NEUTRAL))               (* ; "New page before")
-                 (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB 'NEUTRAL))
-                                                             (* ; "New page after")
-                 (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB 'NEUTRAL))
-                                                             (* ; "Hardcopy formatting mode")
-                 (MBUTTON.SET.NEXT.FIELD TEXTOBJ NEXTB NIL)
-                                                             (* ; 
-                                                           "Update the DEFAULT TAB SPACING field")
-                 (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#)
-                                                                      of SCRATCHSEL)))
-                 (SETQ BUTTON (CAR NEXTB))
-                 (while (NOT (type? MARGINBAR BUTTON))
-                    do [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB]
-                          (SETQ BUTTON (CAR NEXTB)))
-                 (SETQ BUTTONDATA (IMAGEOBJPROP BUTTON 'OBJECTDATUM))
-                                                             (* ; 
-                                                     "(IMAGEOBJPROP BUTTON (QUOTE IMAGECACHE) NIL)")
-                                                             (* ; "Tell it to reformat itself.")
-                 [replace MARL1 of BUTTONDATA
-                    with (COND
-                                ((ILESSP (fetch MARL1 of BUTTONDATA)
-                                        0)
-                                 (fetch MARL1 of BUTTONDATA))
-                                (T (IMIN -0.5 (IMINUS (fetch MARL1 of BUTTONDATA]
-                 [replace MARLN of BUTTONDATA
-                    with (COND
-                                ((ILESSP (fetch MARLN of BUTTONDATA)
-                                        0)
-                                 (fetch MARLN of BUTTONDATA))
-                                (T (IMIN -0.5 (IMINUS (fetch MARLN of BUTTONDATA]
-                 [replace MARR of BUTTONDATA
-                    with (COND
-                                ((ILESSP (fetch MARR of BUTTONDATA)
-                                        0)
-                                 (fetch MARR of BUTTONDATA))
-                                ((ZEROP (fetch MARR of BUTTONDATA))
-                                 (IMINUS (IQUOTIENT (IDIFFERENCE (fetch (TEXTOBJ WRIGHT)
-                                                                    of TEXTOBJ)
-                                                           20)
-                                                12)))
-                                (T (IMIN -0.5 (IMINUS (fetch MARR of BUTTONDATA]
-                 (replace MARTABS of BUTTONDATA with 'NEUTRAL])
-
-(\TEDIT.RECORD.TABLEADERS
-  [LAMBDA (BUTTON NEWSTATE TEXTSTREAM SEL)               (* ; "Edited 30-May-91 22:18 by jds")
-
-         (* Toggle the dotted-leader state of the margin bar tab-setter.
-       This is called when the user hits the "dotted leader" toggle button in the menu)
-
-    (PROG* [(FLG (COND
-                    ((EQ NEWSTATE 'ON)
-                     T)
-                    (T NIL)))
-            (TEXTOBJ (TEXTOBJ TEXTSTREAM))
-            (MARGINBAR (CAR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION
-                                                                                        CH#)
-                                                                               of SEL]
-           (replace MARTABTYPE of (IMAGEOBJPROP MARGINBAR 'OBJECTDATUM)
-              with (SELECTQ (OR (fetch MARTABTYPE of (IMAGEOBJPROP MARGINBAR 
-                                                                        'OBJECTDATUM))
-                                    'LEFT)
-                           (LEFT 'DOTTEDLEFT)
-                           (DOTTEDLEFT 'LEFT)
-                           (CENTERED 'DOTTEDCENTERED)
-                           (DOTTEDCENTERED 
-                                'CENTERED)
-                           (RIGHT 'DOTTEDRIGHT)
-                           (DOTTEDRIGHT 'RIGHT)
-                           (DECIMAL 'DOTTEDDECIMAL)
-                           (DOTTEDDECIMAL 'DECIMAL)
-                           (SHOULDNT])
-)
-(DEFINEQ
-
-(\TEDIT.SHOW.PAGEFORMATTING
-  [LAMBDA (OBJ SEL W)                                    (* ; "Edited  4-Feb-92 16:38 by jds")
-
-(* ;;; "Take a document's page formatting, and display it in the menu.")
-
-    (PROG* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-            (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                             'TEXTOBJ))
-            (CH# (ADD1 (fetch (SELECTION CH#) of SEL)))
-            (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-            (OLDUPDATEFLG (fetch (TEXTOBJ TXTDON'TUPDATE) of TEXTOBJ))
-            FOLIOINFO NEWLOOKS NEXTB BUTTON PAGEID OPAGEFRAMES FIRST REST PFONT HEADING HEADINGS 
-            PAGEPROPS STARTINGPAGE# PAPERSIZE)
-
-     (* ;; "Start by turning off the selection--and leaving it off afterward.")
-
-           (\SHOWSEL SEL NIL NIL)
-           (replace (SELECTION SET) of SEL with NIL)
-
-     (* ;; "What kind of page are we looking at the specs for?")
-
-           (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-           (SETQ BUTTON (CAR NEXTB))
-           (SELECTQ (IMAGEOBJPROP (CAR NEXTB)
-                           'STATE)
-               (|First(&Default)| 
-                    (SETQ PAGEID 'FIRST))
-               (Other% Left (SETQ PAGEID 'LEFT))
-               (Other% Right (SETQ PAGEID 'RIGHT))
-               (PROGN (TEDIT.PROMPTPRINT MAINTEXT "First specify which kind of page you want to see."
-                             T)
-                      (SETQ PAGEID NIL)))
-
-     (* ;; "Now mark the menu for NO SCREEN UPDATES during the button-setting process.")
-
-           (AND PAGEID (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL (replace (TEXTOBJ TXTDON'TUPDATE)
-                                                              of TEXTOBJ with T)
-
-                              (* ;; "Now replace the button values, fill-in fields, etc.")
-
-                              (SETQ OPAGEFRAMES (OR (fetch (TEXTOBJ TXTPAGEFRAMES) of 
-                                                                                             MAINTEXT
-                                                           )
-                                                    TEDIT.PAGE.FRAMES))
-                              [COND
-                                 ((LISTP OPAGEFRAMES)        (* ; 
-                              "No problem, this is already just a list of first-recto-verso frames")
-                                  )
-                                 (T                          (* ; 
-                            "This is probably a parsed-up version of the thing.  Fix it to a list.")
-                                    (COND
-                                       [(EQ (fetch (PAGEREGION REGIONFILLMETHOD) of 
-                                                                                          OPAGEFRAMES
-                                                   )
-                                            'SEQUENCE)
-                                        (SETQ FIRST (CAR (fetch (PAGEREGION REGIONSUBBOXES)
-                                                            of OPAGEFRAMES)))
-                                        (SETQ REST (CADR (fetch (PAGEREGION REGIONSUBBOXES)
-                                                            of OPAGEFRAMES)))
-                                        (COND
-                                           [(EQ (fetch (PAGEREGION REGIONFILLMETHOD) of
-                                                                                         REST)
-                                                'ALTERNATE)
-                                            (SETQ OPAGEFRAMES (CONS FIRST (fetch (PAGEREGION
-                                                                                      REGIONSUBBOXES)
-                                                                             of REST]
-                                           (T (SETQ OPAGEFRAMES NIL]
-                                       (T (SETQ OPAGEFRAMES NIL]
-                              (COND
-                                 ((NOT OPAGEFRAMES)          (* ; 
-                        "If the formatting isn't in our simplified 3-way format, punt out of this.")
-                                  (TEDIT.PROMPTPRINT MAINTEXT "Format too complex to edit." T)
-                                  (SETQ PAGEID NIL)))
-                              (SELECTQ PAGEID
-                                  (FIRST (SETQ NEWLOOKS (CAR OPAGEFRAMES)))
-                                  (LEFT (SETQ NEWLOOKS (CADR OPAGEFRAMES))
-                                        (SETQ PAPERSIZE (LISTGET [CAR (FLAST (
-                                                                           TEDIT.UNPARSE.PAGEFORMAT
-                                                                              (CAR OPAGEFRAMES)
-                                                                              'PICAS]
-                                                               'PAPERSIZE)))
-                                  (RIGHT (SETQ NEWLOOKS (CADDR OPAGEFRAMES))
-                                         (SETQ PAPERSIZE (LISTGET [CAR (FLAST (
-                                                                           TEDIT.UNPARSE.PAGEFORMAT
-                                                                               (CAR OPAGEFRAMES)
-                                                                               'PICAS]
-                                                                'PAPERSIZE)))
-                                  NIL)
-                              (COND
-                                 (PAGEID (SETQ NEWLOOKS (TEDIT.UNPARSE.PAGEFORMAT NEWLOOKS
-                                                               'PICAS))
-                                        (SETQ PAGEPROPS (CAR (FLAST NEWLOOKS)))
-                                        [COND
-                                           ((EQ PAGEID 'FIRST)
-                                            (SETQ PAPERSIZE (LISTGET PAGEPROPS 'PAPERSIZE]
-                                        (SETQ CH# (ADD1 (CDR NEXTB)))
-                                                             (* ; 
-                                                           "Move past the kind-of-page button")
-                                        (SETQ STARTINGPAGE# (LISTGET PAGEPROPS 'STARTINGPAGE#))
-                                                             (* ; 
-                                                           "Grab a potential starting page number.")
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ CH# STARTINGPAGE#)
-                                        (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                                        (SETQ CH# (ADD1 (CDR NEXTB)))
-                                        (IMAGEOBJPROP (CAR NEXTB)
-                                               'STATE
-                                               (OR PAPERSIZE 'Letter))
-                                        (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                                        (SETQ CH# (ADD1 (CDR NEXTB)))
-                                        [IMAGEOBJPROP (CAR NEXTB)
-                                               'STATE
-                                               (COND
-                                                  ((LISTGET PAGEPROPS 'LANDSCAPE?)
-                                                   'ON)
-                                                  (T 'OFF]   (* ; 
-                                                 "Tell whether the page is to be landscape or not.")
-                                        (SETQ FOLIOINFO (LISTGET PAGEPROPS 'FOLIOINFO))
-                                                             (* ; "Page number fomratting info")
-                                        (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                                        (SETQ CH# (ADD1 (CDR NEXTB)))
-                                        [IMAGEOBJPROP (CAR NEXTB)
-                                               'STATE
-                                               (COND
-                                                  ((pop NEWLOOKS)
-                                                   'Yes)
-                                                  (T 'No]
-                                        (SETQ BUTTON (CAR NEXTB))
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB))
-                                               (pop NEWLOOKS))
-                                                             (* ; "Page # X location")
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ
-                                               (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                                               (pop NEWLOOKS))
-                                                             (* ; "Page # Y location")
-                                        (SETQ PFONT (pop NEWLOOKS))
-                                                             (* ; "Skip the font info for now.")
-                                        [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON
-                                                     TEXTOBJ
-                                                     (ADD1 (fetch (SELECTION CH#) of 
-                                                                                           SCRATCHSEL
-                                                                  ]
-                                        (SETQ CH# (ADD1 (CDR NEXTB)))
-                                        (SETQ BUTTON (CAR NEXTB))
-                                        (IMAGEOBJPROP BUTTON 'STATE (SELECTQ (pop FOLIOINFO)
-                                                                        (ARABIC 123)
-                                                                        (LOWERROMAN 'xiv)
-                                                                        (UPPERROMAN 'XIV)
-                                                                        123))
-                                                             (* ; "The format for the page number")
-                                        (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-                                        (SETQ CH# (ADD1 (CDR NEXTB)))
-                                        (SETQ BUTTON (CAR NEXTB))
-                                                             (* ; "How to align the page number")
-                                        (IMAGEOBJPROP BUTTON 'STATE (SELECTQ (pop NEWLOOKS)
-                                                                        (LEFT 'Left)
-                                                                        (RIGHT 'Right)
-                                                                        (CENTERED 'Centered)
-                                                                        'Centered))
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ CH# (pop FOLIOINFO))
-                                                             (* ; 
-                                                           "The text to surround the page number")
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ
-                                               (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                                               (pop FOLIOINFO))
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ
-                                               (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                                               (pop NEWLOOKS))
-                                                             (* ; "Left Margin")
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ
-                                               (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                                               (pop NEWLOOKS))
-                                                             (* ; "Right Margin")
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ
-                                               (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                                               (pop NEWLOOKS))
-                                                             (* ; "Top margin")
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ
-                                               (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                                               (pop NEWLOOKS))
-                                                             (* ; "Bottom Margin")
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ
-                                               (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                                               (pop NEWLOOKS))
-                                                             (* ; "# of columns")
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ
-                                               (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                                               (pop NEWLOOKS))
-                                                             (* ; "Column width")
-                                        (MBUTTON.SET.NEXT.FIELD TEXTOBJ
-                                               (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                                               (pop NEWLOOKS))
-                                                             (* ; "Intercolumn spacing")
-                                        (SETQ HEADINGS (pop NEWLOOKS))
-                                        (for HEADING# from 1 to 8
-                                           do 
-
-                                                 (* ;; 
-                                  "Insert info about up to 8 headings (the # of spots in the menu)")
-
-                                                 (SETQ HEADING (pop HEADINGS))
-                                                 (MBUTTON.SET.NEXT.FIELD
-                                                  TEXTOBJ
-                                                  (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)
-                                                        )
-                                                  (pop HEADING))
-                                                 (MBUTTON.SET.NEXT.FIELD
-                                                  TEXTOBJ
-                                                  (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)
-                                                        )
-                                                  (pop HEADING))
-                                                 (MBUTTON.SET.NEXT.FIELD
-                                                  TEXTOBJ
-                                                  (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)
-                                                        )
-                                                  (pop HEADING)))
-                                        (COND
-                                           (HEADINGS 
-
-                                                  (* ;; 
-                                                "There were headings left over, so warn user.")
-
-                                                  (PROMPTPRINT "WARNING: This document has more kinds of page heading than the menu has room for.  Some will be lost if you APPLY this menu."
-                                                         )))
-                                        (\TEDIT.FILL.IN.CHARLOOKS.MENU TEXTOBJ
-                                               (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL))
-                                               (OR PFONT TEDIT.DEFAULT.FOLIO.LOOKS))
-                                                             (* ; 
-                                                      "The font for the page numbers to appear in.")
-                                        ])
-
-(\TEDITPAGEMENU.CREATE
-  [LAMBDA NIL                                                (* gbn " 8-Oct-84 18:25")
-                                                             (* Creates the TEdit Expanded Menu)
-    (SETQ TEDIT.EXPANDED.PAGEMENU (\TEXTMENU.DOC.CREATE (APPEND TEDIT.PAGEMENU.SPEC 
-                                                               TEDIT.MENUDIVIDER.SPEC
-                                                               [LIST (create MB.TEXT
-                                                                            MBSTRING _ 
-                                                               "Character Looks for Page Numbers:   "
-                                                                            MBFONT _
-                                                                            (FONTCREATE 'HELVETICA 10
-                                                                                   'BOLD]
-                                                               TEDIT.CHARLOOKSMENU.SPEC])
-
-(\TEDIT.APPLY.PAGEFORMATTING
-  [LAMBDA (OBJ SEL W)                         (* ; 
-                                                "Edited  4-Jun-93 12:04 by sybalsky:mv:envos")
-
-(* ;;; "Change the page formatting for this document")
-
-    (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL))
-           (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                            'TEXTOBJ))
-           (CH# (ADD1 (fetch (SELECTION CH#) of SEL)))
-           SCRATCHSEL NEXTB BUTTON OPAGEFRAMES PAGEID PX PY LEFT BOTTOM TOP RIGHT ALIGNMENT PAGENOS 
-           COLS COLWIDTH INTERCOL PFONT NPAGEFORMAT HEADINGTYPE HEADINGX HEADINGY HEADINGS 
-           HEADINGINVALID STARTINGPAGE# FOLIOFORMAT FOLIOPRETEXT FOLIOPOSTTEXT PAGEOPTIONS 
-           NFPAGEFORMAT PAPERSIZE LANDSCAPE?)
-          (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-          [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#]
-                                                             (* ; "Skip the SHOW button.")
-          (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-          (SETQ CH# (ADD1 (CDR NEXTB)))
-          (SELECTQ (IMAGEOBJPROP (CAR NEXTB)
-                          'STATE)
-              (|First(&Default)| 
-                   (SETQ PAGEID 'FIRST))
-              (Other% Left (SETQ PAGEID 'LEFT))
-              (Other% Right (SETQ PAGEID 'RIGHT))
-              (PROGN (TEDIT.PROMPTPRINT MAINTEXT "Set KIND OF PAGE before APPLYing." T)
-                     (RETURN)))                              (* ; "Find which page, for later.")
-          (SETQ STARTINGPAGE# (AND (EQ PAGEID 'FIRST)
-                                   (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ CH#)))
-          (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-          (SETQ CH# (ADD1 (CDR NEXTB)))
-          (SETQ PAPERSIZE (OR (IMAGEOBJPROP (CAR NEXTB)
-                                     'STATE)
-                              'Letter))                      (* ; 
-                                                "Get the size of paper this is to be formatted for")
-          (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-          (SETQ CH# (ADD1 (CDR NEXTB)))
-          (SETQ LANDSCAPE? (EQ (IMAGEOBJPROP (CAR NEXTB)
-                                      'STATE)
-                               'ON))                         (* ; 
-                                       "Decide if this kind of page is to be printed landscape....")
-          (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))
-          (SETQ CH# (ADD1 (CDR NEXTB)))
-          (SELECTQ (IMAGEOBJPROP (CAR NEXTB)
-                          'STATE)
-              (No (SETQ PAGENOS NIL))
-              (Yes (SETQ PAGENOS T))
-              NIL)                                           (* ; "Find about page numbers")
-          (SETQ PX (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ CH#))
-          [SETQ PY (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                      of SCRATCHSEL]
-          [COND
-             (PAGENOS                                        (* ; 
-                                   "If he wants page numbers, make sure he said WHERE to put them.")
-                    (COND
-                       ((AND PX PY))
-                       (T (TEDIT.PROMPTPRINT MAINTEXT 
-                                 "Please set the X and Y location for page numbers before APPLYing."
-                                 T)
-                          (TEDIT.PROMPTFLASH MAINTEXT)
-                          (RETURN]
-          [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                     of SCRATCHSEL]
-                                                             (* ; 
-                                                           "Get to the numbering-format button")
-          (SETQ BUTTON (CAR NEXTB))
-          (SETQ FOLIOFORMAT (SELECTQ (IMAGEOBJPROP BUTTON 'STATE)
-                                (123                         (* ; "arabic numbers")
-                                     'ARABIC)
-                                (xiv                         (* ; "lower-case roman numerals")
-                                     'LOWERROMAN)
-                                (XIV                         (* ; "Upper-case roman numerals")
-                                     'UPPERROMAN)
-                                'ARABIC))
-          [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB]
-                                                             (* ; 
-                                                           "Get to the number alignment button")
-          (SETQ BUTTON (CAR NEXTB))
-          [SETQ ALIGNMENT (U-CASE (IMAGEOBJPROP BUTTON 'STATE]
-                                                             (* ; "PX PY PFONT ALIGNMENT")
-                                                             (* ; 
-                                                           "Margins: LEFT, RIGHT, TOP, BOTTOM")
-          (SETQ CH# (ADD1 (CDR NEXTB)))
-          (SETQ FOLIOPRETEXT (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ CH#))
-          [SETQ FOLIOPOSTTEXT (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ (ADD1 (fetch (SELECTION
-                                                                                        CH#)
-                                                                               of SCRATCHSEL]
-
-(* ;;; "Now get the margins on the paper")
-
-          [SETQ LEFT (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                        of SCRATCHSEL]
-          [SETQ RIGHT (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                         of SCRATCHSEL]
-          [SETQ TOP (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                       of SCRATCHSEL]
-          [SETQ BOTTOM (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                          of SCRATCHSEL]
-          (COND
-             [(SETQ COLS (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                            of SCRATCHSEL]
-             (T (TEDIT.PROMPTPRINT MAINTEXT "Please specify how many columns there should be." T)
-                (TEDIT.PROMPTFLASH MAINTEXT)))
-          [SETQ COLWIDTH (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                            of SCRATCHSEL]
-          [SETQ INTERCOL (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                            of SCRATCHSEL]
-                                                             (* ; "Col count, width, spacing")
-          (SETQ HEADINGS (for HEADING# from 1 to 8
-                            when (PROG1 [SETQ HEADINGTYPE (MBUTTON.NEXT.FIELD.AS.ATOM
-                                                               TEXTOBJ
-                                                               (ADD1 (fetch (SELECTION CH#)
-                                                                        of SCRATCHSEL]
-                                         [SETQ HEADINGX (MBUTTON.NEXT.FIELD.AS.NUMBER
-                                                         TEXTOBJ
-                                                         (ADD1 (fetch (SELECTION CH#)
-                                                                  of SCRATCHSEL]
-                                         [SETQ HEADINGY (MBUTTON.NEXT.FIELD.AS.NUMBER
-                                                         TEXTOBJ
-                                                         (ADD1 (fetch (SELECTION CH#)
-                                                                  of SCRATCHSEL])
-                            collect (COND
-                                           ((AND HEADINGX HEADINGY))
-                                           (T (TEDIT.PROMPTPRINT MAINTEXT (CONCAT 
-                                                                             "You need to say WHERE "
-                                                                                 HEADINGTYPE 
-                                                                                 " headings go.")
-                                                     T)
-                                              (TEDIT.PROMPTFLASH MAINTEXT)
-                                              (SETQ HEADINGINVALID T)))
-                                  (LIST HEADINGTYPE HEADINGX HEADINGY)))
-          (COND
-             (HEADINGINVALID                                 (* ; "Headings invalid.")
-                    (RETURN)))
-          [SETQ PFONT (\TEDIT.PARSE.CHARLOOKS.MENU TEXTOBJ (ADD1 (fetch (SELECTION CH#)
-                                                                        of SCRATCHSEL]
-
-(* ;;; "Glom all the oddball options (starting page, folio format &c) together")
-
-          (SETQ PAGEOPTIONS (AND STARTINGPAGE# (LIST 'STARTINGPAGE# STARTINGPAGE#)))
-          (push PAGEOPTIONS (LIST FOLIOFORMAT FOLIOPRETEXT FOLIOPOSTTEXT))
-          (push PAGEOPTIONS 'FOLIOINFO)
-          [COND
-             (LANDSCAPE?                                     (* ; 
-                                      "The pages are to be printed landscape.  Remember that fact.")
-                    (push PAGEOPTIONS T)
-                    (push PAGEOPTIONS 'LANDSCAPE?]
-          (SETQ NPAGEFORMAT (TEDIT.SINGLE.PAGEFORMAT PAGENOS PX PY PFONT (AND (NEQ ALIGNMENT
-                                                                                   'OFF)
-                                                                              ALIGNMENT)
-                                   LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS 'PICAS 
-                                   PAGEOPTIONS PAPERSIZE))
-          (SETQ OPAGEFRAMES (fetch (TEXTOBJ TXTPAGEFRAMES) of MAINTEXT))
-          [COND
-             ((NOT (LISTP OPAGEFRAMES))
-              (COND
-                 ((EQ PAGEID 'FIRST)                         (* ; 
-                                                           "Setting the first page sets them all")
-                  (SETQ PAGEOPTIONS (COPY PAGEOPTIONS))
-                  (LISTPUT PAGEOPTIONS 'STARTINGPAGE# NIL)   (* ; 
-                                   "Starting page nubmer makes no sense on other than first pages.")
-                  (SETQ NFPAGEFORMAT (TEDIT.SINGLE.PAGEFORMAT PAGENOS PX PY PFONT
-                                            (AND (NEQ ALIGNMENT 'OFF)
-                                                 ALIGNMENT)
-                                            LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS
-                                            'PICAS PAGEOPTIONS PAPERSIZE))
-                  (SETQ OPAGEFRAMES (LIST NPAGEFORMAT NFPAGEFORMAT NFPAGEFORMAT)))
-                 (T                                          (* ; 
-                                                    "Otherwise, start from the default page layout")
-                    (SETQ OPAGEFRAMES (COPY TEDIT.PAGE.FRAMES]
-          (SELECTQ PAGEID
-              (FIRST (RPLACA OPAGEFRAMES NPAGEFORMAT))
-              (LEFT (RPLACA (CDR OPAGEFRAMES)
-                           NPAGEFORMAT))
-              (RIGHT (RPLACA (CDDR OPAGEFRAMES)
-                            NPAGEFORMAT))
-              NIL)
-          (TEDIT.PAGEFORMAT MAINTEXT OPAGEFRAMES)
-          (replace (TEXTOBJ \DIRTY) of MAINTEXT with T)
-                                                             (* ; 
-                                                           "Mark the document as having changed.")
-          (TTY.PROCESS (WINDOWPROP (WINDOWPROP W 'MAINWINDOW)
-                              'PROCESS])
-
-(TEDIT.UNPARSE.PAGEFORMAT
-  [LAMBDA (PAGEREGION UNITS)                            (* ; "Edited 12-Jun-90 18:59 by mitani")
-
-(* ;;; "Take a page layout and unparse it into a PList of specs.")
-
-    (LET* ((PAPER (fetch (PAGEREGION REGIONSPEC) of PAGEREGION))
-           (PAPERWIDTH (fetch (REGION WIDTH) of PAPER))
-           (PAPERHEIGHT (fetch (REGION HEIGHT) of PAPER))
-           (REGIONS (fetch (PAGEREGION REGIONSUBBOXES) of PAGEREGION))
-           PX PY PFONT PQUAD PINFO LEFT RIGHT TOP BOTTOM (COLS 0)
-           COLWIDTH
-           (INTERCOL 0)
-           SPECS PAGENOS (OLDRIGHT NIL)
-           SCALEFACTOR HEADINGS)
-          [for REGION in REGIONS
-             do 
-
-                   (* ;; 
-             "Run thru the regions on the page, calculating information about the page as a whole.")
-
-                   (COND
-                      ((EQ (fetch (PAGEREGION REGIONFILLMETHOD) of REGION)
-                           'FOLIO)                           (* ; 
-                                                           "A page-number (%"Folio%") region")
-                       (SETQ PAGENOS T)
-                       (SETQ PX (fetch (REGION LEFT) of (fetch REGIONSPEC of REGION))
-                        )
-                       (SETQ PY (fetch (REGION BOTTOM) of (fetch REGIONSPEC of REGION
-                                                                         )))
-                       (SETQ SPECS (fetch REGIONLOCALINFO of REGION))
-                       (SETQ PFONT (LISTGET SPECS 'CHARLOOKS))
-                       [SETQ PQUAD (CADR (LISTGET SPECS 'PARALOOKS]
-                       (SELECTQ PQUAD
-                           (LEFT)
-                           (RIGHT (SETQ PX (IPLUS PX 288)))
-                           (CENTERED (SETQ PX (IPLUS PX 144)))
-                           NIL))
-                      [(EQ (fetch (PAGEREGION REGIONFILLMETHOD) of REGION)
-                           'HEADING)                         (* ; "A page-heading region")
-                       (SETQ HEADINGS (NCONC1 HEADINGS (LIST (LISTGET (fetch REGIONLOCALINFO
-                                                                         of REGION)
-                                                                    'HEADINGTYPE)
-                                                             (fetch (REGION LEFT)
-                                                                of (fetch REGIONSPEC
-                                                                          of REGION))
-                                                             (fetch (REGION BOTTOM)
-                                                                of (fetch REGIONSPEC
-                                                                          of REGION]
-                      (T                                     (* ; "A regular-text region.")
-                         (add COLS 1)                    (* ; "Count columns")
-                         (SETQ COLWIDTH (fetch (REGION WIDTH) of (fetch REGIONSPEC
-                                                                            of REGION)))
-                         [SETQ RIGHT (IDIFFERENCE PAPERWIDTH (ADD1 (fetch (REGION RIGHT)
-                                                                      of (fetch REGIONSPEC
-                                                                                of REGION]
-                         (COND
-                            ((EQ OLDRIGHT T))
-                            (OLDRIGHT (SETQ INTERCOL (IDIFFERENCE (fetch (REGION LEFT)
-                                                                     of (fetch REGIONSPEC
-                                                                               of REGION))
-                                                            OLDRIGHT))
-                                   (SETQ OLDRIGHT T))
-                            (T (SETQ OLDRIGHT (fetch (REGION RIGHT) of (fetch REGIONSPEC
-                                                                                  of REGION)))
-                               (SETQ LEFT (fetch (REGION LEFT) of (fetch REGIONSPEC
-                                                                             of REGION)))
-                               [SETQ TOP (IDIFFERENCE PAPERHEIGHT (fetch (REGION PTOP)
-                                                                     of (fetch REGIONSPEC
-                                                                               of REGION]
-                               (SETQ BOTTOM (fetch (REGION BOTTOM) of (fetch REGIONSPEC
-                                                                                 of REGION]
-          (SELECTQ UNITS
-              ((POINTS NIL)                                  (* If units are in printers points, 
-                                                           the default, do no scaling)
-                   )
-              (PICAS                                         (* The units are in picas--12pts 
-                                                           per. Scale all values.)
-                     (SETQ SCALEFACTOR 0.12))
-              (INCHES                                        (* The units are in inches, at 
-                                                           72.27pts per. Set the scale factor)
-                      (SETQ SCALEFACTOR 0.7227))
-              (CM                                            (* Units are in CM, at 72.27/2.54pts 
-                                                           per.)
-                  (SETQ SCALEFACTOR (CONSTANT (FQUOTIENT 0.7227 2.54))))
-              (\ILLEGAL.ARG UNITS))
-          [COND
-             (SCALEFACTOR                                    (* We need to do the scaling.)
-                    (AND PX (SETQ PX (FQUOTIENT (FIXR (FQUOTIENT PX SCALEFACTOR))
-                                            100)))
-                    (AND PY (SETQ PY (FQUOTIENT (FIXR (FQUOTIENT PY SCALEFACTOR))
-                                            100)))
-                    (AND LEFT (SETQ LEFT (FQUOTIENT (FIXR (FQUOTIENT LEFT SCALEFACTOR))
-                                                100)))
-                    (AND RIGHT (SETQ RIGHT (FQUOTIENT (FIXR (FQUOTIENT RIGHT SCALEFACTOR))
-                                                  100)))
-                    (AND TOP (SETQ TOP (FQUOTIENT (FIXR (FQUOTIENT TOP SCALEFACTOR))
-                                              100)))
-                    (AND BOTTOM (SETQ BOTTOM (FQUOTIENT (FIXR (FQUOTIENT BOTTOM SCALEFACTOR))
-                                                    100)))
-                    (AND COLWIDTH (SETQ COLWIDTH (FQUOTIENT (FIXR (FQUOTIENT COLWIDTH SCALEFACTOR))
-                                                        100)))
-                    (AND INTERCOL (SETQ INTERCOL (FQUOTIENT (FIXR (FQUOTIENT INTERCOL SCALEFACTOR))
-                                                        100)))
-                    (SETQ HEADINGS (for HDG in HEADINGS
-                                      collect (LIST (CAR HDG)
-                                                        (FQUOTIENT (FIXR (FQUOTIENT (CADR HDG)
-                                                                                SCALEFACTOR))
-                                                               100)
-                                                        (FQUOTIENT (FIXR (FQUOTIENT (CADDR HDG)
-                                                                                SCALEFACTOR))
-                                                               100]
-          (LIST PAGENOS PX PY PFONT PQUAD LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS
-                (fetch (PAGEREGION REGIONLOCALINFO) of PAGEREGION])
-)
-
-
-
-(* ; "Initialization Code")
-
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU TEDIT.MENUDIVIDER.SPEC 
-       TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC 
-       TEDIT.EXPANDED.PAGEMENU)
-)
-(DEFINEQ
-
-(\TEDIT.MENU.INIT
-  [LAMBDA NIL                                            (* ; "Edited 30-Mar-94 15:53 by jds")
-
-(* ;;; "Initialize the descriptions for all TEdit menus")
-
-(* ;;; "Divides between the main page layout menu and page-# font submenu")
-
-    (SETQ TEDIT.MENUDIVIDER.SPEC (LIST (create MB.TEXT
-                                              MBSTRING _ "
-
-")))
-
-(* ;;; "The principal expanded menu")
-
-    (SETQ TEDIT.EXPANDEDMENU.SPEC (LIST (create MB.BUTTON
-                                               MBLABEL _ "Quit")
-                                        (create MB.TEXT
-                                               MBSTRING _ "	")
-                                        (create MB.BUTTON
-                                               MBLABEL _ "Page Layout")
-                                        (create MB.TEXT
-                                               MBSTRING _ "	")
-                                        (create MB.BUTTON
-                                               MBLABEL _ "Char Looks")
-                                        (create MB.TEXT
-                                               MBSTRING _ "	")
-                                        (create MB.BUTTON
-                                               MBLABEL _ "Para Looks")
-                                        (create MB.TEXT
-                                               MBSTRING _ "	")
-                                        (create MB.BUTTON
-                                               MBLABEL _ "All")
-                                        (create MB.TEXT
-                                               MBSTRING _ "	")
-                                        (create MB.TOGGLE
-                                               MBTEXT _ "Unformatted"
-                                               MBCHANGESTATEFN _ (FUNCTION 
-                                                                  \TEDITMENU.RECORD.UNFORMATTED))
-                                        (create MB.TEXT
-                                               MBSTRING _ "
-")
-                                        (create MB.BUTTON
-                                               MBLABEL _ "Get")
-                                        (create MB.INSERT)
-                                        (create MB.TEXT
-                                               MBSTRING _ "	")
-                                        (create MB.BUTTON
-                                               MBLABEL _ "Put")
-                                        (create MB.INSERT)
-                                        (create MB.TEXT
-                                               MBSTRING _ "	")
-                                        (create MB.BUTTON
-                                               MBLABEL _ "Include")
-                                        (create MB.INSERT)
-                                        (create MB.TEXT
-                                               MBSTRING _ "
-")
-                                        (create MB.BUTTON
-                                               MBLABEL _ "Find")
-                                        (create MB.INSERT)
-                                        (create MB.TEXT
-                                               MBSTRING _ "	")
-                                        (create MB.BUTTON
-                                               MBLABEL _ "Substitute")
-                                        (create MB.INSERT)
-                                        (create MB.TEXT
-                                               MBSTRING _ "  for")
-                                        (create MB.INSERT)
-                                        (create MB.TEXT
-                                               MBSTRING _ "   ")
-                                        (create MB.TOGGLE
-                                               MBTEXT _ "Confirm")
-                                        (create MB.TEXT
-                                               MBSTRING _ "	")
-                                        (create MB.TOGGLE
-                                               MBTEXT _ "Use New Looks")
-                                        (create MB.TEXT
-                                               MBSTRING _ "
-")
-                                        (create MB.BUTTON
-                                               MBLABEL _ "Hardcopy")
-                                        (create MB.TEXT
-                                               MBSTRING _ "  server:")
-                                        (create MB.INSERT)
-                                        (create MB.TEXT
-                                               MBSTRING _ "  copies:")
-                                        (create MB.INSERT)
-                                        (create MB.TEXT
-                                               MBSTRING _ "
-")
-                                        (create MB.TEXT
-                                               MBSTRING _ "Print ")
-                                        (create MB.NWAY
-                                               MBBUTTONS _ '(One% Side Duplex)
-                                               MBMAXITEMSPERLINE _ 5)
-                                        (create MB.TEXT
-                                               MBSTRING _ "   Message/Phone#:")
-                                        (create MB.INSERT)))
-
-(* ;;; "The character-looks (font, etc.) menu")
-
-    (SETQ TEDIT.CHARLOOKSMENU.SPEC (LIST (create MB.TEXT
-                                                MBSTRING _ "Props:  "
-                                                MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                         (create MB.3STATE
-                                                MBLABEL _ 'Bold)
-                                         (create MB.TEXT
-                                                MBSTRING _ "  ")
-                                         (create MB.3STATE
-                                                MBLABEL _ 'Italic)
-                                         (create MB.TEXT
-                                                MBSTRING _ "  ")
-                                         (create MB.3STATE
-                                                MBLABEL _ 'Underline)
-                                         (create MB.TEXT
-                                                MBSTRING _ "  ")
-                                         (create MB.3STATE
-                                                MBLABEL _ 'StrikeThru)
-                                         (create MB.TEXT
-                                                MBSTRING _ "  ")
-                                         (create MB.3STATE
-                                                MBLABEL _ 'Overbar)
-                                         (create MB.TEXT
-                                                MBSTRING _ "
-")
-                                         (create MB.NWAY
-                                                MBBUTTONS _
-                                                '(TimesRoman Helvetica Gacha Modern Classic Terminal
-                                                        Other)
-                                                MBMAXITEMSPERLINE _ 5)
-                                         (create MB.TEXT
-                                                MBSTRING _ "other font:")
-                                         (create MB.INSERT)
-                                         (create MB.TEXT
-                                                MBSTRING _ "
-")
-                                         (create MB.TEXT
-                                                MBSTRING _ "Size: "
-                                                MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                         (create MB.INSERT)
-                                         (create MB.TEXT
-                                                MBSTRING _ "   ")
-                                         (create MB.NWAY
-                                                MBBUTTONS _ '(Normal Superscript Subscript))
-                                         (create MB.TEXT
-                                                MBSTRING _ "  distance: "
-                                                MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                         (create MB.INSERT)))
-
-(* ;;; "The paragraph-formatting menu (margins, etc.)")
-
-    (SETQ TEDIT.PARAMENU.SPEC (LIST (create MB.BUTTON
-                                           MBLABEL _ 'APPLY
-                                           MBBUTTONEVENTFN _ (FUNCTION \TEDIT.APPLY.PARALOOKS))
-                                    (create MB.TEXT
-                                           MBSTRING _ "   ")
-                                    (create MB.BUTTON
-                                           MBLABEL _ 'SHOW
-                                           MBBUTTONEVENTFN _ (FUNCTION \TEDIT.SHOW.PARALOOKS))
-                                    (create MB.TEXT
-                                           MBSTRING _ "   ")
-                                    (create MB.BUTTON
-                                           MBLABEL _ 'NEUTRAL
-                                           MBBUTTONEVENTFN _ (FUNCTION 
-                                                              \TEDIT.NEUTRALIZE.PARALOOKS.MENU))
-                                    (create MB.TEXT
-                                           MBSTRING _ "
-")
-                                    (create MB.NWAY
-                                           MBBUTTONS _ '(Left Right Centered Justified))
-                                    (create MB.TEXT
-                                           MBSTRING _ "	")
-                                    (create MB.3STATE
-                                           MBLABEL _ "Page Heading")
-                                    (create MB.TEXT
-                                           MBSTRING _ "  type:")
-                                    (create MB.INSERT)
-                                    (create MB.TEXT
-                                           MBSTRING _ "
-Line leading:"
-                                           MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                    (create MB.INSERT)
-                                    (create MB.TEXT
-                                           MBSTRING _ "pts   Para Leading:"
-                                           MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                    (create MB.INSERT)
-                                    (create MB.TEXT
-                                           MBSTRING _ "pts   Special Locn:  X"
-                                           MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                    (create MB.INSERT)
-                                    (create MB.TEXT
-                                           MBSTRING _ "picas,  Y"
-                                           MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                    (create MB.INSERT)
-                                    (create MB.TEXT
-                                           MBSTRING _ "picas
-New Page:  "
-                                           MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                    (create MB.3STATE
-                                           MBLABEL _ "Before")
-                                    (create MB.TEXT
-                                           MBSTRING _ "  ")
-                                    (create MB.3STATE
-                                           MBLABEL _ "After")
-                                    (create MB.TEXT
-                                           MBSTRING _ "	Display mode:  "
-                                           MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                    (create MB.3STATE
-                                           MBLABEL _ "Hardcopy")
-                                    (create MB.TEXT
-                                           MBSTRING _ "	Keep:  "
-                                           MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                    (create MB.3STATE
-                                           MBLABEL _ "Heading")
-                                    (create MB.TEXT
-                                           MBSTRING _ "
-Tab Type:  "
-                                           MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                    [create MB.NWAY
-                                           MBBUTTONS _ '((Left \TEDIT.TABTYPE.SET)
-                                                         (Right \TEDIT.TABTYPE.SET)
-                                                         (Centered \TEDIT.TABTYPE.SET)
-                                                         (Decimal \TEDIT.TABTYPE.SET]
-                                    (create MB.TEXT
-                                           MBSTRING _ "  ")
-                                    (create MB.TOGGLE
-                                           MBTEXT _ "Dotted Leader"
-                                           MBCHANGESTATEFN _ (FUNCTION \TEDIT.RECORD.TABLEADERS))
-                                    (create MB.TEXT
-                                           MBSTRING _ "	Default Tab Size:"
-                                           MBFONT _ (FONTCREATE 'HELVETICA 8))
-                                    (create MB.INSERT)
-                                    (create MB.TEXT
-                                           MBSTRING _ "
-")
-                                    (create MB.MARGINBAR)
-                                    (create MB.TEXT
-                                           MBSTRING _ "
-")))
-
-(* ;;; "Page-layout menu for columns, page headings, page numbers, etc.")
-
-    (SETQ TEDIT.PAGEMENU.SPEC (APPEND (LIST (create MB.BUTTON
-                                                   MBLABEL _ 'APPLY
-                                                   MBBUTTONEVENTFN _ '\TEDIT.APPLY.PAGEFORMATTING)
-                                            (create MB.TEXT
-                                                   MBSTRING _ "   "
-                                                   MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD))
-                                            (create MB.BUTTON
-                                                   MBLABEL _ 'SHOW
-                                                   MBBUTTONEVENTFN _ '\TEDIT.SHOW.PAGEFORMATTING)
-                                            (create MB.TEXT
-                                                   MBSTRING _ "
-")
-                                            (create MB.TEXT
-                                                   MBSTRING _ "For page:  ")
-                                            (create MB.NWAY
-                                                   MBBUTTONS _ '(|First(&Default)| Other% Left 
-                                                                       Other% Right))
-                                            (create MB.TEXT
-                                                   MBSTRING _ "
-   Starting Page #:  ")
-                                            (create MB.INSERT
-                                                   MBINITENTRY _ 1)
-                                            (create MB.TEXT
-                                                   MBSTRING _ "	Paper Size:  ")
-                                            (create MB.NWAY
-                                                   MBBUTTONS _ '(Letter Legal A4)
-                                                   MBINITSTATE _ 'Letter)
-                                            (create MB.TEXT
-                                                   MBSTRING _ "  ")
-                                            (create MB.TOGGLE
-                                                   MBTEXT _ "Landscape")
-                                            (create MB.TEXT
-                                                   MBSTRING _ "
-
-")
-                                            (create MB.TEXT
-                                                   MBSTRING _ "Page numbers:  ")
-                                            (create MB.TEXT
-                                                   MBSTRING _ "  "
-                                                   MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD))
-                                            (create MB.NWAY
-                                                   MBBUTTONS _ '(No Yes)
-                                                   MBINITSTATE _ 'Yes)
-                                            (create MB.TEXT
-                                                   MBSTRING _ "  ")
-                                            (create MB.TEXT
-                                                   MBSTRING _ "X: ")
-                                            (create MB.INSERT
-                                                   MBINITENTRY _ 25.5)
-                                            (create MB.TEXT
-                                                   MBSTRING _ "  ")
-                                            (create MB.TEXT
-                                                   MBSTRING _ "Y: ")
-                                            (create MB.INSERT
-                                                   MBINITENTRY _ 3)
-                                            (create MB.TEXT
-                                                   MBSTRING _ "    Format:  ")
-                                            (create MB.NWAY
-                                                   MBBUTTONS _ '(123 xiv XIV)
-                                                   MBINITSTATE _ '123)
-                                            (create MB.TEXT
-                                                   MBSTRING _ "
-		")
-                                            (create MB.TEXT
-                                                   MBSTRING _ "Alignment: ")
-                                            (create MB.NWAY
-                                                   MBBUTTONS _ '(Left Centered Right)
-                                                   MBINITSTATE _ 'Centered)
-                                            (create MB.TEXT
-                                                   MBSTRING _ "
-")
-                                            (create MB.TEXT
-                                                   MBSTRING _ "		Text before number:  ")
-                                            (create MB.INSERT
-                                                   MBINITENTRY _ "")
-                                            (create MB.TEXT
-                                                   MBSTRING _ "   Text after number:  ")
-                                            (create MB.INSERT
-                                                   MBINITENTRY _ "")
-                                            (create MB.TEXT
-                                                   MBSTRING _ "
-"))
-                                     (LIST (create MB.TEXT
-                                                  MBSTRING _ "Margins:   Left")
-                                           (create MB.INSERT
-                                                  MBINITENTRY _ 6)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  Right")
-                                           (create MB.INSERT
-                                                  MBINITENTRY _ 6)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "   Top")
-                                           (create MB.INSERT
-                                                  MBINITENTRY _ 6)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "   Bottom")
-                                           (create MB.INSERT
-                                                  MBINITENTRY _ 6)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "
-")
-                                           (create MB.TEXT
-                                                  MBSTRING _ "Columns: ")
-                                           (create MB.INSERT
-                                                  MBINITENTRY _ 1)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "	Col Width: ")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "	Space between cols: ")
-                                           (create MB.INSERT
-                                                  MBINITENTRY _ 1)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "
-")
-                                           (create MB.TEXT
-                                                  MBSTRING _ "Page Headings:"
-                                                  MBFONT _ (FONTCREATE 'HELVETICA 10 'BOLD))
-                                           (create MB.TEXT
-                                                  MBSTRING _ "
-	Heading Type:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  X:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  Y:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "	Heading Type:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  X:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  Y:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "
-	Heading Type:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  X:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  Y:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "	Heading Type:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  X:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  Y:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "
-	Heading Type:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  X:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  Y:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "	Heading Type:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  X:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  Y:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "
-	Heading Type:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  X:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  Y:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "	Heading Type:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  X:")
-                                           (create MB.INSERT)
-                                           (create MB.TEXT
-                                                  MBSTRING _ "  Y:")
-                                           (create MB.INSERT])
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(\TEDIT.MENU.INIT)
-
-(\TEDITMENU.CREATE)
-
-(\TEDIT.CHARLOOKSMENU.CREATE)
-
-(\TEDITPARAMENU.CREATE)
-
-(\TEDITPAGEMENU.CREATE)
-)
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA )
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA )
-)
-(PUTPROPS TEDITMENU COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 
-1991 1992 1993 1994 1995))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (6299 33141 (MB.BUTTONEVENTINFN 6309 . 7640) (MB.DISPLAY 7642 . 10010) (MB.SETIMAGE 
-10012 . 10970) (MB.SELFN 10972 . 12387) (MB.SIZEFN 12389 . 13406) (MB.WHENOPERATEDFN 13408 . 13740) (
-MB.COPYFN 13742 . 14204) (MB.GETFN 14206 . 14814) (MB.PUTFN 14816 . 15593) (MB.SHOWSELFN 15595 . 16567
-) (MBUTTON.CREATE 16569 . 17853) (MBUTTON.CHANGENAME 17855 . 18250) (MBUTTON.FIND.BUTTON 18252 . 19268
-) (MBUTTON.FIND.NEXT.BUTTON 19270 . 20665) (MBUTTON.FIND.NEXT.FIELD 20667 . 24381) (MBUTTON.INIT 24383
- . 25173) (MBUTTON.NEXT.FIELD.AS.NUMBER 25175 . 25528) (MBUTTON.NEXT.FIELD.AS.PIECES 25530 . 25960) (
-MBUTTON.NEXT.FIELD.AS.TEXT 25962 . 26384) (MBUTTON.NEXT.FIELD.AS.ATOM 26386 . 27259) (
-MBUTTON.SET.FIELD 27261 . 29317) (MBUTTON.SET.NEXT.FIELD 29319 . 30536) (MBUTTON.SET.NEXT.BUTTON.STATE
- 30538 . 31034) (TEDITMENU.STREAM 31036 . 31645) (\TEDITMENU.SELSCREENER 31647 . 33139)) (33445 43868 
-(MB.CREATE.THREESTATEBUTTON 33455 . 34626) (MB.THREESTATE.DISPLAY 34628 . 37218) (
-MB.THREESTATE.SHOWSELFN 37220 . 40322) (MB.THREESTATE.WHENOPERATEDFN 40324 . 41703) (
-MB.THREESTATEBUTTON.FN 41705 . 42802) (THREESTATE.INIT 42804 . 43866)) (43969 63205 (
-MB.CREATE.NWAYBUTTON 43979 . 47947) (MB.NB.DISPLAYFN 47949 . 50221) (MB.NB.WHENOPERATEDFN 50223 . 
-51255) (MB.NB.SIZEFN 51257 . 54796) (MB.NWAYBUTTON.SELFN 54798 . 56742) (MB.NWAYMENU.NEWBUTTON 56744
- . 57330) (NWAYBUTTON.INIT 57332 . 58185) (MB.NB.PACKITEMS 58187 . 60184) (MB.NWAYBUTTON.ADDITEM 60186
- . 63203)) (63459 74107 (\TEXTMENU.TOGGLE.CREATE 63469 . 64870) (\TEXTMENU.TOGGLE.DISPLAY 64872 . 
-67224) (\TEXTMENU.TOGGLE.SHOWSELFN 67226 . 69588) (\TEXTMENU.TOGGLE.WHENOPERATEDFN 69590 . 70978) (
-\TEXTMENU.TOGGLEFN 70980 . 72060) (\TEXTMENU.TOGGLE.INIT 72062 . 72897) (\TEXTMENU.SET.TOGGLE 72899 . 
-74105)) (74359 111675 (DRAWMARGINSCALE 74369 . 77913) (MARGINBAR 77915 . 85285) (MARGINBAR.CREATE 
-85287 . 88197) (MB.MARGINBAR.SELFN 88199 . 100793) (MB.MARGINBAR.SIZEFN 100795 . 101157) (
-MB.MARGINBAR.DISPLAYFN 101159 . 103844) (MDESCALE 103846 . 104285) (MSCALE 104287 . 104621) (
-MB.MARGINBAR.SHOWTAB 104623 . 106794) (MB.MARGINBAR.TABTRACK 106796 . 108131) (\TEDIT.TABTYPE.SET 
-108133 . 110784) (MARGINBAR.INIT 110786 . 111673)) (112692 130294 (\TEXTMENU.START 112702 . 115894) (
-\TEXTMENU.DOC.CREATE 115896 . 127420) (TEXTMENU.CLOSEFN 127422 . 130292)) (130604 150668 (
-\TEDITMENU.CREATE 130614 . 130914) (\TEDIT.EXPANDED.MENU 130916 . 131620) (MB.DEFAULTBUTTON.FN 131622
- . 134494) (\TEDITMENU.RECORD.UNFORMATTED 134496 . 134834) (MB.DEFAULTBUTTON.ACTIONFN 134836 . 150666)
-) (150669 178052 (\TEDIT.CHARLOOKSMENU.CREATE 150679 . 152819) (\TEDIT.EXPANDEDCHARLOOKS.MENU 152821
- . 153195) (\TEDIT.APPLY.BOLDNESS 153197 . 153482) (\TEDIT.APPLY.CHARLOOKS 153484 . 155415) (
-\TEDIT.APPLY.OLINE 155417 . 155698) (\TEDIT.SHOW.CHARLOOKS 155700 . 157613) (
-\TEDIT.NEUTRALIZE.CHARLOOKS 157615 . 158541) (\TEDIT.FILL.IN.CHARLOOKS.MENU 158543 . 166196) (
-\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166198 . 169081) (\TEDIT.PARSE.CHARLOOKS.MENU 169083 . 177191) (
-\TEDIT.APPLY.SLOPE 177193 . 177476) (\TEDIT.APPLY.STRIKEOUT 177478 . 177765) (\TEDIT.APPLY.ULINE 
-177767 . 178050)) (178053 210119 (\TEDITPARAMENU.CREATE 178063 . 178443) (\TEDIT.EXPANDEDPARA.MENU 
-178445 . 178765) (\TEDIT.APPLY.PARALOOKS 178767 . 190997) (\TEDIT.SHOW.PARALOOKS 190999 . 202526) (
-\TEDIT.NEUTRALIZE.PARALOOKS.MENU 202528 . 208599) (\TEDIT.RECORD.TABLEADERS 208601 . 210117)) (210120 
-248122 (\TEDIT.SHOW.PAGEFORMATTING 210130 . 226670) (\TEDITPAGEMENU.CREATE 226672 . 227715) (
-\TEDIT.APPLY.PAGEFORMATTING 227717 . 240088) (TEDIT.UNPARSE.PAGEFORMAT 240090 . 248120)) (248427 
-275166 (\TEDIT.MENU.INIT 248437 . 275164)))))
-STOP
diff --git a/obsolete/library/new/TEDITMENU.LCOM b/obsolete/library/new/TEDITMENU.LCOM
deleted file mode 100644
index 71e6d330..00000000
Binary files a/obsolete/library/new/TEDITMENU.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITPAGE.LCOM b/obsolete/library/new/TEDITPAGE.LCOM
deleted file mode 100644
index 96cfdc66..00000000
Binary files a/obsolete/library/new/TEDITPAGE.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITSCREEN.LCOM b/obsolete/library/new/TEDITSCREEN.LCOM
deleted file mode 100644
index e149404f..00000000
Binary files a/obsolete/library/new/TEDITSCREEN.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITSELECTION.LCOM b/obsolete/library/new/TEDITSELECTION.LCOM
deleted file mode 100644
index 17e5bd16..00000000
Binary files a/obsolete/library/new/TEDITSELECTION.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEDITWINDOW.LCOM b/obsolete/library/new/TEDITWINDOW.LCOM
deleted file mode 100644
index ffe17150..00000000
Binary files a/obsolete/library/new/TEDITWINDOW.LCOM and /dev/null differ
diff --git a/obsolete/library/new/TEXTOFD b/obsolete/library/new/TEXTOFD
deleted file mode 100644
index cfd036b0..00000000
--- a/obsolete/library/new/TEXTOFD
+++ /dev/null
@@ -1,2637 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "24-Apr-95 15:12:29" {DSK}<lispcore>library>new>TEXTOFD.;2 172919 
-
-      changes to%:  (FNS COPYTEXTSTREAM \DELETECH \INSERTCH)
-
-      previous date%: "22-Mar-95 18:08:35" {DSK}<lispcore>library>new>TEXTOFD.;1)
-
-
-(* ; "
-Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1995 by John Sybalsky & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT TEXTOFDCOMS)
-
-(RPAQQ TEXTOFDCOMS
-       [(FILES TEDITDCL)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
-               (FILES (LOADCOMP)
-                      TEDITDCL))
-        (FNS COPYTEXTSTREAM OPENTEXTSTREAM REOPENTEXTSTREAM TEDIT.STREAMCHANGEDP TEXTSTREAMP TXTFILE
-             \DELETECH \SETUPGETCH \TEDIT.REOPEN.STREAM \TEDIT.COPYTEXTSTREAM.PIECEMAPFN \TEXTINIT 
-             \TEXTMARK \TEXTTTYBOUT)
-        (FNS \INSERTCH \INSERTCR)
-        (COMS 
-
-(* ;;; "Functions to manipulate the Piece Table (PCTB)")
-
-              (FNS \CHTOPC \CHTOPCNO \CLEARPCTB \CREATEPIECEORSTREAM \DELETEPIECE \FINDPIECE 
-                   \INSERTPIECE \MAKEPCTB \SPLITPIECE \INSERT.FIRST.PIECE))
-        (COMS                                                (* ; 
-                                                           "Generic-IO type operations support")
-              (FNS \TEXTCLOSEF \TEXTCLOSEF-SUBTREE \TEXTDSPFONT \TEXTEOFP \TEXTGETEOFPTR 
-                   \TEXTGETFILEPTR \TEXTOPENF \TEXTOPENF-SUBTREE \TEXTOUTCHARFN \TEXTBACKFILEPTR 
-                   \TEXTBOUT \TEDITOUTCHARFN \TEXTSETEOF \TEXTSETFILEPTR \TEXTDSPXPOSITION 
-                   \TEXTDSPYPOSITION \TEXTLEFTMARGIN \TEXTRIGHTMARGIN \TEXTDSPCHARWIDTH 
-                   \TEXTDSPSTRINGWIDTH \TEXTDSPLINEFEED)
-              (FNS \TEXTBIN \TEDIT.TEXTBIN.STRINGSETUP \TEDIT.TEXTBIN.FILESETUP 
-                   \TEDIT.TEXTBIN.NEW.PAGE)
-              (FNS \TEXTPEEKBIN \TEDIT.PEEKBIN.NEW.PAGE))
-        (COMS                                                (* ; "Support for TEXTPROP")
-              (FNS CGETTEXTPROP CTEXTPROP GETTEXTPROP PUTTEXTPROP TEXTPROP))
-        [COMS 
-              (* ;; "Support for error handling:  The old error handler for the stream-not-open error.  This is here, because you only want to do this ONCE, even if you load TEXTOFD multiple times (as, e.g., in development)")
-
-              (INITVARS (*TEDIT-OLD-STREAM-ERROR-HANDLER* (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN]
-        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTINIT)))
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA TEXTPROP])
-
-(FILESLOAD TEDITDCL)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \SCRATCHLEN 64)
-
-
-(CONSTANTS (\SCRATCHLEN 64))
-)
-
-
-(FILESLOAD (LOADCOMP)
-       TEDITDCL)
-)
-(DEFINEQ
-
-(COPYTEXTSTREAM
-  [LAMBDA (ORIGINAL CROSSCOPY)                       (* ; "Edited 31-May-91 13:57 by jds")
-
-    (* ;; "Given a stream, textobj or window, returns a new textstream with the same contents.  If CROSSCOPY then strings will really be allocated providing copies of the text else the fileptrs still will be aliases as in the rest of TEDIT.")
-
-    (PROG ((TEXTOBJ (TEXTOBJ ORIGINAL))
-           TSEL PCTB PCLST NEWSTREAM NEWTEXTOBJ)
-          (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-          (SETQ TSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))
-          (SETQ NEWSTREAM (OPENTEXTSTREAM NIL NIL NIL NIL (fetch (TEXTOBJ EDITPROPS)
-                                                                 of TEXTOBJ)))
-                                                             (* ; 
-                           "First create an empty textstream into which the pieces can be hammered")
-          (SETQ NEWTEXTOBJ (TEXTOBJ NEWSTREAM))
-          (replace (SELECTION CH#) of TSEL with 1)
-                                                             (* ; 
-                                                           "Set up to select the whole source text")
-          (replace (SELECTION CHLIM) of TSEL with (ADD1 (fetch (TEXTOBJ TEXTLEN)
-                                                                       of TEXTOBJ)))
-          (replace (SELECTION DCH) of TSEL with (fetch (TEXTOBJ TEXTLEN) of
-                                                                                         TEXTOBJ))
-          (SETQ PCLST (TEDIT.SELECTED.PIECES TEXTOBJ TSEL CROSSCOPY (FUNCTION 
-                                                                     \TEDIT.COPYTEXTSTREAM.PIECEMAPFN
-                                                                     )
-                             TEXTOBJ NEWTEXTOBJ))            (* ; 
-                  "now get a list of copies of the pieces to be inserted into the empty textstream")
-          (\TEDIT.INSERT.PIECES NEWTEXTOBJ 1 PCLST (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)
-                 NIL NIL CROSSCOPY)                          (* ; 
-                                                          "Put the pieces into the copy textstream")
-          (replace (TEXTOBJ TEXTLEN) of NEWTEXTOBJ with (fetch (TEXTOBJ TEXTLEN)
-                                                                       of TEXTOBJ))
-                                                             (* ; 
-                                                      "The copy is the same length as the original")
-          (replace (TEXTOBJ MENUFLG) of NEWTEXTOBJ with (fetch (TEXTOBJ MENUFLG)
-                                                                       of TEXTOBJ))
-                                                             (* ; 
-                                                     "And if the original is a menu, so's the copy")
-          (RETURN NEWSTREAM])
-
-(OPENTEXTSTREAM
-  [LAMBDA (TEXT WINDOW START END PROPS)                  (* ; "Edited  4-May-93 14:38 by jds")
-                                                             (* ; 
-     "Create a text-type STREAM to describe TEXT.  Optionally, connect that to WINDOW for display.")
-    (PROG* ([WAS-TEXTSTREAM (AND (type? STREAM TEXT)
-                                 (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT]
-            [TEXTOBJ (COND
-                        (WAS-TEXTSTREAM                      (* ; 
-                               "If the guy gave us a text stream to edit, use its TEXTOBJ as ours.")
-                               (create TEXTOBJ
-                                  reusing (fetch (TEXTSTREAM TEXTOBJ) of TEXT)
-                                        \INSERTFIRSTCH _ -1 \INSERTNEXTCH _ -1 \INSERTPCVALID _ NIL))
-                        ((type? TEXTOBJ TEXT)
-                         (create TEXTOBJ using TEXT \INSERTFIRSTCH _ -1 \INSERTNEXTCH _ -1 
-                                                   \INSERTPCVALID _ NIL))
-                        (T (create TEXTOBJ]
-            (TEDIT.GET.FINISHEDFORMS NIL)
-            [PROPS (APPEND PROPS (COPY TEDIT.DEFAULT.PROPS)
-                          (COPY (fetch (TEXTOBJ EDITPROPS) of TEXTOBJ]
-            [TEXTOBJ.WINDOW.VALID (AND WINDOW (EQ WINDOW (\TEDIT.PRIMARYW TEXTOBJ))
-                                       (EQ TEXTOBJ (WINDOWPROP WINDOW 'TEXTOBJ]
-            FONT SEL PCTB PC TEXTSTREAM OTEXTOBJ PROP CLEARGET? PARALOOKS PWINDOW)
-                                                             (* ; 
-                                                    "Remember if the textobj had a window already.")
-           (replace (TEXTOBJ \WINDOW) of TEXTOBJ with (AND WINDOW (LIST WINDOW)))
-                                                             (* ; 
-              "Necessary because some incoming object types depend on knowing where the window is.")
-           (replace (TEXTOBJ LINES) of TEXTOBJ with NIL)
-
-     (* ;; "This is here so if we re-OPENTEXTSTREAM an existing stream/window pair we don't get two sets of line descriptors")
-
-           (for PROPNAME in PROPS by (CDDR PROPNAME) as PROPVAL
-              in (CDR PROPS) by (CDDR PROPVAL) do (TEXTPROP TEXTOBJ PROPNAME PROPVAL)
-                  )                                          (* ; 
-                                          "Save the PROPS for later people who'd like to know them")
-           [SETQ FONT (COND
-                         ((type? CHARLOOKS (LISTGET PROPS 'FONT))
-                          (LISTGET PROPS 'FONT))
-                         (T (\TEDIT.PARSE.CHARLOOKS.LIST [OR (LISTGET PROPS 'LOOKS)
-                                                             (COND
-                                                                [(LISTP (LISTGET PROPS 'FONT))
-                                                                 (FONTCREATE (LISTGET PROPS
-                                                                                    'FONT]
-                                                                (T (OR (LISTGET PROPS 'FONT)
-                                                                       DEFAULTFONT]
-                                   NIL TEXTOBJ]              (* ; 
-"Find the default font for this session -- either what the guy tells us, or the global default font")
-           (SETQ PARALOOKS (LISTGET PROPS 'PARALOOKS))
-
-     (* ;; "Get the default paragraph looks.  This must come before the first piece is created, so its fields can be filled in right.")
-
-           (replace (TEXTOBJ FMTSPEC) of TEXTOBJ
-              with (\TEDIT.UNIQUIFY.PARALOOKS [SETQ PARALOOKS (\TEDIT.PARSE.PARALOOKS.LIST
-                                                                   (OR PARALOOKS
-                                                                       (create FMTSPEC
-                                                                          using 
-                                                                                TEDIT.DEFAULT.FMTSPEC
-                                                                              ]
-                              TEXTOBJ))
-           [COND
-              [WAS-TEXTSTREAM                                (* ; 
-                                                    "We got a TEXTOFD stream to edit;  just use it")
-                     (SETQ OTEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of TEXT))
-                     (SETQ TEXTSTREAM TEXT)
-                     (for SELN in (LIST (fetch (TEXTOBJ SEL) of TEXTOBJ)
-                                                (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)
-                                                (fetch (TEXTOBJ SHIFTEDSEL) of TEXTOBJ)
-                                                (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)
-                                                (fetch (TEXTOBJ DELETESEL) of TEXTOBJ))
-                        do 
-
-                              (* ;; "Make all the selections point to the CURRENT textobj!")
-
-                              (COND
-                                 ((EQ OTEXTOBJ (fetch (SELECTION \TEXTOBJ) of SELN))
-                                  (replace (SELECTION \TEXTOBJ) of SELN with TEXTOBJ))
-                                 (T (replace (SELECTION SET) of SELN with NIL)))
-                              (replace (SELECTION ONFLG) of SELN with NIL))
-                     (replace (TEXTSTREAM TEXTOBJ) of TEXTSTREAM with TEXTOBJ)
-                     (replace (TEXTOBJ STREAMHINT) of TEXTOBJ with TEXTSTREAM)
-                     (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-                     (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ with NIL)
-                                                             (* ; "Mark the edit incomplete.")
-                     (replace (TEXTOBJ \DIRTY) of TEXTOBJ with NIL)
-                                                             (* ; "And mark it not changed.")
-                     (COND
-                        (FONT                                (* ; 
-                                                  "If a new default font was specified, set it up.")
-                              (replace (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ
-                                 with (\TEDIT.UNIQUIFY.CHARLOOKS FONT TEXTOBJ]
-              ((type? TEXTOBJ TEXT)                      (* ; 
-                     "We got a TEXTOBJ to edit; fill in the stream, since it might have been GC'd.")
-               (SETQ TEXTSTREAM (replace (TEXTOBJ STREAMHINT) of TEXTOBJ
-                                   with (create TEXTSTREAM
-                                                   TEXTOBJ _ TEXTOBJ)))
-               (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-               (for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM)))
-              (T                                             (* ; 
-                                 "Otherwise, create a TEXTOFD to describe the text we're editing.-")
-                 (SETQ TEXTSTREAM (replace (TEXTOBJ STREAMHINT) of TEXTOBJ
-                                     with (create TEXTSTREAM
-                                                     TEXTOBJ _ TEXTOBJ)))
-                 [replace (TEXTOBJ PCTB) of TEXTOBJ
-                    with (SETQ PCTB (TEDIT.BUILD.PCTB TEXT TEXTOBJ START END FONT PARALOOKS
-                                               (LISTGET PROPS 'CLEARGET]
-
-                 (* ;; "(setq pc (\\editelt pctb (add1 |\\FirstPieceOffset|)))")
-
-                 (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB)
-                                 0))
-                 (for FORM in TEDIT.GET.FINISHEDFORMS do (EVAL FORM))
-                 (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (fetch (BTREENODE TOTLEN)
-                                                                           of PCTB]
-           (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ
-              with (\TEDIT.UNIQUIFY.CHARLOOKS (\TEDIT.CARETLOOKS.VERIFY TEXTOBJ
-                                                         (replace (TEXTOBJ DEFAULTCHARLOOKS)
-                                                            of TEXTOBJ with (
-                                                                            \TEDIT.UNIQUIFY.CHARLOOKS
-                                                                                     FONT TEXTOBJ)))
-                              TEXTOBJ))
-           (replace (TEXTOBJ CARET) of TEXTOBJ with (create
-                                                                 TEDITCARET
-                                                                 TCCARETDS _
-                                                                 (AND WINDOW (WINDOWPROP WINDOW
-                                                                                    'DSP))
-                                                                 TCFORCEUP _ T))
-           (replace (TEXTOBJ TXTREADONLY) of TEXTOBJ with (LISTGET PROPS 'READONLY))
-           (replace (TEXTOBJ TXTTERMSA) of TEXTOBJ with (AND (SETQ PROP
-                                                                          (LISTGET PROPS 'TERMTABLE))
-                                                                         (fetch TERMSA
-                                                                            of PROP)))
-           (replace (TEXTOBJ TXTRTBL) of TEXTOBJ with (LISTGET PROPS 'READTABLE))
-           (replace (TEXTOBJ TXTWTBL) of TEXTOBJ with (LISTGET PROPS 'BOUNDTABLE))
-           [COND
-              ((LISTGET PROPS 'PAGEFORMAT)                   (* ; 
-                              "A default page formatting was supplied.  Impose it on the document.")
-               (TEDIT.PAGEFORMAT TEXTOBJ (LISTGET PROPS 'PAGEFORMAT]
-           (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
-           (SETQ PROP (LISTGET PROPS 'SEL))                  (* ; "Initial Selection, if any.")
-           (COND
-              ((EQ PROP 'DON'T)                              (* ; 
-                                        "A SEL prop of DON'T means don't make an initial selection")
-               (replace (SELECTION SET) of SEL with NIL))
-              ((type? SELECTION PROP)                    (* ; 
-                                             "We came in with an explicit initial sel.  Set it up.")
-               (\COPYSEL PROP SEL)
-               (replace (SELECTION SET) of SEL with T)
-               (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ))
-              ((AND (fetch (SELECTION SET) of SEL)
-                    (NOT PROP))                              (* ; 
-                                       "If we came into this with a valid selection, highlight it.")
-               (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ))
-              (T                                             (* ; 
-    "Starting without a selection;  let's start with a point selection before the first character.")
-                 (replace (SELECTION CH#) of SEL with (COND
-                                                                     ((FIXP PROP))
-                                                                     (PROP (CAR PROP))
-                                                                     (1)))
-                 (replace (SELECTION CHLIM) of SEL with (COND
-                                                                       ((FIXP PROP))
-                                                                       (PROP (IPLUS (CAR PROP)
-                                                                                    (CADR PROP)))
-                                                                       (1)))
-                 (replace (SELECTION DCH) of SEL with (COND
-                                                                     ((FIXP PROP)
-                                                                      0)
-                                                                     (PROP (CADR PROP))
-                                                                     (0)))
-                 (replace (SELECTION DX) of SEL with 0)
-                 (replace (SELECTION POINT) of SEL with 'LEFT)
-                 (replace (SELECTION SELKIND) of SEL with 'CHAR)
-                 (replace (SELECTION SET) of SEL with (NOT (fetch (TEXTOBJ 
-                                                                                         TXTREADONLY)
-                                                                          of TEXTOBJ)))
-                 (replace (SELECTION \TEXTOBJ) of SEL with TEXTOBJ)))
-           [COND
-              ((fetch (SELECTION SET) of SEL)        (* ; 
-                            "If there's an initial selection, it implies initial caret looks, too.")
-               (replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (\TEDIT.GET.INSERT.CHARLOOKS
-                                                                          TEXTOBJ SEL]
-           (COND
-              ((AND WINDOW (NOT TEXTOBJ.WINDOW.VALID))       (* ; 
-                                                       "Only if there's a window to display it in:")
-               (replace (TEXTOBJ \WINDOW) of TEXTOBJ with NIL)
-               (\TEDIT.WINDOW.SETUP WINDOW TEXTOBJ TEXTSTREAM PROPS)
-                                                             (* ; 
-                                                 "Set up the window, and display the initial text.")
-               )
-              ((SETQ PWINDOW (LISTGET PROPS 'PROMPTWINDOW))
-
-               (* ;; "There is no window for the session, but he has passed in a promptwindow to use, install it in the textobj")
-
-               (replace (TEXTOBJ PROMPTWINDOW) of TEXTOBJ with PWINDOW)))
-           (\SETUPGETCH (create EDITMARK
-                                   PC _ (\GETBASEPTR (\FIRSTNODE PCTB)
-                                               0)
-                                   PCOFF _ 0
-                                   PCNO _ 1)
-                  TEXTOBJ)                                   (* ; "Set the file ptr to 0")
-           (RETURN TEXTSTREAM])
-
-(REOPENTEXTSTREAM
-  [LAMBDA (STREAM)                                       (* ; "Edited 31-May-91 14:18 by jds")
-    (replace (STREAM ACCESS) of STREAM with 'BOTH)
-    (replace (STREAM BINABLE) of STREAM with T)
-    (replace (STREAM STRMBINFN) of STREAM with (FUNCTION \TEXTBIN))
-    (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION \TEXTBOUT))
-    STREAM])
-
-(TEDIT.STREAMCHANGEDP
-  [LAMBDA (STREAM RESET?)                                (* ; "Edited 31-May-91 13:57 by jds")
-    (PROG1 (fetch (TEXTOBJ \DIRTY) of (TEXTOBJ STREAM))
-        (COND
-           (RESET? (replace (TEXTOBJ \DIRTY) of (TEXTOBJ STREAM) with NIL))))])
-
-(TEXTSTREAMP
-  (LAMBDA (STREAM)                                           (* jds " 3-Apr-84 14:34")
-          
-          (* Returns the stream if it is a text stream, else NIL)
-
-    (AND (STREAMP STREAM)
-         (type? TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-         STREAM)))
-
-(TXTFILE
-  [LAMBDA (TEXTOBJ)                                      (* ; "Edited 31-May-91 13:58 by jds")
-                                                             (* This function is for compiled 
-                                                           access to the TXTFILE field in 
-                                                           RESETSAVE expressions)
-    (fetch (TEXTOBJ TXTFILE) of TEXTOBJ])
-
-(\DELETECH
-  [LAMBDA (CH# CHLIM LEN TEXTOBJ DONTDIRTY)   (* ; 
-                                                "Edited 22-Mar-95 16:32 by sybalsky:mv:envos")
-
-    (* ;; "Delete the indicated characters from the text object represented by TEXTOBJ")
-
-    (* ;; 
-  "If DONTDIRTY is non-NIL, then don't notice this change for purposes of UNDO or dirtiness.")
-
-    (COND
-       ((OR DONTDIRTY (NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)))
-
-        (* ;; "Only delete characters if changes are permitted, or if it's a TEdit-internal fixup change, e.g., when an NS character 255-x sequence is seen.")
-
-        (LET ((\INFIRSTCH (fetch (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ))
-              (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-              (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-              START-OF-PIECE PCLST)
-             (\TEDIT.CHECK (IGEQ LEN 0)
-                    "LEN of delete must be >0.")
-             (\TEDIT.CHECK (IEQP LEN (IDIFFERENCE CHLIM CH#)))
-             [COND
-                ((AND (fetch (TEXTOBJ \INSERTPCVALID) of TEXTOBJ)
-                      (IEQP CHLIM (fetch (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ))
-                      (IGEQ CH# \INFIRSTCH))                 (* ; 
-         "The deletion is from the end of the most recent type-in.  Just adjust the buffer string.")
-                 (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with
-                                                                   (replace (PIECE PLEN)
-                                                                      of (fetch (TEXTOBJ
-                                                                                         \INSERTPC)
-                                                                                of TEXTOBJ)
-                                                                      with (IDIFFERENCE CH# 
-                                                                                      \INFIRSTCH)))
-                                                             (* ; "Cut back the length")
-                 (freplace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ
-                    with (IPLUS (fetch (TEXTOBJ \INSERTLEN) of TEXTOBJ)
-                                    \INFIRSTCH))             (* ; 
-                        "and ch# of next insertion (i.e., 1 past the top CH# in the insert piece.)")
-                 (replace THLEN of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)
-                    with (IDIFFERENCE (fetch THLEN of (fetch (TEXTOBJ TXTHISTORY)
-                                                                     of TEXTOBJ))
-                                    LEN))                    (* ; 
-                                     "Reduce the length of the insertion in the history list, too.")
-                 (COND
-                    ((ZEROP (fetch (TEXTOBJ \INSERTLEN) of TEXTOBJ))
-
-                     (* ;; "He's completely emptied the type-in piece.  Remove it and force creation of a fresh one at next type-in.")
-
-                     (\DELETEPIECE (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ)
-                            PCTB)                            (* UPDATEPCNODES (fetch
-                                                           (TEXTOBJ \INSERTPC) of TEXTOBJ)
-                                                           (IMINUS LEN) PCTB)
-                     (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; 
-                                                 "Force the next insertion to be in a fresh piece.")
-                     )
-                    (T (UPDATEPCNODES (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ)
-                              (IMINUS LEN)
-                              PCTB)))                        (* ; "Adjust CH#s in the Piece Table.")
-                 )
-                ((ILEQ CH# TEXTLEN)                          (* ; 
-                                      "General case of deletion: Remove pieces as needed to do it.")
-                 (PROG (PCN PC1 PCNON PCSOUT (HIPC NIL)
-                            HI LO)
-                       (SETQ PC1 (\CHTOPC CH# PCTB T))   (* ; 
-                                                "Piece # of piece containing start of deleted text")
-                       (COND
-                          ((IGREATERP CH# START-OF-PIECE)    (* ; 
-                              "Split the piece, so the deleted text now starts on a piece boundary")
-                           (\SPLITPIECE PC1 (- CH# START-OF-PIECE)
-                                  TEXTOBJ))
-                          (T (SETQ PC1 (fetch (PIECE PREVPIECE) of PC1))
-                                                             (* ; 
-                                                "PC1 _ piece before the first piee to be deleted.-")
-                             ))
-                       (COND
-                          ((ILEQ CHLIM TEXTLEN)              (* ; 
-                                      "Find the peice that contains the END of the deleted section")
-                           (SETQ PCN (\CHTOPC CHLIM PCTB T)))
-                          (T 
-                             (* ;; 
- "Deleting past end, so n+1-th piece is the symbol LASTPIECE, which starts 1 past end of all text.")
-
-                             (SETQ START-OF-PIECE (ADD1 TEXTLEN))
-                             (SETQ PCN 'LASTPIECE)
-                             (SETQ HIPC NIL)))
-                       [COND
-                          ((ATOM PCN)                        (* ; 
-                                                           "Deleting before the end of text.")
-                           )
-                          (T                                 (* ; 
-                                                        "Deleting in front of a real piece of text")
-                             (COND
-                                ([AND (IGREATERP CHLIM START-OF-PIECE)
-                                      (ILESSP CHLIM (IPLUS START-OF-PIECE (fetch (PIECE PLEN)
-                                                                             of PCN]
-                                 (SETQ HIPC (\SPLITPIECE PCN (- CHLIM START-OF-PIECE)
-                                                   TEXTOBJ PCNON))
-                                 (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)))
-                                (T (SETQ HIPC PCN]           (* ; 
-                                                   "if not on a piece bound, split the last piece.")
-                       (AND PC1 (EQ PC1 HIPC)
-                            (HELP "circular"))
-                       [SETQ PCLST (bind NPC [PC _ (COND
-                                                          (PC1 (fetch (PIECE NEXTPIECE)
-                                                                  of PC1))
-                                                          (T 
-                                                             (* ;; 
-                                                         "(\EDITELT PCTB (ADD1 \FirstPieceOffset))")
-
-                                                             (\GETBASEPTR (\FIRSTNODE PCTB)
-                                                                    0]
-                                      while (AND PC (NEQ PC HIPC))
-                                      collect (PROG1 PC
-                                                      (SETQ PC (fetch (PIECE NEXTPIECE)
-                                                                  of PC)))]
-                       (OR DONTDIRTY (\TEDIT.HISTORYADD TEXTOBJ
-                                            (create TEDITHISTORYEVENT
-                                                   THACTION _ 'Delete
-                                                   THLEN _ LEN
-                                                   THCH# _ CH#
-                                                   THFIRSTPIECE _ PCLST)))
-                                                             (* ; 
-                                                           "Add this event to the history list")
-                       (for PC in PCLST do [AND (fetch (PIECE POBJ) of PC)
-                                                            (IMAGEOBJPROP (fetch (PIECE POBJ)
-                                                                             of PC)
-                                                                   'WHENDELETEDFN)
-                                                            (APPLY* (IMAGEOBJPROP (fetch
-                                                                                   (PIECE POBJ)
-                                                                                     of PC)
-                                                                           'WHENDELETEDFN)
-                                                                   (fetch (PIECE POBJ)
-                                                                      of PC)
-                                                                   (CAR (fetch (TEXTOBJ \WINDOW)
-                                                                           of TEXTOBJ] 
-                                                             (* \DELETEPIECE PC PCTB)
-                                                      (\DELETETREE PC (fetch (PIECE PTREENODE)
-                                                                         of PC)))
-                       (COND
-                          (PC1 (replace (PIECE NEXTPIECE) of PC1 with HIPC)))
-                       (COND
-                          (HIPC (replace (PIECE PREVPIECE) of HIPC with PC1)))
-                       (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; 
-                                                 "Force the next insertion to be in a fresh piece.")
-                       (\TEDIT.DIFFUSE.PARALOOKS PC1 HIPC)   (* ; 
-                                                           "PROPOGATE PARALOOKS THRU THE DELETION")
-                   ]
-             (freplace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IDIFFERENCE TEXTLEN LEN))
-                                                             (* ; "Update the file's length")
-             (OR DONTDIRTY (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T])
-
-(\SETUPGETCH
-  [LAMBDA (CH# TEXTOBJ)                                  (* ; "Edited 14-Apr-93 17:14 by jds")
-
-(* ;;; "Set up TEXTOBJ so that the next \GETCH will retrieve character # CH#")
-
-    (* ;; "NB that 1st char in the textobj is #1.")
-
-    (* ;; "(declare (localvars . t))")
-
-    (PROG (PC PCNO PS PF CHOFFSET CHARSLEFT (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-              (STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))
-              FPOS OFFST SUBSTREAM START-OF-PIECE)
-          (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL)
-          [COND
-             [(LISTP CH#)                                    (* ; 
-                                                   "If CH# is a piece-offset pair, make use of it.")
-              (SETQ PC (fetch (EDITMARK PC) of CH#))
-              (SETQ CHOFFSET (fetch (EDITMARK PCOFF) of CH#))
-              (COND
-                 ((ATOM PC)                                  (* ; 
-                                                    "This SETUPGETCH is to the final pseudo-piece!")
-                  (freplace (TEXTSTREAM PIECE) of STREAM with PC)
-                  (freplace (STREAM COFFSET) of STREAM with 0)
-                  (freplace (STREAM CPAGE) of STREAM with 0)
-                  (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0)
-                  (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 0)
-                  (freplace (TEXTSTREAM PCOFFSET) of STREAM with 0)
-                  (RETURN]
-             ((IGREATERP CH# (IMAX 1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)))
-              (ERROR "TRYING TO \SETUPGETCH BEYOND END OF TEXT"))
-             (T 
-                (* ;; "CH# is indeed a character number.  Find the corresponding piece, its pcno, and the offset within that piece.")
-
-                (SETQ PC (\CHTOPC CH# PCTB T))
-
-                (* ;; "(setq pc (\\editelt pctb (add1 pcno)))")
-
-                (SETQ CHOFFSET (- CH# START-OF-PIECE]
-          (freplace (TEXTSTREAM PIECE) of STREAM with PC)
-          (replace (STREAM BINABLE) of STREAM with T)
-          (SETQ CHARSLEFT (IDIFFERENCE (fetch (PIECE PLEN) of PC)
-                                 CHOFFSET))
-          (freplace (TEXTSTREAM PCOFFSET) of STREAM with CHOFFSET)
-          (COND
-             ((SETQ PS (ffetch (PIECE PSTR) of PC))  (* ; "This piece resides in a STRING.")
-              (\TEDIT.TEXTBIN.STRINGSETUP CHOFFSET CHARSLEFT STREAM PS))
-             ((SETQ PF (ffetch (PIECE PFILE) of PC)) (* ; "This piece resides on a FILE")
-              (\TEDIT.TEXTBIN.FILESETUP PC CHOFFSET CHARSLEFT STREAM PF (fetch (PIECE PFATP)
-                                                                               of PC)))
-             [(SETQ PF (ffetch (PIECE POBJ) of PC))  (* ; 
-          "This piece points to an object.  set up so \TextBin will be called, and will return it.")
-              (COND
-                 ((SETQ SUBSTREAM (IMAGEOBJPROP PF 'SUBSTREAM))
-                                                             (* ; 
-                                         "There is a stream below this one! Reflect things upward.")
-                                                             (* ; 
-                                    "This is a simple object.  Just set things up so it gets read.")
-                  (\SETUPGETCH (ADD1 CHOFFSET)
-                         (fetch (TEXTSTREAM TEXTOBJ) of SUBSTREAM))
-                  (replace (STREAM BINABLE) of STREAM with NIL)
-                  (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
-                  (freplace (STREAM COFFSET) of STREAM with CHOFFSET)
-                  (freplace (STREAM CBUFSIZE) of STREAM with (fetch (PIECE PLEN)
-                                                                            of PC))
-                  (freplace (STREAM CPAGE) of STREAM with 0)
-                  (freplace (TEXTSTREAM PCSTARTCH) of STREAM with CHOFFSET)
-                  (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0)
-                  (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with
-                                                                           (fetch (TEXTSTREAM
-                                                                                       
-                                                                                     CURRENTPARALOOKS
-                                                                                       ) of
-                                                                                         SUBSTREAM))
-                  (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (fetch
-                                                                                 (TEXTSTREAM 
-                                                                                        CURRENTLOOKS)
-                                                                                   of SUBSTREAM))
-                  (RETURN))
-                 (T                                          (* ; 
-                                    "This is a simple object.  Just set things up so it gets read.")
-                    (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 1)
-                    (freplace (STREAM COFFSET) of STREAM with 0)
-                    (freplace (STREAM CBUFSIZE) of STREAM with 1)
-                    (freplace (STREAM CPAGE) of STREAM with 0)
-                    (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 0)
-                    (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0)
-                    (replace (STREAM BINABLE) of STREAM with NIL)
-                                                             (* ; 
-                                                          "Force the next BIN to go thru our code.")
-                    ]
-             (T (ERROR "Piece is neither a file nor a string??" PC)))
-          (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM with
-                                                                   (\TEDIT.APPLY.PARASTYLES
-                                                                    (fetch (PIECE PPARALOOKS)
-                                                                       of PC)
-                                                                    PC TEXTOBJ))
-                                                             (* ; 
-                                                         "Set the character looks and font caches.")
-          (replace (TEXTSTREAM CURRENTLOOKS) of STREAM with (\TEDIT.APPLY.STYLES
-                                                                         (ffetch (PIECE PLOOKS)
-                                                                            of PC)
-                                                                         PC TEXTOBJ])
-
-(\TEDIT.REOPEN.STREAM
-  [LAMBDA (TEXTSTREAM PIECESTREAM)                       (* ; "Edited 15-Apr-93 15:53 by jds")
-
-    (* ;; "Re-open the backing file stream, and propogate the change thru the entire piece table.  Also, if TXTFILE is set to the closed stream, fill it in as well.")
-
-    (LET* ((NEWSTREAM (OPENSTREAM PIECESTREAM 'INPUT))
-           (TEXTOBJ (TEXTOBJ TEXTSTREAM))
-           (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-           PC)
-          (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB)
-                          0))
-
-          (* ;; "Run thru the pieces, correcting any that used this stream to use the new one:")
-
-          (while PC do (COND
-                                  ((EQ (fetch (PIECE PFILE) of PC)
-                                       PIECESTREAM)
-                                   (replace (PIECE PFILE) of PC with NEWSTREAM)))
-                              (SETQ PC (fetch (PIECE NEXTPIECE) of PC)))
-
-          (* ;; "Check the TXTFILE, and if it uses the closed stream, fix it as well:")
-
-          (COND
-             ((EQ (fetch (TEXTOBJ TXTFILE) of TEXTOBJ)
-                  PIECESTREAM)                               (* ; 
-                                                     "Yup, it was the old, closed stream.  Fix it.")
-              (replace (TEXTOBJ TXTFILE) of TEXTOBJ with NEWSTREAM)))
-
-          (* ;; "Return the new value for the stream:")
-
-          NEWSTREAM])
-
-(\TEDIT.COPYTEXTSTREAM.PIECEMAPFN
-  [LAMBDA (PC TEXTOBJ FROMOBJ TOOBJ)                     (* ; "Edited 31-May-91 14:00 by jds")
-                                                             (* Called by COPYTEXTSTREAM via 
-                                                           TEDIT.SELECTED.PIECES, to do the 
-                                                           copy-operation processing on the 
-                                                           candidate pieces.)
-    (PROG (OBJ NEWOBJ COPYFN)
-          (SETQ PC (create PIECE using PC PNEW _ T)) (* No matter what, we need a fresh 
-                                                           copy.)
-          [COND
-             ((fetch (PIECE POBJ) of PC)             (* This piece describes an object)
-              (SETQ OBJ (fetch (PIECE POBJ) of PC))
-              [COND
-                 [(SETQ COPYFN (IMAGEOBJPROP OBJ 'COPYFN))
-                  (SETQ NEWOBJ (APPLY* COPYFN OBJ (fetch (TEXTOBJ STREAMHINT) of FROMOBJ)
-                                      (fetch (TEXTOBJ STREAMHINT) of TOOBJ)))
-                  (COND
-                     ((EQ NEWOBJ 'DON'T)                     (* He said not to copy this piece --
-                                                           abort the whole copy.)
-                      (TEDIT.PROMPTPRINT TEXTOBJ "COPY of this object not allowed." T)
-                      (RETFROM 'TEDIT.COPY))
-                     (NEWOBJ (replace (PIECE POBJ) of PC with NEWOBJ))
-                     (T (replace (PIECE POBJ) of PC with (COPYALL OBJ]
-                 (OBJ                                        (* No copy fn; just strike off a 
-                                                           copy of our own)
-                      (replace (PIECE POBJ) of PC with (COPYALL OBJ]
-              (COND
-                 ((SETQ COPYFN (IMAGEOBJPROP OBJ 'WHENCOPIEDFN))
-                                                             (* If there's an eventfn for 
-                                                           copying, use it.)
-                  (APPLY* COPYFN OBJ (CAR (fetch (TEXTOBJ \WINDOW) of TOOBJ))
-                         (fetch (TEXTOBJ STREAMHINT) of FROMOBJ)
-                         (fetch (TEXTOBJ STREAMHINT) of TOOBJ]
-          (RETURN PC])
-
-(\TEXTINIT
-  [LAMBDA NIL                                            (* ; "Edited 31-May-91 14:18 by jds")
-                                                             (* ; 
-                                          "Create the FDEV and STREAM prototypes for TEXT streams.")
-
-    (* ;; "TEXT streams make use of the following STREAM fields:")
-
-    (* ;; "(DEVICE (* FDEV of this guy -- The TEXT device)")
-
-    (* ;; "F1 (* The STREAM for the PFILE of the current piece (or NIL))")
-
-    (* ;; "F2 (* # chars left in piece at end of underlying file's page)")
-
-    (* ;; "F3 (* The TEXTOBJ for this stream)")
-
-    (* ;; "F4")
-
-    (* ;; "F5 (* The PIECE we're currently inside)")
-
-    (* ;; "(FW6 WORD) (* CPAGE for the start of the piece, for BACKFILEPTR)")
-
-    (* ;; "(FW7 WORD) (* COFFSET for the start of the piece, for BACKFILEPTR)")
-
-    (* ;; "(FW8 WORD)")
-
-    (SETQ \TEXTIMAGEOPS (create IMAGEOPS
-                               IMAGETYPE _ 'TEXT
-                               IMXPOSITION _ (FUNCTION \TEXTDSPXPOSITION)
-                               IMYPOSITION _ (FUNCTION \TEXTDSPYPOSITION)
-                               IMLEFTMARGIN _ (FUNCTION \TEXTLEFTMARGIN)
-                               IMRIGHTMARGIN _ (FUNCTION \TEXTRIGHTMARGIN)
-                               IMFONT _ (FUNCTION \TEXTDSPFONT)
-                               IMCLOSEFN _ (FUNCTION NILL)
-                               IMFONTCREATE _ 'DISPLAY
-                               IMLINEFEED _ (FUNCTION \TEXTDSPLINEFEED)
-                               IMCHARWIDTH _ (FUNCTION \TEXTDSPCHARWIDTH)
-                               IMSTRINGWIDTH _ (FUNCTION \TEXTDSPSTRINGWIDTH)))
-    (SETQ \TEXTFDEV (create FDEV
-                           DEVICENAME _ 'TEXT
-                           RESETABLE _ T
-                           RANDOMACCESSP _ T
-                           PAGEMAPPED _ NIL
-                           GETFILENAME _ (FUNCTION NILL)
-                           BIN _ (FUNCTION \TEXTBIN)
-                           BOUT _ (FUNCTION \TEXTBOUT)
-                           CLOSEFILE _ (FUNCTION \TEXTCLOSEF)
-                           OPENFILE _ (FUNCTION \TEXTOPENF)
-                           DELETEFILE _ (FUNCTION NILL)
-                           DIRECTORYNAMEP _ (FUNCTION NILL)
-                           EVENTFN _ (FUNCTION NILL)
-                           GENERATEFILES _ (FUNCTION \GENERATENOFILES)
-                           GETFILEINFO _ (FUNCTION NILL)
-                           HOSTNAMEP _ (FUNCTION NILL)
-                           READPAGES _ (FUNCTION NILL)
-                           REOPENFILE _ [FUNCTION (LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV STREAM)
-                                                    (replace (STREAM ACCESS) of STREAM
-                                                       with 'BOTH)
-                                                    STREAM]
-                           SETFILEINFO _ (FUNCTION NILL)
-                           BACKFILEPTR _ (FUNCTION \TEXTBACKFILEPTR)
-                           SETFILEPTR _ (FUNCTION \TEXTSETFILEPTR)
-                           PEEKBIN _ (FUNCTION \TEXTPEEKBIN)
-                           GETEOFPTR _ (FUNCTION \TEXTGETEOFPTR)
-                           GETFILEPTR _ (FUNCTION \TEXTGETFILEPTR)
-                           EOFP _ (FUNCTION \TEXTEOFP)
-                           FDBINABLE _ T
-                           FDBOUTABLE _ NIL
-                           FDEXTENDABLE _ NIL
-                           TRUNCATEFILE _ (FUNCTION NILL)
-                           WRITEPAGES _ (FUNCTION NILL)
-                           READCHARCODE _ (FUNCTION BIN)))
-    (SETQ \TEXTOFD
-     (create STREAM
-            BINABLE _ T
-            BOUTABLE _ NIL
-            ACCESS _ 'BOTH
-            USERCLOSEABLE _ T
-            USERVISIBLE _ T
-            DEVICE _ \TEXTFDEV
-            F1 _ NIL
-            F2 _ 0
-            F3 _ NIL
-            F5 _ NIL
-            FW6 _ 0
-            FW7 _ 0
-            MAXBUFFERS _ 10
-            IMAGEOPS _ \TEXTIMAGEOPS
-            IMAGEDATA _ (create TEXTIMAGEDATA)
-            OUTCHARFN _ (FUNCTION \TEDITOUTCHARFN)))         (* ; "The prototypical Text stream")
-
-    (* ;; "Set up so that FILE NOT OPENs on TEdit streams are caught and fixed.")
-
-    (CL:SETF (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN)
-           (FUNCTION (LAMBDA (CONDITION)
-                       (LET ((STREAM (STREAM-ERROR-STREAM CONDITION)))
-                            (COND
-                               [(AND (BOUNDP 'ERRORPOS)
-                                     (TEXTSTREAMP STREAM))
-                                                             (* ; 
-           "This happened in the error handler, and it happened to a TEdit stream, so try the fix:")
-                                (LET ((XCL::RESULT (REOPENTEXTSTREAM STREAM)))
-                                     (CL:WHEN XCL::RESULT
-                                         (ENVAPPLY (STKNAME ERRORPOS)
-                                                (SUBST XCL::RESULT STREAM (STKARGS ERRORPOS))
-                                                (STKNTH -1 ERRORPOS ERRORPOS)
-                                                ERRORPOS T T))]
-                               (*TEDIT-OLD-STREAM-ERROR-HANDLER* 
-                                                             (* ; 
-                         "Some other kind of stream, so punt to the old handler (if there is one):")
-                                      (APPLY* *TEDIT-OLD-STREAM-ERROR-HANDLER* CONDITION])
-
-(\TEXTMARK
-  [LAMBDA (TEXTOBJ)                                      (* ; "Edited 31-May-91 14:18 by jds")
-    (PROG ((STREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ)))
-          (RETURN (CONS (ffetch (TEXTSTREAM PIECE) of STREAM)
-                        (IDIFFERENCE (create BYTEPTR
-                                            PAGE _ (ffetch (STREAM CPAGE) of STREAM)
-                                            OFFSET _ (ffetch (STREAM COFFSET) of STREAM))
-                               (create BYTEPTR
-                                      PAGE _ (ffetch (TEXTSTREAM PCSTARTPG) of STREAM)
-                                      OFFSET _ (ffetch (TEXTSTREAM PCSTARTCH) of STREAM])
-
-(\TEXTTTYBOUT
-  [LAMBDA (STREAM BYTE)                                  (* ; "Edited 31-May-91 14:18 by jds")
-                                                             (* Do BOUT to a text stream, which 
-                                                           is an insertion at the caret.)
-    (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)))
-          (COND
-             ((EQ BYTE ERASECHARCODE)
-              (\TEDIT.CHARDELETE TEXTOBJ "" (fetch (TEXTOBJ SEL) of TEXTOBJ)))
-             ((EQ IGNORE.CCE (fetch CCECHO of (\SYNCODE (OR (fetch (TEXTOBJ TXTTERMSA)
-                                                                       of TEXTOBJ)
-                                                                    \PRIMTERMSA)
-                                                             BYTE)))
-                                                             (* Nothing, ignore it)
-              )
-             (T (SELCHARQ BYTE
-                     ((EOL CR LF) 
-                          (\TEXTBOUT STREAM BYTE)
-                          (replace (STREAM CHARPOSITION) of STREAM with 0))
-                     (PROGN (\TEXTBOUT STREAM BYTE)
-                            (add (fetch (STREAM CHARPOSITION) of STREAM)
-                                   1])
-)
-(DEFINEQ
-
-(\INSERTCH
-  [LAMBDA (CH CH# TEXTOBJ INSERTMARK)         (* ; 
-                                                "Edited 22-Mar-95 16:44 by sybalsky:mv:envos")
-
-    (* ;; "If the current ch is 1+last ch in the distinguished INPUTPIECE, then append this text to that piece (make a new one if need be.), and fix up ch#s in the PCTB")
-
-    (* ;; "else, create a new input piece (as a substring of the old one) and INSERT it at the right spot, perhaps after splitting a piece to make room.")
-
-    (COND
-       ((NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ))
-
-        (* ;; "Only insert if the document is allowed to change.")
-
-        (PROG (PC (LEN (COND
-                          ((type? STRINGP CH)
-                           (NCHARS CH))
-                          (T 1)))
-                  [FATP (COND
-                           [(type? STRINGP CH)
-                            (AND (fetch (STRINGP FATSTRINGP) of CH)
-                                 (NOT (NULL (for CHAR instring CH
-                                               thereis (IGREATERP CHAR \MAXTHINCHAR]
-                           (T (IGREATERP CH \MAXTHINCHAR]
-                  CHNO NEWPC PREVPC EVENT REPLACING (NEWFLAG NIL)
-                  (\INEXTCH (fetch (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ))
-                  (\INLEN (fetch (TEXTOBJ \INSERTLEN) of TEXTOBJ))
-                  (\INLEFT (fetch (TEXTOBJ \INSERTLEFT) of TEXTOBJ))
-                  (\INSTRING (fetch (TEXTOBJ \INSERTSTRING) of TEXTOBJ))
-                  (\INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ))
-                  (\INFIRSTCH (fetch (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ))
-                  (PCTB (ffetch (TEXTOBJ PCTB) of TEXTOBJ))
-                  (TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-                  (IMARKPC (fetch (EDITMARK PC) of INSERTMARK))
-                  (IMARKCH (fetch (EDITMARK PCOFF) of INSERTMARK))
-                  PLOOKS NLOOKS START-OF-PIECE)
-              [COND
-                 ((ZEROP LEN)                                (* ; "Nothing to insert, really!")
-                  (RETURN))
-                 [(ZEROP (fetch (BTREENODE COUNT) of PCTB))
-                                                             (* ; "PCTB is empty.")
-                  (\INSERT.FIRST.PIECE TEXTOBJ)
-                  (SETQ \INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ))
-                  (SETQ \INSTRING (fetch (TEXTOBJ \INSERTSTRING) of TEXTOBJ))
-                  (COND
-                     ((type? STRINGP CH)                 (* ; 
-                                       "If input is a string, copy it to the insert piece's string")
-                      (RPLSTRING \INSTRING 1 CH))
-                     (T                                      (* ; 
-                                         "If it's a single charcode, move it to the piece's string")
-                        (RPLCHARCODE \INSTRING 1 CH)))
-                  (replace (PIECE PLEN) of \INPC (freplace (TEXTOBJ \INSERTLEN)
-                                                            of TEXTOBJ with LEN))
-                  (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE 512 LEN))
-                  (freplace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with LEN)
-                  (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT
-                                                    THACTION _ 'Insert
-                                                    THLEN _ (fetch (PIECE PLEN) of \INPC)
-                                                    THCH# _ CH#
-                                                    THFIRSTPIECE _ (LIST \INPC)
-                                                    THPOINT _ 'RIGHT]
-                 ((OR [AND (fetch (TEXTOBJ \INSERTPCVALID) of TEXTOBJ)
-                           (OR (IEQP CH# \INEXTCH)
-                               (AND INSERTMARK (EQ IMARKPC (fetch (PIECE NEXTPIECE) of \INPC)
-                                                   )
-                                    (EQ IMARKCH 0]
-                      (AND NIL (EQ CH# 1)
-                           (EQ \INEXTCH -1)))
-
-                  (* ;; "We're inserting at the end of a previous insertion, for which we already have a piece built.  Just add to it.")
-
-                  (* ;; "Or, First insertion to empty document.")
-
-                  (COND
-                     ((IGEQ \INLEFT LEN)                     (* ; 
-                                                 "There's enough room in this piece -- fill it in.")
-                      (COND
-                         ((type? STRINGP CH)             (* ; 
-                                       "If input is a string, copy it to the insert piece's string")
-                          (RPLSTRING \INSTRING (ADD1 \INLEN)
-                                 CH))
-                         (T                                  (* ; 
-                                         "If it's a single charcode, move it to the piece's string")
-                            (RPLCHARCODE \INSTRING (ADD1 \INLEN)
-                                   CH)))
-                      (replace (PIECE PLEN) of \INPC with (freplace (TEXTOBJ 
-                                                                                           \INSERTLEN
-                                                                                           )
-                                                                         of TEXTOBJ
-                                                                         with (IPLUS \INLEN LEN))
-                             )                               (* ; 
-                                                           "Fix the length of the insert piece")
-                      (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE 
-                                                                                         \INLEFT LEN)
-                             )                               (* ; "And the space left in the piece")
-                      (freplace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS \INEXTCH 
-                                                                                           LEN))
-                                                             (* ; "And the next CH#")
-                                                             (* ; "And the piece # for future use")
-                      )
-                     (T                                      (* ; 
-                                                     "No room.  Chop this piece & start a new one.")
-                        (replace (PIECE PSTR) of \INPC with (SUBSTRING \INSTRING 1 \INLEN
-                                                                               ))
-                                                             (* ; 
-                                                        "Chop the current piece's string to length")
-                        (SETQ NEWPC (create PIECE
-                                           PSTR _ (ALLOCSTRING 512 '% )
-                                           PLOOKS _ (fetch (PIECE PLOOKS) of \INPC)
-                                           PPARALOOKS _ (fetch (PIECE PPARALOOKS) of \INPC)
-                                           PPARALAST _ NIL
-                                           PNEW _ T))        (* ; "Create the new piece")
-                        (freplace (TEXTOBJ \INSERTSTRING) of TEXTOBJ
-                           with (SETQ \INSTRING (fetch (PIECE PSTR) of NEWPC)))
-                                                             (* ; 
-                                                           "Set the \INSTRING field in TEXTOBJ")
-                        (COND
-                           ((type? STRINGP CH)           (* ; 
-                                       "If input is a string, copy it to the insert piece's string")
-                            (RPLSTRING \INSTRING 1 CH))
-                           (T                                (* ; 
-                                         "If it's a single charcode, move it to the piece's string")
-                              (RPLCHARCODE \INSTRING 1 CH)))
-                        (replace (PIECE PLEN) of NEWPC with LEN)
-                                                             (* ; 
-                                         "So far, the present input is the only thing in the piece")
-                        (replace (TEXTOBJ \INSERTPCNO) of TEXTOBJ
-                           with (\INSERTPIECE NEWPC (OR (fetch (PIECE NEXTPIECE)
-                                                                   of \INPC)
-                                                                'LASTPIECE)
-                                           TEXTOBJ))         (* ; 
-                                          "Insert the new piece into the text and save the piece #")
-
-                        (* ;; "(SETQ PCTB (fetch PCTB of TEXTOBJ))")
-                                                             (* ; 
-                                                           "Which may have caused a PCTB overflow")
-                                                             (* ; 
-                                                       "This does not happen, after change pctree.")
-                        (freplace (TEXTOBJ \INSERTPC) of TEXTOBJ with (SETQ \INPC NEWPC))
-                        (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE
-                                                                                     512 LEN))
-                        (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with LEN)
-                        (replace (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ with CH#)
-                                                             (* ; 
-                                                           "CH# of the first inserted character")
-                        (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS CH# LEN))
-                                                             (* ; 
-                            "The CH# of the next character, if it's inserted at the current caret.")
-                        (replace THFIRSTPIECE of (fetch (TEXTOBJ TXTHISTORY) of
-                                                                                         TEXTOBJ)
-                           with (NCONC1 (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)
-                                           NEWPC))
-                        (SETQ NEWFLAG T)                     (* ; "Note the new piece's creation")
-                        ))
-                  (add (fetch THLEN of (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ))
-                         LEN)                                (* ; 
-                                             "Update the length of the insertion/replacement text.")
-                  )
-                 (T 
-                    (* ;; "NEW INSERTION POINT;  IF THERE'S ANYTHING LEFT OF THE PREVIOUS INSERT PIECE, CRACK OFF A NEW ONE & FILL IT.  THEN FIGURE OUT WHERE TO SHOEHORN IT IN.")
-
-                    (SETQ PC (OR IMARKPC (\CHTOPC CH# PCTB T)))
-                    [COND
-                       ((AND \INPC (IGEQ \INLEFT LEN))       (* ; 
-                                 "There's room left in the prior input-piece's string;  re-use it.")
-                        (SETQ NEWPC (create PIECE
-                                           PSTR _ (SUBSTRING \INSTRING (ADD1 \INLEN))
-                                           PLOOKS _ (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ)
-                                           PPARALOOKS _ (fetch (PIECE PPARALOOKS) of \INPC)
-                                           PPARALAST _ NIL
-                                           PNEW _ T))        (* ; "Build the new piece")
-                        (replace (PIECE PSTR) of \INPC with (SUBSTRING \INSTRING 1 \INLEN
-                                                                               ))
-                        (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE
-                                                                                     \INLEFT LEN)))
-                       (T                                    (* ; 
-                                                          "No room left;  build a whole new piece.")
-                          (SETQ NEWPC (create PIECE
-                                             PSTR _ (freplace (TEXTOBJ \INSERTSTRING)
-                                                       of TEXTOBJ with (ALLOCSTRING 512))
-                                             PLOOKS _ (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ)
-                                             PPARALOOKS _ (OR (AND \INPC (fetch (PIECE PPARALOOKS
-                                                                                           )
-                                                                            of \INPC))
-                                                              (\TEDIT.UNIQUIFY.PARALOOKS
-                                                               (create FMTSPEC
-                                                                  copying (fetch (TEXTOBJ
-                                                                                          FMTSPEC)
-                                                                                 of TEXTOBJ))
-                                                               TEXTOBJ))
-                                             PPARALAST _ NIL
-                                             PNEW _ T))
-                          (freplace (TEXTOBJ \INSERTLEFT) of TEXTOBJ with (IDIFFERENCE
-                                                                                       512 LEN]
-                    (freplace (TEXTOBJ \INSERTPC) of TEXTOBJ with (SETQ \INPC NEWPC))
-                    (replace (PIECE PLEN) of NEWPC with LEN)
-                    (freplace (TEXTOBJ \INSERTSTRING) of TEXTOBJ with
-                                                                         (SETQ \INSTRING
-                                                                          (fetch (PIECE PSTR)
-                                                                             of NEWPC)))
-                    (COND
-                       ((type? STRINGP CH)               (* ; 
-                                                           "Insert the characters into the piece")
-                        (RPLSTRING \INSTRING 1 CH))
-                       (T (RPLCHARCODE \INSTRING 1 CH)))
-                    (freplace (TEXTOBJ \INSERTLEN) of TEXTOBJ with LEN)
-                    (freplace (TEXTOBJ \INSERTFIRSTCH) of TEXTOBJ with CH#)
-                                                             (* ; 
-                                               "Cache the first-inserted-ch #, for backspace speed")
-                    (SETQ NEWFLAG T)
-                    (COND
-                       ((OR (IGREATERP CH# TEXTLEN)
-                            (IEQP CH# START-OF-PIECE))       (* ; 
-                      "We're inserting on a piece boundary;  do it, then remember the prior piece.")
-                        (\INSERTPIECE \INPC PC TEXTOBJ NIL))
-                       (T                                    (* ; 
-                          "Not on a piece boundary;  split the piece we're inside of, then insert.")
-                          (\INSERTPIECE \INPC (\SPLITPIECE PC (- CH# START-OF-PIECE)
-                                                         TEXTOBJ)
-                                 TEXTOBJ NIL)))
-                    [COND
-                       ((NOT (fetch (PIECE PPARALOOKS) of \INPC))
-                                                             (* ; 
-                          "There weren't any paralooks available at creation time.  Find some now.")
-                        [SETQ PLOOKS (AND (fetch (PIECE PREVPIECE) of \INPC)
-                                          (fetch (PIECE PPARALOOKS) of (fetch
-                                                                                (PIECE PREVPIECE)
-                                                                                  of \INPC]
-                        [SETQ NLOOKS (AND (fetch (PIECE NEXTPIECE) of \INPC)
-                                          (fetch (PIECE PPARALOOKS) of (fetch
-                                                                                (PIECE NEXTPIECE)
-                                                                                  of \INPC]
-                        (replace (PIECE PPARALOOKS) of \INPC
-                           with (COND
-                                       ((NOT PLOOKS)         (* ; 
-                                                           "No preceding para to take looks from")
-                                        (OR NLOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)))
-                                       ((NOT NLOOKS)         (* ; 
-                                                           "No succeeding paras to take looks from")
-                                        (OR PLOOKS (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ)))
-                                       (T PLOOKS]
-                    (replace (TEXTOBJ \INSERTPCNO) of TEXTOBJ with 0)
-                                                             (* ; 
-                                                           "Save the pcno for future insertions")
-                    (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-                                                             (* ; 
-                                                    "The PCTB may have expanded during the insert.")
-                    (SETQ PREVPC (OR (fetch (PIECE PREVPIECE) of NEWPC)
-                                     PC))                    (* ; 
-                                      "The piece we're to take the inserted characters' looks from")
-                    (replace (PIECE PLOOKS) of NEWPC with (fetch (TEXTOBJ CARETLOOKS)
-                                                                         of TEXTOBJ))
-                    [replace (PIECE PPARALOOKS) of NEWPC
-                       with (COND
-                                   ((ZEROP TEXTLEN)          (* ; 
-                                                           "No text yet;  use default paralooks")
-                                    (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))
-                                   ((SETQ PREVPC (fetch (PIECE NEXTPIECE) of \INPC))
-                                                             (* ; 
-                                                          "There's later text.  Use its para looks")
-                                    (fetch (PIECE PPARALOOKS) of PREVPC))
-                                   ((SETQ PREVPC (fetch (PIECE PREVPIECE) of \INPC))
-                                                             (* ; 
-                                         "There's earlier text.  Use its looks, copied if need be.")
-                                    (COND
-                                       ((fetch (PIECE PPARALAST) of PREVPC)
-                                        (fetch (PIECE PPARALOOKS) of PREVPC))
-                                       (T (fetch (PIECE PPARALOOKS) of PREVPC]
-                    (SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ))
-                                                             (* ; "Prior edit event.")
-                    [SETQ REPLACING (AND (EQ (fetch THACTION of EVENT)
-                                             'Delete)
-                                         (IEQP CH# (fetch THCH# of EVENT]
-                    (COND
-                       ((AND (fetch (TEXTOBJ \INSERTPCVALID) of TEXTOBJ)
-                             (IEQP CH# \INEXTCH)
-                             (EQ (fetch THACTION of EVENT)
-                                 'Insert))
-
-                        (* ;; "We're continuing a prior insertion, even if we had to create a new piece.  Just continue the old history event, too.")
-
-                        (add (fetch THLEN of EVENT)
-                               LEN))
-                       (T                                    (* ; 
-                          "Nope, this is a new insertion/replacement.  Make the new history event.")
-                          (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT
-                                                            THACTION _ (COND
-                                                                          (REPLACING 'Replace)
-                                                                          (T 'Insert))
-                                                            THLEN _ (fetch (PIECE PLEN)
-                                                                       of \INPC)
-                                                            THCH# _ CH#
-                                                            THFIRSTPIECE _ (LIST \INPC)
-                                                            THPOINT _ 'RIGHT
-                                                            THOLDINFO _ (AND REPLACING EVENT]
-              [OR NEWFLAG (PROGN                             (* ; 
-                           "We didn't add a piece, so we must update character numbers in the PCTB")
-                                                             (* ; "The insert-piece's PCTB entry")
-
-                                 (* ;; "(for I from (IPLUS PCNO \EltsPerPiece) to (\EDITELT PCTB \PCTBLastPieceOffset) by \EltsPerPiece do (\EDITSETA PCTB I (IPLUS (\EDITELT PCTB I) LEN)))")
-
-                                 (COND
-                                    ((NOT (AND (EQ CH# 1)
-                                               (EQ \INEXTCH -1)))
-                                                             (* ; 
-                            "Update character numbers in the PCTB doesn't need when 1st insertion.")
-                                     (UPDATEPCNODES \INPC LEN PCTB]
-              (freplace (TEXTOBJ TEXTLEN) of TEXTOBJ with (SETQ TEXTLEN (IPLUS LEN 
-                                                                                           TEXTLEN)))
-              (replace (TEXTOBJ \INSERTNEXTCH) of TEXTOBJ with (IPLUS CH# LEN))
-              (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with T)
-              (replace (TEXTOBJ \DIRTY) of TEXTOBJ with T)
-              (replace (PIECE PFATP) of \INPC with (OR (fetch (PIECE PFATP)
-                                                                      of \INPC)
-                                                                   FATP])
-
-(\INSERTCR
-  [LAMBDA (CH CH# TEXTOBJ)                               (* ; "Edited 31-May-91 14:00 by jds")
-
-    (* ;; "Handle insertion of CR and meta-CR.  The former causes a paragraph break, while the latter doesn't.  Note, though, that inserting a meta-CR causes the doucment to become formatted.")
-
-    (COND
-       ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ))
-       (T (LET (INPC)
-               (COND
-                  ([AND (NOT (fetch (TEXTOBJ FORMATTEDP) of TEXTOBJ))
-                        (NOT (IEQP CH (CHARCODE CR]          (* ; 
-              "Inserting a meta-CR into an unformatted document.  Start by setting up para breaks.")
-                   (\TEDIT.CONVERT.TO.FORMATTED TEXTOBJ)))
-               (\INSERTCH (CHARCODE CR)
-                      CH# TEXTOBJ)                           (* ; "Put the CR in")
-               (COND
-                  ((IEQP CH (CHARCODE CR))                   (* ; 
-                                     "It's really a CR, rather than a meta-CR so do para breaking.")
-                   (SETQ INPC (fetch (TEXTOBJ \INSERTPC) of TEXTOBJ))
-                   (AND INPC (replace (PIECE PPARALAST) of INPC with T))
-                                                             (* ; 
-             "Mark the end of the paragraph (INPC might be NIL if the insert got refused somehow).")
-                   (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; 
-                                                          "FORCE A NEW PIECE ON THE NEXT CHARACTER")
-                   ])
-)
-
-
-
-(* ;;; "Functions to manipulate the Piece Table (PCTB)")
-
-(DEFINEQ
-
-(\CHTOPC
-  [LAMBDA (CH# PCTB TELL-PC-START?)                      (* ; "Edited 15-Apr-93 16:05 by jds")
-
-    (* ;; "Given a character # in a text object, and the object's piece table, return a pointer to the piece containing that character, else NIL.")
-
-    (* ;; "If TELL-PC-START? is not NIL, sets the free variable START-OF-PIECE to the ch# of the piece's start.")
-
-    (LET ((TREE PCTB)
-          (BASE-CH# 1)
-          TBASE-CH# FOUND)
-         (while (type? BTREENODE TREE)
-            do [for I from 1 to (fetch (BTREENODE COUNT) of TREE)
-                      as OFST from 2 by 4
-                      do (COND
-                                ((IGREATERP (SETQ TBASE-CH# (IPLUS BASE-CH# (\GETBASEFIXP TREE OFST))
-                                             )
-                                        CH#)
-                                 (SETQ FOUND (\GETBASEPTR TREE (- OFST 2)))
-                                 (RETURN))
-                                (T (SETQ BASE-CH# TBASE-CH#]
-                  (SETQ TREE FOUND))
-         (AND TELL-PC-START? (SETQ START-OF-PIECE BASE-CH#))
-         (OR TREE 'LASTPIECE])
-
-(\CHTOPCNO
-  [LAMBDA (CH# PCTB)                                    (* ; "Edited 13-Jun-90 00:47 by mitani")
-
-    (* ;; "Given a character # in a text object, and the object's piece table, return a pointer to the piece containing that character, else NIL")
-
-    (DECLARE (LOCALVARS . T))
-    (LET ((INDEX 0)
-          (TREE (fetch (PCTNODE HI) of PCTB))
-          CHNUM)
-         [while TREE do (COND
-                                   [(IEQP CH# (SETQ CHNUM (fetch (PCTNODE CHNUM) of TREE)))
-                                                             (* ; "FIND NODE")
-                                    (RETURN (SETQ INDEX (IPLUS INDEX (fetch (PCTNODE RANK)
-                                                                        of TREE]
-                                   ((IGREATERP CH# CHNUM)    (* ; "MOVE RIGHT")
-                                    (SETQ INDEX (IPLUS INDEX (fetch (PCTNODE RANK) of TREE)))
-                                    (SETQ TREE (fetch (PCTNODE HI) of TREE)))
-                                   ((ILESSP CH# CHNUM)       (* ; "MOVE LEFT")
-                                    (SETQ TREE (fetch (PCTNODE LO) of TREE]
-         (IMAX INDEX 1])
-
-(\CLEARPCTB
-  [LAMBDA (PCTB)                                         (* ; "Edited 23-Feb-88 11:11 by jds")
-          
-          (* ;; "(PROG ((OLASTPC (\EDITELT PCTB \PCTBLastPieceOffset))) (\EDITSETA PCTB \FirstPieceOffset 1) (* Create the LASTPIECE pseudo-piece placeholder in the first piece of the table) (\EDITSETA PCTB (ADD1 \FirstPieceOffset) (QUOTE LASTPIECE)) (for I from \SecondPieceOffset to OLASTPC do (* Now remove the other pieces, setting them to NIL) (\EDITSETA PCTB I NIL)) (\EDITSETA PCTB \PCTBLastPieceOffset (ADD1 \FirstPieceOffset)) (* Fix up the last-piece pointer) (\EDITSETA PCTB \PCTBFreePieces (IPLUS (\EDITELT PCTB \PCTBFreePieces) (LRSH (IDIFFERENCE OLASTPC (ADD1 \FirstPieceOffset)) 1))) (* And the free count of pieces.) (RETURN PCTB))")
-
-    (HELP])
-
-(\CREATEPIECEORSTREAM
-  [LAMBDA (STRING LOOKS PARALOOKS START END)             (* ; "Edited 31-May-91 14:18 by jds")
-
-    (* ;; "Given a source for text, build a PIECE to describe it.")
-
-    (* ;; "HOWEVER-- if it's aformatted file, return the stream for that file.")
-
-    (PROG (PC)
-          [SETQ PC
-           (COND
-              ((STRINGP STRING)                              (* ; "It's a string.")
-               (create PIECE
-                      PSTR _ STRING
-                      PFILE _ NIL
-                      PLEN _ (NCHARS STRING)
-                      PPARALAST _ NIL
-                      PPARALOOKS _ PARALOOKS
-                      PFATP _ (fetch (STRINGP FATSTRINGP) of STRING)))
-              ((NULL STRING)                                 (* ; 
-                                                   "If it's NIL, use an empty string for the text.")
-               (create PIECE
-                      PSTR _ ""
-                      PFILE _ NIL
-                      PLEN _ 0
-                      PPARALAST _ NIL
-                      PPARALOOKS _ PARALOOKS))
-              ((ATOM STRING)                                 (* ; 
-                                                           "An atom is a file name.  Open it.")
-               (SETQ STRING (OPENSTREAM STRING 'INPUT 'OLD))
-               (RETURN STRING))
-              [(STREAMP STRING)
-               (COND
-                  [(EQ NoBits (fetch (STREAM ACCESSBITS) of STRING))
-                                                             (* ; 
-                                                        "If the stream is no longer open, open it.")
-                   (RETURN (OPENSTREAM STRING 'INPUT 'OLD]
-                  (T (RETURN STRING]
-              ((type? PIECE STRING)
-               STRING)
-              (T                                             (* ; 
-                                                      "Anything else is coerced to a string first.")
-                 (SETQ STRING (MKSTRING STRING))
-                 (create PIECE
-                        PSTR _ STRING
-                        PFILE _ NIL
-                        PLEN _ (NCHARS STRING)
-                        PPARALAST _ NIL
-                        PPARALOOKS _ PARALOOKS]
-          (replace (PIECE PLOOKS) of PC with (OR LOOKS (CHARLOOKS.FROM.FONT DEFAULTFONT))
-                 )
-          (replace (PIECE PPARALOOKS) of PC with (OR PARALOOKS (create FMTSPEC
-                                                                              using 
-                                                                                TEDIT.DEFAULT.FMTSPEC
-                                                                                  )))
-          (RETURN PC])
-
-(\DELETEPIECE
-  [LAMBDA (PC PCTB PC#)                                  (* ; "Edited 20-Apr-93 19:06 by jds")
-
-    (* ;; "Remove piece PC from the piece table PCTB.  Adjust the character numbers of succeeding pieces, if need be.")
-
-    (PROG (PCNODE (NEXT (fetch (PIECE NEXTPIECE) of PC))
-                 (PREV (fetch (PIECE PREVPIECE) of PC)))
-          (\DELETETREE PC (fetch (PIECE PTREENODE) of PC))
-          (COND
-             (NEXT (replace (PIECE PREVPIECE) of NEXT with PREV)))
-                                                             (* ; 
-                                                           "Break any forward link from the piece")
-          (COND
-             (PREV (replace (PIECE NEXTPIECE) of PREV with NEXT)))
-                                                             (* ; "and any backward link.")
-      ])
-
-(\FINDPIECE
-  [LAMBDA (PC PCTB)                                      (* ; "Edited 31-May-91 13:53 by jds")
-
-         (* Given a piece and the pctb it's in, return the elt %# of the CH# entry for 
-       that piece in the table)
-
-    (LET ((NODE (FINDPCNODE PC PCTB)))
-         (INDEX (fetch (PCTNODE CHNUM) of NODE)
-                PCTB])
-
-(\INSERTPIECE
-  [LAMBDA (NEW OLD TEXTOBJ DONTUPDATECH#S PC# NEW-PREVLEN PREV)
-                                                             (* ; "Edited  7-Oct-94 17:43 by jds")
-
-    (* ;; "Insert the piece NEW in front of the piece OLD;  re-allocate PCTB if need be")
-
-    (PROG* ((PLEN (fetch (PIECE PLEN) of NEW))
-            (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-            OLDLEN PCNODE PREVPC)
-           (COND
-              ((ZEROP (fetch (BTREENODE COUNT) of PCTB))
-                                                             (* ; "PCTB is empty.")
-               (replace (PIECE NEXTPIECE) of NEW with NIL)
-               (replace (PIECE PREVPIECE) of NEW with NIL)
-               (replace (BTREENODE DOWN1) of PCTB with NEW)
-               (replace (BTREENODE COUNT) of PCTB with 1)
-               (replace (BTREENODE TOTLEN) of PCTB with PLEN)
-               (RETURN 1)))
-           (SETQ OLDLEN (fetch (BTREENODE TOTLEN) of PCTB))
-           [SETQ PCNODE (COND
-                           ((OR (NULL OLD)
-                                (ATOM OLD))                  (* ; "Inserting in front of a symbol OR NIL, which must be LASTPIECE, the end-of-doc marker.  Go find the node that contains it.")
-                            (\LASTNODE PCTB))
-                           (T                                (* ; 
-         "Normal case; go find the btree node that contains the piece we're inserting in front of.")
-                              (FINDPCNODE OLD PCTB]
-           (\INSERTTREE NEW OLD PCNODE NEW-PREVLEN NIL PREV)
-
-     (* ;; "Update inter-piece linkages:")
-
-           (COND
-              [(OR (NULL OLD)
-                   (ATOM OLD))                               (* ; "Inserting in front of a symbol OR NIL, which must be LASTPIECE, the end-of-doc marker.  Go find the node that contains it.")
-               (replace (PIECE NEXTPIECE) of NEW with NIL)
-               (replace (PIECE PREVPIECE) of NEW with (AND (NOT (ZEROP OLDLEN))
-                                                                       (SETQ PREVPC (\CHTOPC
-                                                                                     OLDLEN PCTB]
-              (T                                             (* ; 
-         "Normal case; go find the btree node that contains the piece we're inserting in front of.")
-                 (replace (PIECE NEXTPIECE) of NEW with OLD)
-                 (replace (PIECE PREVPIECE) of NEW with (SETQ PREVPC (ffetch
-                                                                                  (PIECE PREVPIECE)
-                                                                                    of OLD)))
-                 (replace (PIECE PREVPIECE) of OLD with NEW)))
-           (AND PREVPC (replace (PIECE NEXTPIECE) of PREVPC with NEW])
-
-(\MAKEPCTB
-  [LAMBDA (PC1 MINLEN)                                   (* ; "Edited 15-Apr-93 15:48 by jds")
-
-    (* ;; "Create a new piece table, with PC1 as its first piece, and a dummy piece at the end, with 1st ch# of 1+ (chlim of pc1)")
-
-    (* ;; "A piece Table has the following format: It's an array, with 2 header words (1_# of pieces left in table unused) (2_offset of last used word in tbl), followed by 2-word entries: the first ch# in the piece, and a pointer to the piece.")
-
-    (* ;; "NEW piece tree ")
-
-    (* ;; "ROOT->LO: total hight of piece tree")
-
-    (* ;; "ROOT->HI : Top node of piece tree")
-
-    (LET ((PCTB (CREATE BTREENODE))
-          PLEN)
-         (COND
-            (PC1 (FREPLACE (BTREENODE COUNT) OF PCTB WITH 2)
-                 (FREPLACE (BTREENODE TOTLEN) OF PCTB WITH (SETQ PLEN (FETCH
-                                                                                   (PIECE PLEN)
-                                                                                     OF PC1)))
-                 (FREPLACE (BTREENODE DOWN1) OF PCTB WITH PC1)
-                 (FREPLACE (BTREENODE DLEN1) OF PCTB WITH PLEN)
-                 (FREPLACE (BTREENODE DOWN2) OF PCTB WITH 'LASTPIECE)
-                 (FREPLACE (BTREENODE DLEN2) OF PCTB WITH 0)
-                 (FREPLACE (PIECE PTREENODE) OF PC1 WITH PCTB))
-            (T 
-               (* ;; 
-             "No initial piece, so create a 0-long document, with only the ending-piece dummy")
-
-               (FREPLACE (BTREENODE COUNT) OF PCTB WITH 1)
-               (FREPLACE (BTREENODE TOTLEN) OF PCTB WITH 0)
-               (FREPLACE (BTREENODE DOWN1) OF PCTB WITH 'LASTPIECE)
-               (FREPLACE (BTREENODE DLEN1) OF PCTB WITH 0)))
-         PCTB])
-
-(\SPLITPIECE
-  [LAMBDA (PC CH TEXTOBJ PC#)                            (* ; "Edited 21-Apr-93 17:49 by jds")
-
-    (* ;; "Split the piece PC before CH (rel to start of PIECE);  return the new second piece.")
-
-    (* ;; "PC#, if present, points at the CH# entry for the piece being split.")
-
-    (PROG* ((PCTB (ffetch (TEXTOBJ PCTB) of TEXTOBJ))
-            (NEWPC (create PIECE using PC))
-            CHNO NEWLEN NEXTPC)
-           (SETQ CHNO CH)                                    (* ; 
-                                                    "Offset within the piece before which to break")
-           (COND
-              ((ILEQ CHNO 0)
-               (SHOULDNT "Splitting a piece at the start.")))
-           (replace (PIECE PPARALAST) of PC with NIL)
-                                                             (* ; 
-                                 "There can be no para break before the split, as things now work.")
-           (COND
-              ((ffetch (PIECE PSTR) of PC)           (* ; 
-                                  "This piece points to a string.  Split it for the two new pieces")
-               (freplace (PIECE PSTR) of NEWPC with (SUBSTRING (ffetch (PIECE PSTR)
-                                                                              of PC)
-                                                                       (ADD1 CHNO)))
-               (freplace (PIECE PLEN) of NEWPC with (IDIFFERENCE (ffetch (PIECE
-                                                                                          PLEN)
-                                                                                of PC)
-                                                                       CHNO))
-               (freplace (PIECE PSTR) of PC with (SUBSTRING (ffetch (PIECE PSTR)
-                                                                           of PC)
-                                                                    1 CHNO))
-               (freplace (PIECE PLEN) of PC with CHNO))
-              ((ffetch (PIECE PFILE) of PC)          (* ; 
-                                       "This piece points to a file.  Set the fileptrs accordingly")
-               (freplace (PIECE PFILE) of NEWPC with (ffetch (PIECE PFILE)
-                                                                    of PC))
-               [freplace (PIECE PFPOS) of NEWPC with (COND
-                                                                    ((fetch (PIECE PFATP)
-                                                                        of NEWPC)
-                                                             (* ; 
-                                     "This is a FAT piece;  need to allow 2 bytes per char skipped")
-                                                                     (IPLUS (ffetch (PIECE PFPOS)
-                                                                               of PC)
-                                                                            CHNO CHNO))
-                                                                    (T 
-                                                             (* ; 
-                                                           "Regular piece;  allow 1 byte per char")
-                                                                       (IPLUS (ffetch
-                                                                               (PIECE PFPOS)
-                                                                                 of PC)
-                                                                              CHNO]
-               (freplace (PIECE PLEN) of NEWPC with (IDIFFERENCE (ffetch (PIECE
-                                                                                          PLEN)
-                                                                                of PC)
-                                                                       CHNO))
-               (FREPLACE (PIECE PLEN) OF PC WITH CHNO)))
-           (PROGN                                            (* UNINTERRUPTABLY)
-                  (SETQ NEXTPC (ffetch (PIECE NEXTPIECE) of PC))
-                                                             (* LET ((PCNODE (FETCH
-                                                           (PIECE PTREENODE) OF PC)))
-                                                           (* ;; 
-                                      "Update the length of the original piece in it's tree entry.")
-                                                           (for ITEM# from 0 by 4 as I from 1 
-                                                           to (fetch (BTREENODE COUNT) of 
-                                                           PCNODE) when (EQ (\GETBASEPTR PCNODE 
-                                                           ITEM#) PC) do (* ;;
-                                                           "FIXME - I think this can be done as aport of \INSERTPIECE / \INSERTTREEE, by looking back 1 from the OLD entry and updating. --JDS")
-                                                           (\PUTBASEFIXP PCNODE
-                                                           (IPLUS ITEM# 2) (fetch
-                                                           (PIECE PLEN) of PC))
-                                                           (RETURN)))
-                  (\INSERTPIECE NEWPC (OR NEXTPC 'LASTPIECE)
-                         TEXTOBJ NIL NIL (IMINUS (fetch (PIECE PLEN) of NEWPC))
-                         PC)
-
-                  (* ;; "update nextlink and prevlink")
-
-                  (COND
-                     ((NULL NEXTPC)                          (* ; 
-                                                           "PC is last piece (not LASTPIECE)")
-                                                             (* ; "NEWPC is new last piece.")
-                      (replace (PIECE NEXTPIECE) of NEWPC with NIL))
-                     (T (replace (PIECE NEXTPIECE) of NEWPC with NEXTPC)
-                        (replace (PIECE PREVPIECE) of NEXTPC with NEWPC)))
-                  (replace (PIECE NEXTPIECE) of PC with NEWPC)
-                  (replace (PIECE PREVPIECE) of NEWPC with PC))
-                                                             (* ; "Now set its starting CH#")
-           (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
-                                                             (* ; 
-                                         "Whenever you split a piece, you can't add to it anymore.")
-           (RETURN NEWPC])
-
-(\INSERT.FIRST.PIECE
-  [LAMBDA (TEXTOBJ)                                      (* ; "Edited 31-May-91 14:00 by jds")
-
-    (* ;; "Insert 1st piece to empty PCTB.")
-
-    (PROG (PC)
-          (\INSERTPIECE [SETQ PC (\CREATEPIECEORSTREAM NIL (CHARLOOKS.FROM.FONT DEFAULTFONT)
-                                            (COND
-                                               (TEXTOBJ (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))
-                                               (T (create FMTSPEC using TEDIT.DEFAULT.FMTSPEC
-                                                         ]
-                 NIL TEXTOBJ)
-          (replace (TEXTOBJ \INSERTPC) of TEXTOBJ with PC)
-          (replace (PIECE PSTR) of PC with (freplace (TEXTOBJ \INSERTSTRING)
-                                                          of TEXTOBJ with (ALLOCSTRING 512])
-)
-
-
-
-(* ; "Generic-IO type operations support")
-
-(DEFINEQ
-
-(\TEXTCLOSEF
-  [LAMBDA (STREAM)                                       (* ; "Edited 15-Apr-93 16:43 by jds")
-                                                             (* ; 
-                                                           "Close the files underlying a stream")
-    (PROG ((TEXTOBJ (TEXTOBJ STREAM))
-           PCTB PC)
-          (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-          [OR (ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-              (COND
-                 ((TYPE? PIECE (SETQ PC (\GETBASEPTR (\FIRSTNODE PCTB)
-                                                   0)))
-                  (fetch (PIECE PFILE) of PC)
-                  (CLOSEF? (fetch (PIECE PFILE) of PC))
-                  (SETQ PC (FETCH (PIECE NEXTPIECE) OF PC))
-                  (WHILE PC DO (AND (fetch (PIECE PFILE) of PC)
-                                            (CLOSEF? (fetch (PIECE PFILE) of PC)))
-                                      (SETQ PC (FETCH (PIECE NEXTPIECE) OF PC]
-
-     (* ;; "And close the REAL file as well, in case we'd made a local cache.")
-
-          (CLOSEF? (fetch (TEXTOBJ TXTFILE) of TEXTOBJ])
-
-(\TEXTCLOSEF-SUBTREE
-  [LAMBDA (PCTREE)                                       (* ; "Edited 31-May-91 14:00 by jds")
-
-    (* ;; "Run thru the pieces in the document, closing the underlying file")
-
-    (* ;; "by traverse pctree")
-
-    (LET (PC)
-         (COND
-            ((NULL PCTREE)
-             NIL)
-            (T (SETQ PC (fetch (PCTNODE PCE) of PCTREE))
-               (AND (NOT (ATOM PC))
-                    (fetch (PIECE PFILE) of PC)
-                    (CLOSEF? (fetch (PIECE PFILE) of PC)))
-               (\TEXTCLOSEF-SUBTREE (fetch (PCTNODE LO) of PCTREE))
-               (\TEXTCLOSEF-SUBTREE (fetch (PCTNODE HI) of PCTREE])
-
-(\TEXTDSPFONT
-  [LAMBDA (STREAM NEWFONT)                               (* ; "Edited 31-May-91 14:02 by jds")
-
-    (* ;; "Set the font for a TEdit window.  Need change the caret looks, for character insertion, and the WINDOW's looks, so that TEXEC type-out to the window does the right thing.")
-
-    (LET ((TEXTOBJ (TEXTOBJ STREAM)))
-         (PROG1 (fetch (CHARLOOKS CLFONT) of (fetch (TEXTOBJ CARETLOOKS) of TEXTOBJ))
-             [COND
-                (NEWFONT 
-
-                       (* ;; "Only do this if there's a new font to set:")
-
-                       (TEDIT.CARETLOOKS STREAM (\GETFONTDESC NEWFONT 'DISPLAY))
-                       (COND
-                          ((fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-
-                           (* ;; "Update the windows, if there are any.")
-
-                           (for WIN in (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-                              do (DSPFONT NEWFONT WIN])])
-
-(\TEXTEOFP
-  [LAMBDA (STREAM)                                       (* ; "Edited 31-May-91 14:18 by jds")
-
-    (* ;; "Test for EOF on a text stream: At end of a piece, and there's no more pieces.")
-
-    (OR (NOT (fetch (TEXTSTREAM PIECE) of STREAM))
-        (EQ (fetch (TEXTSTREAM PIECE) of STREAM)
-            'LASTPIECE)
-        (AND (IEQP (fetch (STREAM COFFSET) of STREAM)
-                   (fetch (STREAM CBUFSIZE) of STREAM))
-             (ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
-             (OR (NOT (fetch (PIECE NEXTPIECE) of (fetch (TEXTSTREAM PIECE) of STREAM
-                                                                 )))
-                 (bind (PC _ (fetch (PIECE NEXTPIECE) of (fetch (TEXTSTREAM PIECE)
-                                                                        of STREAM))) while
-                                                                                         PC
-                    do (COND
-                              ((NOT (ZEROP (fetch (PIECE PLEN) of PC)))
-                               (RETURN NIL)))
-                          (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) finally (RETURN
-                                                                                         T])
-
-(\TEXTGETEOFPTR
-  [LAMBDA (STREAM)                                       (* ; "Edited 31-May-91 13:58 by jds")
-    (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ) of STREAM])
-
-(\TEXTGETFILEPTR
-  [LAMBDA (STREAM)                                       (* ; "Edited 28-Mar-94 15:32 by jds")
-
-    (* ;; "GETFILEPTR fn for text streams.")
-
-    (PROG ((PC (fetch (TEXTSTREAM PIECE) of STREAM))
-           (CHARSLEFT (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
-           (OFFSET (fetch (STREAM COFFSET) of STREAM))
-           (LIMIT (fetch (STREAM CBUFSIZE) of STREAM))
-           PLEN)
-          (COND
-             ((EQ PC 'LASTPIECE)                             (* ; "STREAM is Empty Document")
-              (RETURN 0))
-             [PC                                             (* ; 
-                                     "There's a piece.  That means he's inside the file somewhere.")
-                 (SETQ PLEN (fetch (PIECE PLEN) of PC))
-                 (RETURN (IMIN [SUB1 (IPLUS (\TEDIT.PIECE-CHNO PC)
-                                            (IDIFFERENCE PLEN CHARSLEFT)
-                                            (COND
-                                               ((fetch (TEXTSTREAM FATSTREAMP) of STREAM)
-                                                             (* ; 
-  "This is a 16-bit stream;  The difference is in BYTES, and needs to be divided by 2 to get chars")
-                                                (IQUOTIENT (IDIFFERENCE OFFSET LIMIT)
-                                                       2))
-                                               (T (IDIFFERENCE OFFSET LIMIT]
-                               (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ)
-                                                                      of STREAM]
-             (T                                              (* ; 
-                                             "Lack of a current piece means he walked off the end.")
-                (RETURN (IMAX 1 (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ)
-                                                                       of STREAM])
-
-(\TEXTOPENF
-  [LAMBDA (STREAM ACCESS ASDF QWER ZXCV)                 (* ; "Edited 31-May-91 13:58 by jds")
-                                                             (* Return the stream, opened for 
-                                                           input)
-    (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-           PCTB PC)
-          (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
-          (\TEXTOPENF-SUBTREE (fetch (PCTNODE HI) of PCTB))
-
-     (* ;; "(for I from (ADD1 \FirstPieceOffset) to (SUB1 (\EDITELT PCTB \PCTBLastPieceOffset)) by \EltsPerPiece do (SETQ PC (\EDITELT PCTB I)) (COND ((AND (fetch PFILE of PC) (EQ (fetch ACCESSBITS of (fetch PFILE of PC)) NoBits)) (\TEDIT.REOPEN.STREAM STREAM (fetch PFILE of PC)))))")
-
-          (RETURN STREAM])
-
-(\TEXTOPENF-SUBTREE
-  [LAMBDA (PCTREE)                                       (* ; "Edited 31-May-91 14:19 by jds")
-    (LET (PC)
-         (COND
-            ((NULL PCTREE)
-             NIL)
-            (T (SETQ PC (fetch (PCTNODE PCE) of PCTREE))
-               [COND
-                  ((AND (fetch (PIECE PFILE) of PC)
-                        (EQ (fetch (STREAM ACCESSBITS) of (fetch (PIECE PFILE)
-                                                                     of PC))
-                            NoBits))
-                   (\TEDIT.REOPEN.STREAM STREAM (fetch (PIECE PFILE) of PC]
-               (\TEXTOPENF-SUBTREE (fetch (PCTNODE LO) of PCTREE))
-               (\TEXTOPENF-SUBTREE (fetch (PCTNODE HI) of PCTREE])
-
-(\TEXTOUTCHARFN
-  [LAMBDA (CH STREAM)                                    (* ; "Edited 31-May-91 13:59 by jds")
-    (\INSERTCH CH (fetch (TEXTOBJ TEXTLEN) of (fetch (TEXTSTREAM TEXTOBJ)
-                                                             of STREAM))
-           (fetch (TEXTSTREAM TEXTOBJ) of STREAM])
-
-(\TEXTBACKFILEPTR
-  [LAMBDA (STREAM)                                       (* ; "Edited 28-Mar-94 15:32 by jds")
-
-    (* ;; "Use this to BACKFILEPTR a text stream.")
-
-    [PROG (PC PS PF REALFILE)
-          (COND
-             [(AND (IEQP (fetch (STREAM CPAGE) of STREAM)
-                         (fetch (TEXTSTREAM PCSTARTPG) of STREAM))
-                   (IEQP (fetch (STREAM COFFSET) of STREAM)
-                         (fetch (TEXTSTREAM PCSTARTCH) of STREAM)))
-                                                             (* ; 
-                                             "Hit start of piece;  back to PREVPIECE & keep going.")
-              [SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
-                          with (fetch (PIECE PREVPIECE) of (fetch (TEXTSTREAM PIECE)
-                                                                          of STREAM]
-                                                             (* ; "Move to previous piece")
-              (replace (STREAM BINABLE) of STREAM with T)
-              (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL)
-                                                             (* add (fetch (TEXTSTREAM PCNO) of 
-                                                           STREAM) -1)
-              (while (AND PC (ZEROP (fetch (PIECE PLEN) of PC)))
-                 do                                      (* ; 
-                                               "Skip over any zero-length pieces as we back along.")
-                       (SETQ PC (fetch (PIECE PREVPIECE) of PC)))
-              (COND
-                 [PC (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
-                        with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS) of PC)
-                                        PC
-                                        (fetch (TEXTSTREAM TEXTOBJ) of STREAM)))
-                     (COND
-                        ((SETQ PS (fetch (PIECE PSTR) of PC))
-                                                             (* ; "This piece lives in a string.")
-                         (\TEDIT.TEXTBIN.STRINGSETUP (SUB1 (fetch (PIECE PLEN) of PC))
-                                1 STREAM PS)
-
-                         (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.")
-
-                         )
-                        ((SETQ PF (fetch (PIECE PFILE) of PC))
-                                                             (* ; "This piece lives on a file.")
-                         (\TEDIT.TEXTBIN.FILESETUP PC (SUB1 (fetch (PIECE PLEN) of PC))
-                                1 STREAM PF (fetch (PIECE PFATP) of PC)
-                                'PEEKBIN))
-                        ((fetch (PIECE POBJ) of PC)
-                         (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0))
-                        (T (ERROR "CAN'T GET TO NEXT PIECE"]
-                 (T (ERROR "Trying to BACKFILEPTR thru start of text."]
-             ((ZEROP (fetch (STREAM COFFSET) of STREAM))
-                                                             (* ; "Move back 1 file page")
-              (SETQ REALFILE (fetch (TEXTSTREAM REALFILE) of STREAM))
-              (replace (TEXTSTREAM CHARSLEFT) of STREAM with (IPLUS (fetch
-                                                                                 (TEXTSTREAM 
-                                                                                        CHARSLEFT)
-                                                                                   of STREAM)
-                                                                                (fetch
-                                                                                 (STREAM CBUFSIZE)
-                                                                                   of STREAM)))
-              (replace (STREAM COFFSET) of REALFILE with 0)
-              (COND
-                 ((fetch (TEXTSTREAM FATSTREAMP) of STREAM)
-                                                             (* ; 
-                                                           "16 bit stream, so back up 2 bytes.")
-                  (\BACKFILEPTR REALFILE)
-                  (\BACKFILEPTR REALFILE))
-                 (T (\BACKFILEPTR REALFILE)))
-              (\PEEKBIN REALFILE)
-              (replace (STREAM CPAGE) of STREAM with (fetch (STREAM CPAGE)
-                                                                    of REALFILE))
-              (replace (STREAM COFFSET) of STREAM with (fetch (STREAM COFFSET)
-                                                                      of REALFILE))
-              (replace (STREAM CBUFSIZE) of STREAM with (fetch (STREAM CBUFSIZE)
-                                                                       of REALFILE))
-              (replace (STREAM CPPTR) of STREAM with (fetch (STREAM CPPTR)
-                                                                    of REALFILE)))
-             (T                                              (* ; "JUST ACT CASUAL & DO IT.")
-                (COND
-                   ((fetch (TEXTSTREAM FATSTREAMP) of STREAM)
-                                                             (* ; 
-                                                           "16 bit stream, so back up 2 bytes.")
-                    (\PAGEDBACKFILEPTR STREAM)
-                    (\PAGEDBACKFILEPTR STREAM))
-                   (T (\PAGEDBACKFILEPTR STREAM]
-    T])
-
-(\TEXTBOUT
-  [LAMBDA (STREAM BYTE)                                  (* ; "Edited 10-May-93 16:59 by jds")
-                                                             (* ; 
-                                    "Do BOUT to a text stream, which is an insertion at the caret.")
-    (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM))
-           (CH# (ADD1 (\TEXTGETFILEPTR STREAM)))
-           WINDOW TEXTLEN PS PC PSTR OFFST)
-          (SETQ TEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-          (SETQ WINDOW (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))
-          (AND WINDOW (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# CH#))
-          (\INSERTCH BYTE CH# TEXTOBJ)
-          (AND WINDOW (TEDIT.UPDATE.SCREEN TEXTOBJ))
-          (AND (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)
-               (RETURN))                                     (* ; 
-                                                     "If teh stream is readonly, nothing happened!")
-          [SETQ PS (ffetch (PIECE PSTR) of (SETQ PC (fetch (TEXTOBJ \INSERTPC)
-                                                               of TEXTOBJ]
-                                                             (* ; "This piece resides in a STRING.")
-          (replace (TEXTSTREAM PIECE) of STREAM with PC)
-          (freplace (STREAM CPPTR) of STREAM with (ADDBASE (ffetch (STRINGP BASE)
-                                                                          of PS)
-                                                                     (LRSH (SETQ OFFST
-                                                                            (ffetch (STRINGP
-                                                                                         OFFST)
-                                                                               of PS))
-                                                                           1)))
-          (freplace (STREAM CPAGE) of STREAM with 0)
-          (freplace (STREAM COFFSET) of STREAM with (IPLUS (freplace (TEXTSTREAM
-                                                                                      PCSTARTCH)
-                                                                          of STREAM
-                                                                          with (LOGAND 1 OFFST))
-                                                                       (fetch (TEXTOBJ \INSERTLEN
-                                                                                         )
-                                                                          of TEXTOBJ)))
-          (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0)
-                                                             (* ; 
-                                                 "Page # within the 'file' where this piece starts")
-          (freplace (STREAM CBUFSIZE) of STREAM with (fetch (STREAM COFFSET)
-                                                                    of STREAM))
-          (freplace (STREAM EPAGE) of STREAM with 1)
-          (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
-          (freplace (TEXTSTREAM REALFILE) of STREAM with NIL])
-
-(\TEDITOUTCHARFN
-  [LAMBDA (STREAM CHARCODE)                              (* ; "Edited 31-May-91 14:19 by jds")
-
-    (* ;; "OUTCHARFN for TEdit streams -- always BOUTs the character, because TEdit streams deal in complete charcodes rather than bytes. BUT -- does update the CHARPOSITION of the stream, which is used by some code to decide things.")
-
-    (COND
-       ((EQ CHARCODE (CHARCODE EOL))
-        (\BOUT STREAM (CHARCODE CR))
-        (freplace (STREAM CHARPOSITION) of STREAM with 0))
-       (T (\BOUT STREAM CHARCODE)
-          (freplace (STREAM CHARPOSITION) of STREAM with
-                                                            (PROGN 
-                                                             (* ; "Ugh.  Don't overflow")
-                                                                   (IPLUS16 (ffetch (STREAM
-                                                                                         CHARPOSITION
-                                                                                         )
-                                                                               of STREAM)
-                                                                          1])
-
-(\TEXTSETEOF
-  [LAMBDA (STREAM EOFPTR)                                (* ; "Edited 31-May-91 14:19 by jds")
-                                                             (* Set the EPAGE/EOFFSET of the 
-                                                           stream to be (SUB1 of EOFPTR))
-    (replace (STREAM EPAGE) of STREAM with (fetch (BYTEPTR PAGE) of EOFPTR))
-    (replace (STREAM EOFFSET) of STREAM with (fetch (BYTEPTR OFFSET) of EOFPTR])
-
-(\TEXTSETFILEPTR
-  [LAMBDA (STREAM FILEPOS)                               (* ; "Edited 22-Apr-93 13:44 by jds")
-                                                             (* ; 
-                                                           "Sets the file ptr for a text stream.")
-    (PROG ((TEXTOBJ (fetch (TEXTSTREAM TEXTOBJ) of STREAM)))
-          (COND
-             ((ZEROP (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)))
-             ((OR (IEQP FILEPOS -1)
-                  (IEQP FILEPOS (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)))
-                                                             (* ; "Means end of file")
-              (\SETUPGETCH (IMAX 1 (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
-                     TEXTOBJ)
-              (\BIN STREAM))
-             ((OR (ILESSP FILEPOS 0)
-                  (IGREATERP FILEPOS (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)))
-                                                             (* ; 
-                                                     "If the fileptr is not within the text, punt.")
-              (\ILLEGAL.ARG FILEPOS))
-             (T (\SETUPGETCH (IMAX 1 (ADD1 FILEPOS))
-                       TEXTOBJ])
-
-(\TEXTDSPXPOSITION
-  [LAMBDA (STREAM XPOSITION)                             (* ; "Edited 31-May-91 13:59 by jds")
-
-         (* Simply returns the XPOSITION of the primary window's display stream, this is 
-       a read-only function)
-
-    (LET [(WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ STREAM]
-         (IF WINDOW
-             THEN (DSPXPOSITION NIL WINDOW)
-           ELSE (POSITION STREAM XPOSITION])
-
-(\TEXTDSPYPOSITION
-  [LAMBDA (STREAM YPOSITION)                             (* ; "Edited 31-May-91 13:59 by jds")
-
-         (* Simply returns the XPOSITION of the primary window's display stream, this is 
-       a read-only function)
-
-    (LET [(WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ STREAM]
-         (IF WINDOW
-             THEN (DSPYPOSITION NIL WINDOW)
-           ELSE (AND \#DISPLAYLINES (NEQ \CURRENTDISPLAYLINE -1)
-                         (DIFFERENCE \#DISPLAYLINES \CURRENTDISPLAYLINE])
-
-(\TEXTLEFTMARGIN
-  [LAMBDA (STREAM XPOSITION)                             (* ; "Edited 31-May-91 14:03 by jds")
-
-(* ;;; "Returns the left margin of the textstream.  This is a read-only function")
-
-    (IF (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ STREAM)))
-        THEN [IPLUS 8 (fetch (FMTSPEC LEFTMAR) of (fetch (TEXTOBJ FMTSPEC)
-                                                                 of (TEXTOBJ STREAM]
-      ELSE 0])
-
-(\TEXTRIGHTMARGIN
-  [LAMBDA (STREAM XPOSITION)                             (* ; "Edited 31-May-91 14:03 by jds")
-
-(* ;;; "Returns the right margin of the textstream.  This is a read-only function")
-
-    (LET ((TEXTOBJ (TEXTOBJ STREAM)))
-         (IF (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)
-             THEN (LET [(RIGHTMAR (fetch (FMTSPEC RIGHTMAR) of (fetch (TEXTOBJ 
-                                                                                             FMTSPEC)
-                                                                              of TEXTOBJ]
-                           (IF (ZEROP RIGHTMAR)
-                               THEN (fetch (TEXTOBJ WRIGHT) of TEXTOBJ)
-                             ELSE RIGHTMAR))
-           ELSE (LINELENGTH NIL STREAM])
-
-(\TEXTDSPCHARWIDTH
-  [LAMBDA (STREAM CHARCODE)
-    (CHARWIDTH CHARCODE (DSPFONT NIL STREAM])
-
-(\TEXTDSPSTRINGWIDTH
-  [LAMBDA (STREAM STRING)
-    (STRINGWIDTH STRING (DSPFONT NIL STREAM])
-
-(\TEXTDSPLINEFEED
-  [LAMBDA (STREAM VALUE)
-    (FONTPROP (DSPFONT NIL STREAM)
-           'HEIGHT])
-)
-(DEFINEQ
-
-(\TEXTBIN
-  [LAMBDA (STREAM)                                       (* ; "Edited 28-Mar-94 15:33 by jds")
-
-(* ;;; "Do BIN slow case for a text stream")
-                                                             (* ; 
-                               "NB that PEEKBIN and BACKFILEPTR need to track changes in this code")
-    (DECLARE (LOCALVARS . T))
-    (PROG (CH FILE STR PF PS PC PO NPC OPC SUBSTREAM)
-          (COND
-             [(ILESSP (fetch (STREAM COFFSET) of STREAM)
-                     (fetch (STREAM CBUFSIZE) of STREAM))
-                                                             (* ; 
-                                                           "Simple case -- just do the usual BIN")
-              (COND
-                 [(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE) of STREAM
-                                                                 )))
-                                                             (* ; "Handle objects specially")
-                  (COND
-                     ((SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM))
-                                                             (* ; 
-                                       "If this object has a substream in it, go to that substream")
-                      (add (fetch (STREAM COFFSET) of STREAM)
-                             1)
-                      (RETURN (\BIN SUBSTREAM)))
-                     (T 
-                        (* ;; "Otherwise, just return the object as BIN's result, and make sure we'll go to the next page next time.")
-
-                        (replace (STREAM COFFSET) of STREAM with (fetch (STREAM
-                                                                                         CBUFSIZE)
-                                                                                of STREAM))
-                        (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
-                        (RETURN PO]
-                 [(fetch (TEXTSTREAM FATSTREAMP) of STREAM)
-                                                             (* ; 
-                                                           "This is a 16 bit BIN.  grab 2 bytes.")
-                                                             (* ; 
-                                             "WHAT HAPPENS IF THE SECOND BYTE IS ON ANOTHER PAGE??")
-                  (RETURN (LOGOR (UNFOLD (\PAGEDBIN STREAM)
-                                        256)
-                                 (COND
-                                    ((ILESSP (fetch (STREAM COFFSET) of STREAM)
-                                            (fetch (STREAM CBUFSIZE) of STREAM))
-                                                             (* ; 
-            "This pair of characters doesn't straddle a file page bound.  Just grab the next char.")
-                                     (\PAGEDBIN STREAM))
-                                    (T                       (* ; 
-      "Need to move to the next page on the backing file.  Doing so also grabs the next character.")
-                                       (\TEDIT.TEXTBIN.NEW.PAGE STREAM T]
-                 (T (RETURN (\PAGEDBIN STREAM]
-             (T                                              (* ; 
-                                       "We've either hit a page bound in a file, or a piece bound.")
-                (RETURN (COND
-                           [(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
-                                                             (* ; "Time for a new piece.")
-                            [repeatwhile (AND PC (ZEROP (fetch (PIECE PLEN) of PC)))
-                               do                        (* ; 
-                                         "Skip over any zero-length pieces at the end of the file.")
-                                     (SETQ OPC (fetch (TEXTSTREAM PIECE) of STREAM))
-                                     (SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
-                                                 with (AND OPC (fetch (PIECE NEXTPIECE)
-                                                                      of OPC]
-                            (replace (STREAM BINABLE) of STREAM with T)
-                            (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL)
-                                                             (* ; 
-                                                           "Move to the next piece in the chain")
-                            (COND
-                               [PC                           (* ; 
-                                                           "There IS a next piece to move to.")
-                                   (AND (fetch (TEXTSTREAM LOOKSUPDATEFN) of STREAM)
-                                        (SETQ NPC (APPLY* (fetch (TEXTSTREAM LOOKSUPDATEFN)
-                                                             of STREAM)
-                                                         STREAM PC))
-                                        (replace (TEXTSTREAM PIECE) of STREAM
-                                           with (SETQ PC NPC)))
-                                                             (* ; 
- "Take care of any piece-change uproar.  uproar -- which may include picking a new piece to go to.")
-                                   [COND
-                                      (NPC                   (* ; 
-                                    "If we got an NPC, this was taken care of by the LOOKSUPDATEFN")
-                                           )
-                                      ([AND (SETQ PO (fetch (PIECE POBJ) of PC))
-                                            (SETQ SUBSTREAM (IMAGEOBJPROP PO 'SUBSTREAM]
-                                       (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
-                                                             of SUBSTREAM))
-                                       (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM
-                                          with (fetch (TEXTSTREAM CURRENTPARALOOKS)
-                                                      of SUBSTREAM))
-                                       (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
-                                          with (fetch (TEXTSTREAM CURRENTLOOKS) of 
-                                                                                            SUBSTREAM
-                                                          )))
-                                      [(NEQ (fetch (PIECE PPARALOOKS) of OPC)
-                                            (fetch (PIECE PPARALOOKS) of PC))
-                                       (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM
-                                          with (\TEDIT.APPLY.PARASTYLES (fetch (PIECE 
-                                                                                           PPARALOOKS
-                                                                                              )
-                                                                               of PC)
-                                                          PC
-                                                          (fetch (TEXTSTREAM TEXTOBJ)
-                                                             of STREAM)))
-                                       (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
-                                          with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS)
-                                                                           of PC)
-                                                          PC
-                                                          (fetch (TEXTSTREAM TEXTOBJ)
-                                                             of STREAM]
-                                      ((NOT (EQCLOOKS (fetch (PIECE PLOOKS) of PC)
-                                                   (fetch (PIECE PLOOKS) of OPC)))
-                                       (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
-                                          with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS)
-                                                                           of PC)
-                                                          PC
-                                                          (fetch (TEXTSTREAM TEXTOBJ)
-                                                             of STREAM]
-                                   (COND
-                                      ((SETQ PS (fetch (PIECE PSTR) of PC))
-                                                             (* ; "This piece lives in a string.")
-                                       (\TEDIT.TEXTBIN.STRINGSETUP 0 (fetch (PIECE PLEN)
-                                                                            of PC)
-                                              STREAM PS)
-
-                                 (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.")
-                                                             (* ; 
-                                "Then actually grab the next character to hand back to the caller.")
-                                       (\BIN STREAM))
-                                      ((SETQ PF (fetch (PIECE PFILE) of PC))
-                                                             (* ; "This piece lives on a file.")
-                                       (\TEDIT.TEXTBIN.FILESETUP PC 0 (fetch (PIECE PLEN)
-                                                                             of PC)
-                                              STREAM PF (fetch (PIECE PFATP) of PC)
-                                              'PEEKBIN)
-                                       (\BIN STREAM))
-                                      [(SETQ PO (fetch (PIECE POBJ) of PC))
-                                       (replace (STREAM BINABLE) of STREAM with NIL)
-                                       (COND
-                                          (SUBSTREAM         (* ; 
-                                          "There is a stream below this one, to feed chars upward.")
-                                                 (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
-                                                                       of SUBSTREAM))
-                                                 (freplace (STREAM COFFSET) of STREAM
-                                                    with 0)
-                                                 (freplace (TEXTSTREAM CHARSLEFT) of STREAM
-                                                    with (fetch (PIECE PLEN) of PC))
-                                                 (freplace (STREAM CBUFSIZE) of STREAM
-                                                    with (fetch (PIECE PLEN) of PC))
-                                                 (freplace (STREAM CPAGE) of STREAM
-                                                    with 0)
-                                                 (freplace (TEXTSTREAM PCSTARTCH) of STREAM
-                                                    with 0)
-                                                 (freplace (TEXTSTREAM PCSTARTPG) of STREAM
-                                                    with 0)
-                                                 (replace (TEXTSTREAM CURRENTPARALOOKS)
-                                                    of STREAM with (fetch (TEXTSTREAM
-                                                                                       
-                                                                                     CURRENTPARALOOKS
-                                                                                       ) of
-                                                                                         SUBSTREAM))
-                                                 (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
-                                                    with (fetch (TEXTSTREAM CURRENTLOOKS)
-                                                                of SUBSTREAM))
-                                                 (RETURN (\BIN SUBSTREAM)))
-                                          (T (replace (TEXTSTREAM CHARSLEFT) of STREAM
-                                                with 0)
-                                             (RETURN PO]
-                                      (T (ERROR "CAN'T GET TO NEXT PIECE"]
-                               (T                            (* ; 
-                                                       "There are no more pieces.  Punt gracefully")
-                                  (COND
-                                     ((fetch (STREAM ENDOFSTREAMOP) of STREAM)
-                                                             (* ; 
-                                           "If there's an EOF handler, call it & return the result")
-                                      (RETURN (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM
-                                                             )
-                                                     STREAM)))
-                                     (T                      (* ; "Otherwise, return NIL")
-                                        (RETURN NIL]
-                           [(SETQ PO (fetch (PIECE POBJ) of (fetch (TEXTSTREAM PIECE)
-                                                                       of STREAM)))
-                                                             (* ; "This is an object")
-                            (replace (STREAM BINABLE) of STREAM with NIL)
-                            (COND
-                               (SUBSTREAM                    (* ; 
-                                          "There is a stream below this one, to feed chars upward.")
-                                      (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ) of
-                                                                                         SUBSTREAM))
-                                      (freplace (STREAM COFFSET) of STREAM with 1)
-                                      (freplace (TEXTSTREAM CHARSLEFT) of STREAM with
-                                                                                         0)
-                                      (freplace (STREAM CBUFSIZE) of STREAM
-                                         with (fetch (PIECE PLEN) of PC))
-                                      (freplace (STREAM CPAGE) of STREAM with 0)
-                                      (freplace (TEXTSTREAM PCSTARTCH) of STREAM with
-                                                                                         1)
-                                      (freplace (TEXTSTREAM PCSTARTPG) of STREAM with
-                                                                                         0)
-                                      (replace (TEXTSTREAM CURRENTPARALOOKS) of STREAM
-                                         with (fetch (TEXTSTREAM CURRENTPARALOOKS)
-                                                     of SUBSTREAM))
-                                      (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
-                                         with (fetch (TEXTSTREAM CURRENTLOOKS) of 
-                                                                                            SUBSTREAM
-                                                         ))
-                                      (RETURN (\BIN SUBSTREAM)))
-                               (T (replace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
-                                  (RETURN PO]
-                           (T                                (* ; 
-                                                         "Need to move to the next page in a file.")
-                              (RETURN (\TEDIT.TEXTBIN.NEW.PAGE STREAM])
-
-(\TEDIT.TEXTBIN.STRINGSETUP
-  [LAMBDA (CHOFFSET CHARSLEFT STREAM PS)                 (* ; "Edited 31-May-91 14:21 by jds")
-    (PROG (OFFST)
-          (COND
-             ((fetch (STRINGP FATSTRINGP) of PS)
-
-         (* The string is FAT. Therefore, make all the offsets and things take account 
-       of the fact that each char is really 2 bytes.)
-
-              (freplace (STREAM CPPTR) of STREAM with (ADDBASE (ffetch (STRINGP
-                                                                                        BASE)
-                                                                              of PS)
-                                                                         (ffetch (STRINGP OFFST)
-                                                                            of PS)))
-
-         (* The char page ptr can point to the real first char, since it's a word.)
-
-              (freplace (STREAM CPAGE) of STREAM with 0)
-              (freplace (STREAM COFFSET) of STREAM with (UNFOLD CHOFFSET 2))
-                                                             (* Offset into the string, in bytes.
-                                                           That 2 should really be something 
-                                                           like BYTESPERFATCHAR.)
-              (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0)
-                                                             (* Page %# within the "file" where 
-                                                           this piece starts)
-              (freplace (TEXTSTREAM PCSTARTCH) of STREAM with 0)
-                                                             (* Char within "page" where the 
-                                                           piece starts (for BACKFILEPTR))
-              (freplace (STREAM CBUFSIZE) of STREAM with (IPLUS (UNFOLD CHARSLEFT 2)
-                                                                            (ffetch (STREAM
-                                                                                         COFFSET)
-                                                                               of STREAM)))
-                                                             (* Since the chars-left field is 
-                                                           words, and we're talking bytes.)
-              (freplace (STREAM EPAGE) of STREAM with 1)
-              (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
-
-         (* When we hit the end of the string, we'll have run out off the piece, too.)
-
-              (freplace (TEXTSTREAM REALFILE) of STREAM with NIL)
-              (replace (STREAM BINABLE) of STREAM with NIL)
-                                                             (* To force BINs thru the \TEXTBIN 
-                                                           function so we can get two bytes.)
-              (replace (TEXTSTREAM FATSTREAMP) of STREAM with T)
-                                                             (* And mark the stream as having 
-                                                           wide characters, so \TEXTBIN knows 
-                                                           what to do.)
-              )
-             (T                                              (* Characters are thin in this 
-                                                           string (the usual case))
-                (freplace (STREAM CPPTR) of STREAM with
-                                                           (ADDBASE (ffetch (STRINGP BASE)
-                                                                       of PS)
-                                                                  (LRSH (SETQ OFFST
-                                                                         (ffetch (STRINGP OFFST)
-                                                                            of PS))
-                                                                        1)))
-                (freplace (STREAM CPAGE) of STREAM with 0)
-                (freplace (TEXTSTREAM PCSTARTPG) of STREAM with 0)
-                                                             (* Page %# within the "file" where 
-                                                           this piece starts)
-                (freplace (TEXTSTREAM PCSTARTCH) of STREAM with (LOGAND 1 OFFST))
-                                                             (* Char within "page" where the 
-                                                           piece starts (for BACKFILEPTR))
-                (freplace (STREAM COFFSET) of STREAM with (IPLUS (LOGAND 1 OFFST)
-                                                                             CHOFFSET))
-                (freplace (STREAM CBUFSIZE) of STREAM with (IPLUS CHARSLEFT
-                                                                              (ffetch
-                                                                               (STREAM COFFSET)
-                                                                                 of STREAM)))
-                (freplace (STREAM EPAGE) of STREAM with 1)
-                (freplace (TEXTSTREAM CHARSLEFT) of STREAM with 0)
-                (freplace (TEXTSTREAM REALFILE) of STREAM with NIL)
-                (replace (TEXTSTREAM FATSTREAMP) of STREAM with NIL])
-
-(\TEDIT.TEXTBIN.FILESETUP
-  [LAMBDA (PC CHOFFSET CHARSLEFT STREAM PF FATP OPERATION NOERRORFLG)
-                                                             (* ; "Edited 15-Apr-93 15:53 by jds")
-                                                             (* ; 
-                                      "Do the setup needed to make a text stream read from a file.")
-    (PROG ((BYTESLEFT (COND
-                         (FATP (UNFOLD CHARSLEFT 2))
-                         (T CHARSLEFT)))
-           (BYTEOFFSET (COND
-                          (FATP (UNFOLD CHOFFSET 2))
-                          (T CHOFFSET)))
-           CH FPOS)
-          [COND
-             ((IEQP (ffetch (STREAM ACCESSBITS) of PF)
-                    NoBits)                                  (* ; "ASSURE THAT THE FILE IS OPEN")
-              (SETQ PF (\TEDIT.REOPEN.STREAM STREAM PF]
-          [freplace (TEXTSTREAM PCSTARTPG) of STREAM with (ffetch (BYTEPTR PAGE)
-                                                                         of (SETQ FPOS
-                                                                                 (ffetch
-                                                                                  (PIECE PFPOS)
-                                                                                    of PC]
-                                                             (* ; 
-                                                      "Page within the file where the piece starts")
-          (freplace (TEXTSTREAM PCSTARTCH) of STREAM with (ffetch (BYTEPTR OFFSET)
-                                                                         of FPOS))
-                                                             (* ; 
-                                                           "Char within the page where it starts.")
-          (SETFILEPTR PF (IPLUS FPOS BYTEOFFSET))
-          [COND
-             ((ZEROP (GETEOFPTR PF))                         (* ; 
-                                                           "For zero-length files, do nothing.")
-              )
-             ((ILESSP (IPLUS FPOS BYTEOFFSET)
-                     (GETEOFPTR PF))                         (* ; 
-                   "Only get the next character if we aren't positioning past the end of the file.")
-              (SETQ CH (SELECTQ OPERATION
-                           (PEEKBIN (\PEEKBIN PF NOERRORFLG))
-                           (BIN (\BIN PF))
-                           (\PEEKBIN PF NOERRORFLG]
-
-(* ;;; "Move all the relevant fields from the backing file's stream into the text stream, so that microcoded BINs will do the right thing.")
-
-          (freplace (STREAM CPPTR) of STREAM with (ffetch (STREAM CPPTR) of
-                                                                                         PF))
-          (freplace (STREAM CPAGE) of STREAM with (ffetch (STREAM CPAGE) of
-                                                                                         PF))
-          (freplace (STREAM COFFSET) of STREAM with (ffetch (STREAM COFFSET)
-                                                                   of PF))
-          (freplace (STREAM EPAGE) of STREAM with 32767)
-          (freplace (STREAM CBUFSIZE) of STREAM with (IMIN (ffetch (STREAM CBUFSIZE)
-                                                                          of PF)
-                                                                       (IPLUS (ffetch
-                                                                               (STREAM COFFSET)
-                                                                                 of PF)
-                                                                              BYTESLEFT)))
-          [freplace (TEXTSTREAM CHARSLEFT) of STREAM with
-                                                             (IDIFFERENCE BYTESLEFT
-                                                                    (IDIFFERENCE (ffetch
-                                                                                  (STREAM CBUFSIZE)
-                                                                                    of STREAM)
-                                                                           (ffetch (STREAM 
-                                                                                              COFFSET
-                                                                                              )
-                                                                              of STREAM]
-          (freplace (TEXTSTREAM REALFILE) of STREAM with PF)
-          (replace (TEXTSTREAM FATSTREAMP) of STREAM with FATP)
-                                                             (* ; 
-                                   "Mark the stream, if it contains fat characters for this piece.")
-          (replace (STREAM BINABLE) of STREAM with (NOT FATP))
-                                                             (* ; 
-                                        "A stream that has fat chars can't use the micrododed BIN.")
-                                                             (* ; 
-                                                           "And return the next character in line")
-          (RETURN CH])
-
-(\TEDIT.TEXTBIN.NEW.PAGE
-  [LAMBDA (STREAM SPLITCHAR)                             (* ; "Edited 31-May-91 14:21 by jds")
-
-         (* * Handle crossing a file-page boundary within TEXTBIN)
-
-         (* If SPLITCHAR is non-NIL, we've already read the first byte of a two-byte 
-       character, and only need to read the second byte.
-       Otherwise, this function will read 2 bytes for a fat character.)
-
-    (PROG ((FILE (fetch (TEXTSTREAM REALFILE) of STREAM))
-           CH)                                               (* Get the STREAM which describes 
-                                                           the file for real)
-          [COND
-             ((IEQP (fetch (STREAM ACCESSBITS) of FILE)
-                    NoBits)                                  (* The file was closed for some 
-                                                           reason; reopen it.)
-              (SETQ FILE (\GETSTREAM (OPENFILE (fetch (STREAM FULLNAME) of FILE)
-                                            'INPUT)
-                                'INPUT]
-          (replace (STREAM COFFSET) of FILE with (fetch (STREAM CBUFSIZE)
-                                                                of FILE))
-                                                             (* Force it to do a page switch for 
-                                                           us)
-          (SETQ CH (\BIN FILE))                              (* Get the next character in the 
-                                                           usual manner)
-          (replace (STREAM CPPTR) of STREAM with (fetch (STREAM CPPTR) of FILE))
-                                                             (* Steal the fields we need to 
-                                                           simulate that stream)
-          (replace (STREAM COFFSET) of STREAM with (fetch (STREAM COFFSET)
-                                                                  of FILE))
-          (replace (STREAM CPAGE) of STREAM with (fetch (STREAM CPAGE) of FILE))
-          (replace (STREAM CBUFSIZE) of STREAM with (IMIN (fetch (TEXTSTREAM 
-                                                                                        CHARSLEFT)
-                                                                         of STREAM)
-                                                                      (fetch (STREAM CBUFSIZE)
-                                                                         of FILE)))
-                                                             (* Can't read farther than 
-                                                           end-of-piece, tho)
-          (replace (TEXTSTREAM CHARSLEFT) of STREAM with (IDIFFERENCE (fetch
-                                                                                   (TEXTSTREAM 
-                                                                                          CHARSLEFT)
-                                                                                     of STREAM)
-                                                                            (fetch (STREAM 
-                                                                                             CBUFSIZE
-                                                                                              )
-                                                                               of STREAM)))
-          (COND
-             [(AND (fetch (TEXTSTREAM FATSTREAMP) of STREAM)
-                   (NOT SPLITCHAR))
-
-         (* This piece contains fat characters. Need to grab a second byte from the 
-       file, and construct a 16-bit character)
-
-              (RETURN (LOGOR (UNFOLD CH 256)
-                             (\PAGEDBIN STREAM]
-             (T                                              (* Regular, 8-bit characters.
-                                                           Just return the one we BINned.)
-
-         (* or we only need the second byte, since the first byte was on the prior page.)
-
-                (RETURN CH])
-)
-(DEFINEQ
-
-(\TEXTPEEKBIN
-  [LAMBDA (STREAM NOERRORFLG)                            (* ; "Edited 28-Mar-94 15:34 by jds")
-                                                             (* ; "DO PEEKBIN for a text stream")
-    (PROG (CH FILE STR PF PS PC PO SUBSTREAM)
-          (SETQ PC (fetch (TEXTSTREAM PIECE) of STREAM))
-          (COND
-             [(ILESSP (fetch (STREAM COFFSET) of STREAM)
-                     (fetch (STREAM CBUFSIZE) of STREAM))
-                                                             (* ; 
-                                                         "Simple case -- just do the usual PEEKBIN")
-              (COND
-                 ((AND PC (fetch (PIECE POBJ) of PC))
-                  (RETURN (fetch (PIECE POBJ) of PC)))
-                 [(fetch (TEXTSTREAM FATSTREAMP) of STREAM)
-                                                             (* ; 
-                                                     "This is a 16 bit PEEKBIN.  Grab two chars...")
-                  (RETURN (COND
-                             [(\EOFP STREAM)
-                              (COND
-                                 (NOERRORFLG NIL)
-                                 (T (\PEEKBIN STREAM]
-                             ((ILESSP (fetch (STREAM COFFSET) of STREAM)
-                                     (SUB1 (fetch (STREAM CBUFSIZE) of STREAM)))
-                                                             (* ; 
-                                "We're sure of staying on the same page.  Just grab the characters")
-                              (PROG1 (LOGOR (UNFOLD (\PAGEDBIN STREAM)
-                                                   256)
-                                            (\PAGEDPEEKBIN STREAM NOERRORFLG))
-                                     (\PAGEDBACKFILEPTR STREAM)))
-                             (T (SETQ PS (fetch (STREAM F1) of STREAM))
-                                (replace (STREAM COFFSET) of PS with (fetch
-                                                                                  (STREAM COFFSET)
-                                                                                    of STREAM))
-                                (PROG1 (LOGOR (UNFOLD (\PAGEDBIN PS)
-                                                     256)
-                                              (\PAGEDPEEKBIN PS NOERRORFLG))
-                                       (\PAGEDBACKFILEPTR PS]
-                 (T (RETURN (\PAGEDPEEKBIN STREAM NOERRORFLG]
-             [PC                                             (* ; 
-                                       "We've either hit a page bound in a file, or a piece bound.")
-                 (RETURN (COND
-                            [(ZEROP (fetch (TEXTSTREAM CHARSLEFT) of STREAM))
-                                                             (* ; "Time for a new piece.")
-                             (SETQ PC (replace (TEXTSTREAM PIECE) of STREAM
-                                         with (fetch (PIECE NEXTPIECE) of PC)))
-                                                             (* ; 
-                                                           "Move to the next piece in the chain")
-                             (COND
-                                [PC (replace (TEXTSTREAM CURRENTLOOKS) of STREAM
-                                       with (\TEDIT.APPLY.STYLES (fetch (PIECE PLOOKS)
-                                                                        of PC)
-                                                       PC
-                                                       (fetch (TEXTSTREAM TEXTOBJ) of STREAM)
-                                                       ))
-                                    (COND
-                                       [(SETQ PO (fetch (PIECE POBJ) of PC))
-                                        (replace (STREAM BINABLE) of STREAM with NIL)
-                                        (freplace (STREAM CBUFSIZE) of STREAM
-                                           with (fetch (PIECE PLEN) of PC))
-                                        (freplace (STREAM COFFSET) of STREAM with 0)
-                                        (COND
-                                           (SUBSTREAM        (* ; 
-                                          "There is a stream below this one, to feed chars upward.")
-                                                  (\SETUPGETCH 1 (fetch (TEXTSTREAM TEXTOBJ)
-                                                                        of SUBSTREAM))
-                                                  (freplace (TEXTSTREAM CHARSLEFT) of STREAM
-                                                     with (fetch (PIECE PLEN) of PC))
-                                                  (freplace (STREAM CPAGE) of STREAM
-                                                     with 0)
-                                                  (freplace (TEXTSTREAM PCSTARTCH) of STREAM
-                                                     with 0)
-                                                  (freplace (TEXTSTREAM PCSTARTPG) of STREAM
-                                                     with 0)
-                                                  (replace (TEXTSTREAM CURRENTPARALOOKS)
-                                                     of STREAM with (fetch (TEXTSTREAM
-                                                                                        
-                                                                                     CURRENTPARALOOKS
-                                                                                        )
-                                                                               of SUBSTREAM))
-                                                  (replace (TEXTSTREAM CURRENTLOOKS) of
-                                                                                         STREAM
-                                                     with (fetch (TEXTSTREAM CURRENTLOOKS)
-                                                                 of SUBSTREAM))
-                                                  (RETURN (\BIN SUBSTREAM)))
-                                           (T (replace (TEXTSTREAM CHARSLEFT) of STREAM
-                                                 with 0)
-                                              (RETURN PO]
-                                       ((SETQ PS (fetch (PIECE PSTR) of PC))
-                                                             (* ; "This piece lives in a string.")
-                                        (\TEDIT.TEXTBIN.STRINGSETUP 0 (fetch (PIECE PLEN)
-                                                                             of PC)
-                                               STREAM PS)
-
-                                 (* ;; "Set the stream up so that it will use PS for BINs, starting at offset 0 (the front of the piece), and will run for as many chars as there are in the piece.")
-
-                                        (\PEEKBIN STREAM NOERRORFLG))
-                                       ((SETQ PF (fetch (PIECE PFILE) of PC))
-                                                             (* ; "This piece lives on a file.")
-                                        (\TEDIT.TEXTBIN.FILESETUP PC 0 (fetch (PIECE PLEN)
-                                                                              of PC)
-                                               STREAM PF (fetch (PIECE PFATP) of PC)
-                                               'PEEKBIN NOERRORFLG))
-                                       (T (ERROR "CAN'T GET TO NEXT PIECE"]
-                                (NOERRORFLG                  (* ; 
-                                                       "There are no more pieces.  Punt gracefully")
-                                       (RETURN NIL))
-                                (T                           (* ; "He wants it the hard way.")
-                                   (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM)
-                                          STREAM]
-                            (T                               (* ; 
-                                                         "Need to move to the next page in a file.")
-                               (RETURN (\TEDIT.PEEKBIN.NEW.PAGE STREAM NOERRORFLG]
-             (NOERRORFLG                                     (* ; 
-                                                       "There are no more pieces.  Punt gracefully")
-                    (RETURN NIL))
-             (T                                              (* ; "He wants it the hard way.")
-                (APPLY* (fetch (STREAM ENDOFSTREAMOP) of STREAM)
-                       STREAM])
-
-(\TEDIT.PEEKBIN.NEW.PAGE
-  [LAMBDA (STREAM NOERRORFLG)                            (* ; "Edited 31-May-91 14:21 by jds")
-
-         (* * Handle crossing a file-page boundary within \TEXTPEEKBIN)
-
-         (* If SPLITCHAR is non-NIL, we've already read the first byte of a two-byte 
-       character, and only need to read the second byte.
-       Otherwise, this function will read 2 bytes for a fat character.)
-
-    (PROG ((FILE (fetch (TEXTSTREAM REALFILE) of STREAM))
-           CH)                                               (* Get the STREAM which describes 
-                                                           the file for real)
-          [COND
-             ((IEQP (fetch (STREAM ACCESSBITS) of FILE)
-                    NoBits)                                  (* The file was closed for some 
-                                                           reason; reopen it.)
-              (SETQ FILE (\GETSTREAM (OPENFILE (fetch (STREAM FULLNAME) of FILE)
-                                            'INPUT)
-                                'INPUT]
-          (replace (STREAM COFFSET) of FILE with (fetch (STREAM CBUFSIZE)
-                                                                of FILE))
-                                                             (* Force it to do a page switch for 
-                                                           us)
-          [SETQ CH (COND
-                      [(\EOFP FILE)
-                       (COND
-                          (NOERRORFLG NIL)
-                          (T (\PEEKBIN FILE]
-                      ((fetch (TEXTSTREAM FATSTREAMP) of STREAM)
-                       (PROG1 (LOGOR (UNFOLD (\PAGEDBIN FILE)
-                                            256)
-                                     (\PAGEDPEEKBIN FILE NOERRORFLG))
-                              (\PAGEDBACKFILEPTR FILE)))
-                      (T (\PEEKBIN FILE NOERRORFLG]          (* Get the next character in the 
-                                                           usual manner)
-          (replace (STREAM CPPTR) of STREAM with (fetch (STREAM CPPTR) of FILE))
-                                                             (* Steal the fields we need to 
-                                                           simulate that stream)
-          (replace (STREAM COFFSET) of STREAM with (fetch (STREAM COFFSET)
-                                                                  of FILE))
-          (replace (STREAM CPAGE) of STREAM with (fetch (STREAM CPAGE) of FILE))
-          (replace (STREAM CBUFSIZE) of STREAM with (IMIN (fetch (TEXTSTREAM 
-                                                                                        CHARSLEFT)
-                                                                         of STREAM)
-                                                                      (fetch (STREAM CBUFSIZE)
-                                                                         of FILE)))
-                                                             (* Can't read farther than 
-                                                           end-of-piece, tho)
-          (replace (TEXTSTREAM CHARSLEFT) of STREAM with (IDIFFERENCE (fetch
-                                                                                   (TEXTSTREAM 
-                                                                                          CHARSLEFT)
-                                                                                     of STREAM)
-                                                                            (fetch (STREAM 
-                                                                                             CBUFSIZE
-                                                                                              )
-                                                                               of STREAM)))
-          (RETURN CH])
-)
-
-
-
-(* ; "Support for TEXTPROP")
-
-(DEFINEQ
-
-(CGETTEXTPROP
-  [LAMBDA (TEXTOBJ PROP)                                     (* ; "Edited 20-Oct-87 12:36 by jds")
-          
-          (* ;; "compiles calls on TEXTPROP that are fetching values.  This needs to be changed whenever GETTEXTPROP is changed.")
-
-    (SELECTQ PROP
-        ((READONLY READ-ONLY) 
-             `(fetch (TEXTOBJ TXTREADONLY) of ,TEXTOBJ))
-        `(LISTGET (fetch (TEXTOBJ EDITPROPS) of ,TEXTOBJ)
-                ',PROP])
-
-(CTEXTPROP
-  [LAMBDA (FORMTAIL)                                     (* ; "Edited 31-May-91 13:59 by jds")
-
-    (* ;; "compiles calls to TEXTPROP")
-
-    (COND
-       ((NULL (CDR FORMTAIL))                                (* ; "less that 2 args")
-        (printout T "Possible error in call to TEXTPROP: less than 2 args" T (LIST 'TEXTPROP FORMTAIL
-                                                                                   )
-               T)
-        (CGETTEXTPROP (LIST 'TEXTOBJ (CAR FORMTAIL))
-               NIL))
-       ((NOT (EQ (CAADR FORMTAIL)
-                 'QUOTE))                                    (* ; "property is not quoted.")
-        'IGNOREMACRO)
-       [(NULL (CDDR FORMTAIL))                               (* ; "fetching a TEXTPROP property.")
-        (CGETTEXTPROP (LIST 'TEXTOBJ (CAR FORMTAIL))
-               (CADR (CADR FORMTAIL]
-       (T                                                    (* ; "storing a window property")
-          (LET ((TEXTOBJ (CAR FORMTAIL))
-                (PROP (CDADR FORMTAIL))
-                (VAL (CADDR FORMTAIL)))
-               [SELECTQ PROP
-                   ((READONLY READ-ONLY) 
-                        `(REPLACE (TEXTOBJ TXTREADONLY) OF ,TEXTOBJ WITH ,VAL))
-                   `(COND
-                       [(FETCH (TEXTOBJ EDITPROPS) OF (TEXTOBJ ,TEXTOBJ))
-                        (LISTPUT (FETCH (TEXTOBJ EDITPROPS) OF (TEXTOBJ ,TEXTOBJ))
-                               ',PROP
-                               ',VAL]
-                       (T (REPLACE (TEXTOBJ EDITPROPS) OF (TEXTOBJ ,TEXTOBJ)
-                             WITH (LIST ,PROP ,VAL]
-               (LIST 'COND (LIST (LIST 'FETCH 'EDITPROPS 'OF (LIST 'TEXTOBJ (CAR FORMTAIL)))
-                                 (LIST 'LISTPUT (LIST 'FETCH 'EDITPROPS 'OF (LIST 'TEXTOBJ
-                                                                                  (CAR FORMTAIL)))
-                                       (CADR FORMTAIL)
-                                       (CADDR FORMTAIL)))
-                     (LIST T (LIST 'REPLACE 'EDITPROPS 'OF (LIST 'TEXTOBJ (CAR FORMTAIL))
-                                   'WITH
-                                   (LIST 'LIST (CADR FORMTAIL)
-                                         (CADDR FORMTAIL])
-
-(GETTEXTPROP
-  [LAMBDA (TEXTOBJ PROP)                                 (* ; "Edited  9-Feb-89 11:20 by jds")
-
-    (* ;; "Gets values for document properties.  Used by TEXTPROP.")
-
-    (SELECTQ PROP
-        ((READONLY READ-ONLY) 
-             (FETCH (TEXTOBJ TXTREADONLY) OF TEXTOBJ))
-        ((BEING-EDITED ACTIVE) 
-             (FETCH (TEXTOBJ TXTEDITING) OF TEXTOBJ))
-        ((NO-NS-CHARS NONSCHARS NO-NSCHARS) 
-             (FETCH (TEXTOBJ TXTNONSCHARS) OF TEXTOBJ))
-        (LISTGET (fetch (TEXTOBJ EDITPROPS) of TEXTOBJ)
-               PROP])
-
-(PUTTEXTPROP
-  [LAMBDA (TEXTOBJ PROP VALUE)                           (* ; "Edited  9-Feb-89 11:19 by jds")
-                                                             (* ; 
-                                                           "put a value on prop list for a textobj")
-    (SELECTQ PROP
-        ((READONLY READ-ONLY) 
-             (PROG1 (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)
-                 (replace (TEXTOBJ TXTREADONLY) of TEXTOBJ with VALUE)))
-        ((BEING-EDITED ACTIVE) 
-             (PROG1 (fetch (TEXTOBJ TXTEDITING) of TEXTOBJ)
-                 (replace (TEXTOBJ TXTEDITING) of TEXTOBJ with VALUE)))
-        ((NO-NS-CHARS NONSCHARS NO-NSCHARS) 
-             (PROG1 (fetch (TEXTOBJ TXTNONSCHARS) of TEXTOBJ)
-                 (replace (TEXTOBJ TXTNONSCHARS) of TEXTOBJ with VALUE)))
-        (COND
-           ((fetch (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ))
-            (PROG1 (LISTGET (ffetch (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ))
-                          PROP)
-                (LISTPUT (ffetch (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ))
-                       PROP VALUE)))
-           (T (freplace (TEXTOBJ EDITPROPS) of (TEXTOBJ TEXTOBJ) with (LIST PROP VALUE))
-              NIL])
-
-(TEXTPROP
-  [LAMBDA X                                              (* ; "Edited  9-Feb-89 11:20 by jds")
-
-    (* ;; "general top level entry for both fetching and setting window properties.")
-
-    (COND
-       ((IGREATERP X 2)
-        (PUTTEXTPROP (TEXTOBJ (ARG X 1))
-               (ARG X 2)
-               (ARG X 3)))
-       ((EQ X 2)
-        (GETTEXTPROP (TEXTOBJ (ARG X 1))
-               (ARG X 2)))
-       (T (\ILLEGAL.ARG NIL])
-)
-
-
-
-(* ;; 
-"Support for error handling:  The old error handler for the stream-not-open error.  This is here, because you only want to do this ONCE, even if you load TEXTOFD multiple times (as, e.g., in development)"
-)
-
-
-(RPAQ? *TEDIT-OLD-STREAM-ERROR-HANDLER* (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN))
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(\TEXTINIT)
-)
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA )
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA TEXTPROP)
-)
-(PUTPROPS TEXTOFD COPYRIGHT ("John Sybalsky & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 
-1990 1991 1993 1994 1995))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (3000 52200 (COPYTEXTSTREAM 3010 . 6076) (OPENTEXTSTREAM 6078 . 20955) (REOPENTEXTSTREAM
- 20957 . 21379) (TEDIT.STREAMCHANGEDP 21381 . 21679) (TEXTSTREAMP 21681 . 21995) (TXTFILE 21997 . 
-22442) (\DELETECH 22444 . 33252) (\SETUPGETCH 33254 . 40533) (\TEDIT.REOPEN.STREAM 40535 . 42045) (
-\TEDIT.COPYTEXTSTREAM.PIECEMAPFN 42047 . 44485) (\TEXTINIT 44487 . 50093) (\TEXTMARK 50095 . 50843) (
-\TEXTTTYBOUT 50845 . 52198)) (52201 77694 (\INSERTCH 52211 . 75998) (\INSERTCR 76000 . 77692)) (77760 
-97944 (\CHTOPC 77770 . 78959) (\CHTOPCNO 78961 . 80223) (\CLEARPCTB 80225 . 81021) (
-\CREATEPIECEORSTREAM 81023 . 83865) (\DELETEPIECE 83867 . 84780) (\FINDPIECE 84782 . 85148) (
-\INSERTPIECE 85150 . 88160) (\MAKEPCTB 88162 . 90077) (\SPLITPIECE 90079 . 97038) (\INSERT.FIRST.PIECE
- 97040 . 97942)) (97996 121422 (\TEXTCLOSEF 98006 . 99233) (\TEXTCLOSEF-SUBTREE 99235 . 99941) (
-\TEXTDSPFONT 99943 . 100935) (\TEXTEOFP 100937 . 102296) (\TEXTGETEOFPTR 102298 . 102508) (
-\TEXTGETFILEPTR 102510 . 104573) (\TEXTOPENF 104575 . 105405) (\TEXTOPENF-SUBTREE 105407 . 106208) (
-\TEXTOUTCHARFN 106210 . 106558) (\TEXTBACKFILEPTR 106560 . 112461) (\TEXTBOUT 112463 . 115811) (
-\TEDITOUTCHARFN 115813 . 117059) (\TEXTSETEOF 117061 . 117570) (\TEXTSETFILEPTR 117572 . 118797) (
-\TEXTDSPXPOSITION 118799 . 119250) (\TEXTDSPYPOSITION 119252 . 119797) (\TEXTLEFTMARGIN 119799 . 
-120282) (\TEXTRIGHTMARGIN 120284 . 121120) (\TEXTDSPCHARWIDTH 121122 . 121218) (\TEXTDSPSTRINGWIDTH 
-121220 . 121316) (\TEXTDSPLINEFEED 121318 . 121420)) (121423 153726 (\TEXTBIN 121433 . 138219) (
-\TEDIT.TEXTBIN.STRINGSETUP 138221 . 143934) (\TEDIT.TEXTBIN.FILESETUP 143936 . 149438) (
-\TEDIT.TEXTBIN.NEW.PAGE 149440 . 153724)) (153727 167010 (\TEXTPEEKBIN 153737 . 162876) (
-\TEDIT.PEEKBIN.NEW.PAGE 162878 . 167008)) (167048 172266 (CGETTEXTPROP 167058 . 167534) (CTEXTPROP 
-167536 . 169880) (GETTEXTPROP 169882 . 170477) (PUTTEXTPROP 170479 . 171804) (TEXTPROP 171806 . 172264
-)))))
-STOP
diff --git a/obsolete/library/new/TEXTOFD.LCOM b/obsolete/library/new/TEXTOFD.LCOM
deleted file mode 100644
index 563ba393..00000000
Binary files a/obsolete/library/new/TEXTOFD.LCOM and /dev/null differ
diff --git a/obsolete/library/patches/NEW-SKETCH-COLOR b/obsolete/library/patches/NEW-SKETCH-COLOR
deleted file mode 100644
index 794a62e0..00000000
--- a/obsolete/library/patches/NEW-SKETCH-COLOR
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "23-Jul-90 18:28:51" {DSK}<home>peach>matsuda>NEW-SKETCH-COLOR.;2 32679  

      previous date%: "23-Jul-90 17:49:19" {DSK}<home>peach>matsuda>NEW-SKETCH-COLOR.;1)


(* ; "
Copyright (c) 1990 by Fuji Xerox Co., Ltd.  All rights reserved.
")

(PRETTYCOMPRINT NEW-SKETCH-COLORCOMS)

(RPAQQ NEW-SKETCH-COLORCOMS 
       [(P (MOVD 'CIRCLE.DRAWFN 'ORG.CIRCLE.DRAWFN)
           (MOVD 'CLOSED.WIRE.DRAWFN 'ORG.CLOSED.WIRE.DRAWFN)
           (MOVD 'BOX.DRAWFN1 'ORG.BOX.DRAWFN1)
           (SETQ SKETCHINCOLORFLG T))
        (FNS \BBTCURVEPT BMOBJ.DISPLAYFN BITMAPOBJ.SNAPW OPPOSITECOLOR \SCALEDBITBLT.DISPLAY 
             BITMAPELT.INPUTFN GET.BITMAP.POSITION BOX.DRAWFN1 CIRCLE.DRAWFN CLOSED.WIRE.DRAWFN 
             SKETCHINCOLORP NEW.READCOLOR1 SK.FIGUREIMAGE)
        (P (MOVD 'READCOLOR1 'ORG.READCOLOR1)
           (MOVD 'NEW.READCOLOR1 'READCOLOR1)
           (REPLACE (IMAGEOPS IMFILLPOLYGON)
                  OF \8DISPLAYIMAGEOPS WITH (FUNCTION POLYSHADE.DISPLAY))
           (REPLACE (IMAGEOPS IMSCALEDBITBLT)
                  OF \8DISPLAYIMAGEOPS WITH (FUNCTION \SCALEDBITBLT.DISPLAY])

(MOVD 'CIRCLE.DRAWFN 'ORG.CIRCLE.DRAWFN)

(MOVD 'CLOSED.WIRE.DRAWFN 'ORG.CLOSED.WIRE.DRAWFN)

(MOVD 'BOX.DRAWFN1 'ORG.BOX.DRAWFN1)

(SETQ SKETCHINCOLORFLG T)
(DEFINEQ

(\BBTCURVEPT
  [LAMBDA (X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 NBITSRIGHTPLUS1 TOPMINUSBRUSH 
             DestinationBitMap BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH
             BRUSHRASTERWIDTH COLORBRUSHBASE NBITS DISPLAYDATA)
                                                           (* ; "Edited 24-May-90 10:03 by matsuda")

    (* ;; "Called by \CURVEPT macro.  Draws a brush point by bitblting BRUSHBM to point X,Y in DestinationBitMap.  BBT is a BitBlt table where everything is already set except the source and destination addresses, width and height.  In other words, only the easy stuff")
                                                             (* ; "set the width fields of the bbt")
    [PROG (CLIPPEDTOP STY)
          [COND
             [(ILEQ Y TOPMINUSBRUSH)                         (* ; 
                                                           "the top part of the brush is visible")
              (SETQ CLIPPEDTOP (IPLUS Y BRUSHHEIGHT))
              (replace PBTSOURCE of BBT with BRUSHBASE)
              (freplace PBTHEIGHT of BBT with (IMIN BRUSHHEIGHT (IDIFFERENCE Y 
                                                                                   BOTTOMMINUSBRUSH]
             (T                                              (* ; "only the bottom is visible")
                (SETQ CLIPPEDTOP TOP)
                [replace PBTSOURCE of BBT with (\ADDBASE BRUSHBASE
                                                                  (ITIMES BRUSHRASTERWIDTH
                                                                         (SETQ STY (IDIFFERENCE
                                                                                    Y TOPMINUSBRUSH]
                (freplace PBTHEIGHT of BBT with (IDIFFERENCE (IMIN BRUSHHEIGHT
                                                                               (IDIFFERENCE Y 
                                                                                     BOTTOMMINUSBRUSH
                                                                                      ))
                                                                   STY]
          (freplace PBTDEST of BBT with (\ADDBASE DESTINATIONBASE (ITIMES RASTERWIDTH
                                                                                     (\SFInvert
                                                                                      
                                                                                    DestinationBitMap
                                                                                      CLIPPEDTOP]
    [COND
       (COLORBRUSHBASE [COND
                          [(ILESSP X LEFT)                   (* ; 
                                                      "only the right part of the brush is visible")
                                                             (* ; 
                                                           "FOR NOW BRUTE FORCE WITH NBITS CHECK")
                           [freplace PBTDESTBIT of BBT with (COND
                                                                           ((EQ NBITS 4)
                                                                            (LLSH LEFT 2))
                                                                           (T (LLSH LEFT 3]
                           (freplace PBTSOURCEBIT of BBT
                              with (IDIFFERENCE BRUSHWIDTH
                                              (freplace PBTWIDTH of BBT
                                                 with (COND
                                                             ((EQ NBITS 4)
                                                              (LLSH (IDIFFERENCE X LEFTMINUSBRUSH)
                                                                    2))
                                                             (T (LLSH (IDIFFERENCE X LEFTMINUSBRUSH)
                                                                      3]
                          (T                                 (* ; "left edge is visible")
                             [freplace PBTDESTBIT of BBT with (SETQ X
                                                                           (COND
                                                                              ((EQ NBITS 4)
                                                                               (LLSH X 2))
                                                                              (T (LLSH X 3]
                             (freplace PBTSOURCEBIT of BBT with 0)
                                                             (* ; 
                                                          "set width to the amount that is visible")
                             (freplace PBTWIDTH of BBT with (IMIN BRUSHWIDTH
                                                                              (IDIFFERENCE 
                                                                                     NBITSRIGHTPLUS1
                                                                                     X]
              (COND
                 ((NEQ (ffetch DDOPERATION of DISPLAYDATA)
                       'INVERT)                              (* ; 
                   "if color brush is used, the ground must be cleared before the brush is put in.")
                  (\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA)
                         'ERASE)
                  (\PILOTBITBLT BBT 0)                       (* ; 
                                                   "reset the source to point to the color bitmap.")
                  ))
              [COND
                 ((ILEQ Y TOPMINUSBRUSH)                     (* ; 
                                                           "the top part of the brush is visible")
                  (freplace PBTSOURCE of BBT with COLORBRUSHBASE))
                 (T                                          (* ; "only the bottom is visible")
                    (freplace PBTSOURCE of BBT with (\ADDBASE COLORBRUSHBASE
                                                                       (ITIMES BRUSHRASTERWIDTH
                                                                              (IDIFFERENCE Y 
                                                                                     TOPMINUSBRUSH]
              (\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA)
                     (ffetch DDOPERATION of DISPLAYDATA)))
       (T (COND
             [(ILESSP X LEFT)                                (* ; 
                                                      "only the right part of the brush is visible")
              (freplace PBTDESTBIT of BBT with LEFT)
              (freplace PBTSOURCEBIT of BBT with (IDIFFERENCE BRUSHWIDTH
                                                                    (freplace PBTWIDTH
                                                                       of BBT
                                                                       with (IDIFFERENCE X 
                                                                                       LEFTMINUSBRUSH
                                                                                       ]
             (T                                              (* ; "left edge is visible")
                (freplace PBTDESTBIT of BBT with X)
                (freplace PBTSOURCEBIT of BBT with 0)
                                                             (* ; 
                                                          "set width to the amount that is visible")
                (freplace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE RIGHTPLUS1 X
                                                                                   ]
    (\PILOTBITBLT BBT 0])

(BMOBJ.DISPLAYFN
  [LAMBDA (IMAGEOBJ IMAGE.STREAM)                      (* ; "Edited 18-Apr-90 16:28 by matsuda")

    (* ;; "Display a bitmap IMAGEOBJ on IMAGE.STREAM.  Scales and rotates it if appropriate, and moves it down by DESCENT.")

    (PROG ([FACTOR (fetch (BITMAPOBJ BMOBJSCALEFACTOR) of (IMAGEOBJPROP IMAGEOBJ 
                                                                         'OBJECTDATUM]
           [BITMAP (fetch (BITMAPOBJ BITMAP) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]
           (CACHE (IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP))
           [DESCENT (fetch (BITMAPOBJ BMOBJDESCENT) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]
           (STREAM-SCALE (DSPSCALE NIL IMAGE.STREAM))
           SHRUNK.BITMAP)
          (RELMOVETO 0 [IMINUS (FIXR (FTIMES STREAM-SCALE (OR DESCENT 0]
                 IMAGE.STREAM)
          (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM)
              (INTERPRESS 
                          (* ;; "Printing to an Interpress stream, so use the specialized method.")

                          (SHOWBITMAP.IP IMAGE.STREAM BITMAP NIL FACTOR 0))
              ((DISPLAY PRESS) 
                               (* ;; 
         "This is the default case, press display and everyone else prints the junky shrunk bitmap")

                   (COND
                      ((NOT (SETQ SHRUNK.BITMAP CACHE))
                       [COND
                          [(LEQ FACTOR 1.0)                  (* ; 
                                   "We're shrinking the bitmap.  Create a shrunk image for display")
                           (SETQ SHRUNK.BITMAP (SHRINKBITMAP BITMAP (FQUOTIENT 1.0 FACTOR)
                                                      (FQUOTIENT 1.0 FACTOR]
                          (T                                 (* ; 
                                                        "We're expanding it.  Create a bigger one.")
                             (SETQ SHRUNK.BITMAP (EXPANDBITMAP BITMAP FACTOR FACTOR]
                       (IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP SHRUNK.BITMAP)))
                   [BITBLT SHRUNK.BITMAP NIL NIL IMAGE.STREAM (DSPXPOSITION NIL IMAGE.STREAM)
                          (DSPYPOSITION NIL IMAGE.STREAM)
                          (FIXR (FTIMES FACTOR (BITMAPWIDTH BITMAP)))
                          (FIXR (FTIMES FACTOR (BITMAPHEIGHT BITMAP])
              (PROGN 
                     (* ;; "This is the default case--Call SCALEDBITBLT")

                     (SCALEDBITBLT BITMAP 0 0 IMAGE.STREAM (DSPXPOSITION NIL IMAGE.STREAM)
                            (DSPYPOSITION NIL IMAGE.STREAM)
                            (BITMAPWIDTH BITMAP)
                            (BITMAPHEIGHT BITMAP)
                            'INPUT
                            'PAINT NIL NIL FACTOR])

(BITMAPOBJ.SNAPW
  [LAMBDA NIL                                          (* ; "Edited 12-Apr-90 09:09 by matsuda")

         (* * makes an image object of a prompted for region of the screen.)

    (PROG ((REG (GETREGION))
           BM)
          [SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REG)
                          (fetch (REGION HEIGHT) of REG)
                          (BITSPERPIXEL (SCREENBITMAP \CURSORSCREEN]
          (BITBLT (SCREENBITMAP \CURSORSCREEN)
                 (fetch (REGION LEFT) of REG)
                 (fetch (REGION BOTTOM) of REG)
                 BM 0 0 NIL NIL 'INPUT 'REPLACE)
          (COPYINSERT (BITMAPTEDITOBJ BM 1 0))
          (RETURN])

(OPPOSITECOLOR
  [LAMBDA (COLOR BITSPERPIXEL)                         (* ; "Edited 23-May-90 15:05 by matsuda")
    (IDIFFERENCE (MAXIMUMCOLOR BITSPERPIXEL)
           (COLORNUMBERP COLOR BITSPERPIXEL])

(\SCALEDBITBLT.DISPLAY
  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH 
                 HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
                 CLIPPEDSOURCEBOTTOM SCALE)            (* ; "Edited 22-May-90 15:02 by matsuda")
    (LET (BITMAP REGION)
         (IF (NULL SCALE)
             THEN (SETQ SCALE 1))
         (IF (WINDOWP SOURCEBITMAP)
             THEN (SETQ REGION (DSPCLIPPINGREGION NIL SOURCEBITMAP))
                   (IF (NULL WIDTH)
                       THEN (SETQ WIDTH (FETCH (REGION WIDTH) OF REGION)))
                   (IF (NULL HEIGHT)
                       THEN (SETQ HEIGHT (FETCH (REGION HEIGHT) OF REGION)))
           ELSEIF (BITMAPP SOURCEBITMAP)
             THEN (IF (NULL WIDTH)
                          THEN (SETQ WIDTH (BITMAPWIDTH SOURCEBITMAP)))
                   (IF (NULL HEIGHT)
                       THEN (SETQ HEIGHT (BITMAPHEIGHT SOURCEBITMAP)))
           ELSE (SHOULDNT))
         (SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT (FETCH SCBITSPERPIXEL OF \CURSORSCREEN)))
         (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM BITMAP)
         (BITBLT (EXPANDBITMAP BITMAP SCALE SCALE)
                NIL NIL DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM (TIMES WIDTH SCALE)
                (TIMES HEIGHT SCALE)
                SOURCETYPE OPERATION TEXTURE CLIPPINGREGION])

(BITMAPELT.INPUTFN
  [LAMBDA (WINDOW)                                     (* ; "Edited 22-May-90 12:56 by matsuda")
                                                             (* gets a region of the screen and 
                                                           makes it a scalable bitmap.)
    (PROG ((REGION (GETREGION 4 4))
           BM POS)
          (OR (REGIONP REGION)
              (RETURN))
          (SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REGION)
                          (fetch (REGION HEIGHT) of REGION)
                          (FETCH SCBITSPERPIXEL OF \CURSORSCREEN)))
          (BITBLT (SCREENBITMAP \CURSORSCREEN)
                 (fetch (REGION LEFT) of REGION)
                 (fetch (REGION BOTTOM) of REGION)
                 BM 0 0 (fetch (REGION WIDTH) of REGION)
                 (fetch (REGION HEIGHT) of REGION))
          (OR (SETQ POS (GET.BITMAP.POSITION WINDOW BM NIL "Place the bitmap image."))
              (RETURN))
          (RETURN (SK.BITMAP.CREATE BM (SK.MAP.INPUT.PT.TO.GLOBAL POS WINDOW)
                         (VIEWER.SCALE WINDOW])

(GET.BITMAP.POSITION
  [LAMBDA (WINDOW BITMAP OPERATION MSG XOFFSET YOFFSET)(* ; "Edited 22-May-90 12:53 by matsuda")

         (* gets a position by tracking with a bitmap The spec returns is actually
       (ONGRID? position) so that caller can tell whether it was placed on grid or 
       not.)

    (PROG (BUFFER.BITMAP WIDTH HEIGHT)
          (SETQ WIDTH (BITMAPWIDTH BITMAP))
          (SETQ HEIGHT (BITMAPHEIGHT BITMAP))
          (SETQ BUFFER.BITMAP (BITMAPCREATE WIDTH HEIGHT (FETCH SCBITSPERPIXEL OF 
                                                                                        \CURSORSCREEN
                                                                )))
          (STATUSPRINT WINDOW "
" MSG)
          (RETURN (SK.TRACK.BITMAP1 WINDOW BITMAP BUFFER.BITMAP WIDTH HEIGHT (OR OPERATION
                                                                                 'PAINT)
                         XOFFSET YOFFSET])

(BOX.DRAWFN1
  [LAMBDA (REG SIZE WIN WINREG OPERATION DASHING TEXTURE OUTLINECOLOR FILLINGCOLOR)
                                                           (* ; "Edited 25-May-90 14:18 by matsuda")
                                                             (* draws a box. Used by both box and 
                                                           text box elements.)
    (COND
       ((OR (NULL WINREG)
            (REGIONSINTERSECTP WINREG REG))
        (COND
           ((AND (SKETCHINCOLORP)
                 (OR FILLINGCOLOR TEXTURE))                  (* call the filling routine that 
                                                           does color.)
            (FILLPOLYGON (KNOTS.OF.REGION REG SIZE)
                   FILLINGCOLOR WIN))
           (TEXTURE (DSPFILL REG (COND
                                    ((EQ (DSPOPERATION NIL WIN)
                                         'ERASE)             (* use black in case the window 
                                                           moved because of texture to window 
                                                           alignment bug.)
                                     BLACKSHADE)
                                    (T TEXTURE))
                           (SK.TRANSLATE.MODE OPERATION WIN)
                           WIN))
           (FILLINGCOLOR                                     (* if no texture, use the color.)
                  (DSPFILL REG (TEXTUREOFCOLOR FILLINGCOLOR)
                         OPERATION WIN)))

         (* code to fix white space bug in Interpress.
       It works but Masters are larger and the one I tried wouldn't print.
       (SELECTQ (IMAGESTREAMTYPE WIN) ((NIL DISPLAY PRESS)
       (* special case DISPLAY for speed and PRESS because rounded corners don't work 
       for large brushes.) (SK.DRAWAREABOX (fetch
       (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG)
       (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG) SIZE OPERATION WIN 
       DASHING OUTLINECOLOR)) (PROG ((LFT (fetch
       (REGION LEFT) of REG)) (BTM (fetch (REGION BOTTOM) of REG))
       (TOP (fetch (REGION TOP) of REG)) (RGHT
       (fetch (REGION RIGHT) of REG))) (DRAWCURVE
       (LIST (CREATEPOSITION LFT BTM) (CREATEPOSITION LFT TOP)
       (CREATEPOSITION RIGHT TOP) (CREATEPOSITION RIGHT BTM)) T
       (create BRUSH BRUSHSHAPE _ (QUOTE ROUND) BRUSHSIZE _ SIZE BRUSHCOLOR _ 
       OUTLINECOLOR) DASHING WIN))))

        (SK.DRAWAREABOX (fetch (REGION LEFT) of REG)
               (fetch (REGION BOTTOM) of REG)
               (fetch (REGION WIDTH) of REG)
               (fetch (REGION HEIGHT) of REG)
               SIZE
               (SK.TRANSLATE.MODE OPERATION WIN)
               WIN DASHING OUTLINECOLOR])

(CIRCLE.DRAWFN
  [LAMBDA (CIRCLEELT WINDOW REGION)                    (* ; "Edited 25-May-90 15:36 by matsuda")
                                                             (* draws a circle from a circle 
                                                           element.)
    (PROG ((GCIRCLE (fetch (SCREENELT INDIVIDUALGLOBALPART) of CIRCLEELT))
           (LCIRCLE (fetch (SCREENELT LOCALPART) of CIRCLEELT))
           CPOS DASHING FILLING)
          (SETQ CPOS (fetch (LOCALCIRCLE CENTERPOSITION) of LCIRCLE))
          (SETQ DASHING (fetch (LOCALCIRCLE LOCALCIRCLEDASHING) of LCIRCLE))
          (SETQ FILLING (fetch (LOCALCIRCLE LOCALCIRCLEFILLING) of LCIRCLE))
          (COND
             ((fetch (SKFILLING FILLING.COLOR) of FILLING)

         (* if the circle is filled with a color call FILLCIRCLE with both the texture 
       and the color. This allows iris to do its thing before textures and colors are 
       merged.)

              (DSPOPERATION (PROG1 (DSPOPERATION (fetch (SKFILLING FILLING.OPERATION)
                                                    of FILLING)
                                          WINDOW)
                                (FILLCIRCLE (fetch (POSITION XCOORD) of CPOS)
                                       (fetch (POSITION YCOORD) of CPOS)
                                       (fetch (LOCALCIRCLE RADIUS) of LCIRCLE)
                                       (fetch (SKFILLING FILLING.COLOR) of FILLING)
                                       WINDOW))
                     WINDOW))
             ((fetch (SKFILLING FILLING.TEXTURE) of FILLING)
                                                             (* if the circle is filled with 
                                                           texture, call FILLCIRCLE.)
              (DSPOPERATION (PROG1 (DSPOPERATION (fetch (SKFILLING FILLING.OPERATION)
                                                    of FILLING)
                                          WINDOW)
                                (FILLCIRCLE (fetch (POSITION XCOORD) of CPOS)
                                       (fetch (POSITION YCOORD) of CPOS)
                                       (fetch (LOCALCIRCLE RADIUS) of LCIRCLE)
                                       (COND
                                          ((EQ (DSPOPERATION NIL WINDOW)
                                               'ERASE)       (* use black in case the window 
                                                           moved because of texture to window 
                                                           alignment bug.)
                                           BLACKSHADE)
                                          (T (fetch (SKFILLING FILLING.TEXTURE) of FILLING)))
                                       WINDOW))
                     WINDOW)))
          (RETURN (\CIRCLE.DRAWFN1 CPOS (fetch (LOCALCIRCLE RADIUSPOSITION) of LCIRCLE)
                         (fetch (LOCALCIRCLE RADIUS) of LCIRCLE)
                         (fetch (LOCALCIRCLE LOCALCIRCLEBRUSH) of LCIRCLE)
                         DASHING WINDOW])

(CLOSED.WIRE.DRAWFN
  [LAMBDA (CLOSEDWIREELT WIN REG OPERATION)            (* ; "Edited 25-May-90 15:26 by matsuda")
                                                             (* draws a closed wire element.)
    (PROG ((GINDVELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of CLOSEDWIREELT))
           (LOCALPART (fetch (SCREENELT LOCALPART) of CLOSEDWIREELT))
           VARX)
          (SETQ VARX (fetch (LOCALCLOSEDWIRE LOCALCLOSEDWIREFILLING) of LOCALPART))
          [COND
             ((OR (fetch (SKFILLING FILLING.TEXTURE) of VARX)
                  (fetch (SKFILLING FILLING.COLOR) of VARX))
                                                             (* if there isn't any filling, don't 
                                                           fill.)
              (FILLPOLYGON (fetch (LOCALCLOSEDWIRE KNOTS) of LOCALPART)
                     [COND
                        ((fetch (SKFILLING FILLING.COLOR) of VARX))
                        ((SKETCHINCOLORP)
                         VARX)
                        (T                                   (* simulate color)
                           (TEXTUREOFCOLOR (fetch (SKFILLING FILLING.COLOR) of VARX]
                     WIN
                     (COND
                        ((EQ (DSPOPERATION NIL WIN)
                             'ERASE)                         (* if the stream is erasing, erase.)
                         'ERASE)
                        (T                                   (* otherwise use the element's mode.)
                           (fetch (SKFILLING FILLING.OPERATION) of VARX]
          (OR (EQ (fetch (BRUSH BRUSHSIZE) of (SETQ VARX (fetch (LOCALCLOSEDWIRE 
                                                                                 LOCALCLOSEDWIREBRUSH
                                                                                   ) of LOCALPART
                                                                        )))
                  0)
              (WB.DRAWLINE CLOSEDWIREELT WIN REG OPERATION T (fetch (CLOSEDWIRE CLOSEDWIREDASHING
                                                                               ) of GINDVELT)
                     VARX])

(SKETCHINCOLORP
  [LAMBDA NIL                                          (* ; "Edited 25-May-90 14:00 by matsuda")
                                                             (* hook to determine if sketch 
                                                           should allow color.)
    (AND SKETCHINCOLORFLG (IGREATERP (FETCH SCBITSPERPIXEL OF \CURSORSCREEN)
                                 1])

(NEW.READCOLOR1
  [LAMBDA (MSG ALLOWNONEFLG NOWCOLOR)                  (* ; "Edited 25-May-90 10:05 by matsuda")
    (LET ((INITCOLOR (AND NOWCOLOR (INSURE.RGB.COLOR NOWCOLOR T)))
          COLORINDEX)
         (SETQ COLORINDEX (PAINTW.READBRUSHTEXTURE))
         (COND
            ((NULL COLORINDEX)
             INITCOLOR)
            ((INSURE.RGB.COLOR (ELT (SCREENCOLORMAP NIL)
                                    COLORINDEX)))
            (T INITCOLOR])

(SK.FIGUREIMAGE
  [LAMBDA (SCRITEMS LIMITREGION REGIONOFINTEREST)      (* ; "Edited 22-May-90 13:23 by matsuda")

         (* returns a bitmap which contains the image of the elements on SCRITEMS.
       And a lower left corner.)

    (RESETFORM (CURSOR WAITINGCURSOR)
           (PROG (REGION DSPSTREAM BITMAP LEFT BOTTOM LIMITDIM)
                 (COND
                    ((NULL SCRITEMS)
                     (RETURN)))
                 [COND
                    ((SCREENELEMENTP SCRITEMS)               (* single item case.)
                     (SETQ REGION (SK.ITEM.REGION SCRITEMS)))
                    (T (SETQ REGION (SK.ITEM.REGION (CAR SCRITEMS)))
                       [for SCITEM in (CDR SCRITEMS) do (SETQ REGION (SK.UNIONREGIONS
                                                                                  REGION
                                                                                  (SK.ITEM.REGION
                                                                                   SCITEM]
                                                             (* order the elements by priority)
                       (SETQ SCRITEMS (REVERSE (SK.SORT.ELTS.BY.PRIORITY SCRITEMS]
                                                             (* only some of the points are being 
                                                           moved, reduce the region to those.)
                 (AND REGIONOFINTEREST (SETQ REGION (OR (INTERSECTREGIONS REGION REGIONOFINTEREST)
                                                        REGION)))
                 [COND
                    (LIMITREGION 

         (* limit the size of the bitmap. This is used by copy insert functions that do 
       not know how big the thing coming in is.)

                           (COND
                              ((GREATERP (fetch (REGION WIDTH) of REGION)
                                      (SETQ LIMITDIM (fetch (REGION WIDTH) of LIMITREGION)))
                                                             (* reduce the width picking out the 
                                                           middle of the region)
                               (replace (REGION LEFT) of REGION
                                  with (PLUS (fetch (REGION LEFT) of REGION)
                                                 (QUOTIENT (DIFFERENCE LIMITDIM (fetch
                                                                                 (REGION WIDTH)
                                                                                   of REGION))
                                                        2)))
                               (replace (REGION WIDTH) of REGION with LIMITDIM)))
                           (COND
                              ((GREATERP (fetch (REGION HEIGHT) of REGION)
                                      (SETQ LIMITDIM (fetch (REGION HEIGHT) of LIMITREGION)))
                                                             (* reduce the height picking out the 
                                                           middle of the region)
                               (replace (REGION BOTTOM) of REGION
                                  with (PLUS (fetch (REGION BOTTOM) of REGION)
                                                 (QUOTIENT (DIFFERENCE LIMITDIM (fetch
                                                                                 (REGION HEIGHT)
                                                                                   of REGION))
                                                        2)))
                               (replace (REGION HEIGHT) of REGION with LIMITDIM]
                                                             (* ADD1 is used to convert the 
                                                           possibly floating region coordinates 
                                                           into fixed.)
                 [SETQ DSPSTREAM (DSPCREATE (SETQ BITMAP (BITMAPCREATE (ADD1 (fetch (REGION
                                                                                         WIDTH)
                                                                                of REGION))
                                                                (ADD1 (fetch (REGION HEIGHT)
                                                                         of REGION))
                                                                (FETCH SCBITSPERPIXEL
                                                                   OF \CURSORSCREEN]
                 (DSPXOFFSET [IMINUS (SETQ LEFT (FIXR (fetch (REGION LEFT) of REGION]
                        DSPSTREAM)
                 (DSPYOFFSET [IMINUS (SETQ BOTTOM (FIXR (fetch (REGION BOTTOM) of REGION]
                        DSPSTREAM)

         (* this is because the default clipping region is smaller than the clipping 
       region of the figure in extreme cases.)

                 (DSPCLIPPINGREGION REGION DSPSTREAM)
                 (DSPOPERATION 'PAINT DSPSTREAM)             (* to avoid carriage returns.)
                 (DSPRIGHTMARGIN (PLUS 100 (fetch (REGION RIGHT) of REGION))
                        DSPSTREAM)
                 (DRAW.LOCAL.SKETCH SCRITEMS DSPSTREAM REGION)
                 (RETURN (create SKFIGUREIMAGE
                                SKFIGURE.LOWERLEFT _ (create POSITION
                                                            XCOORD _ LEFT
                                                            YCOORD _ BOTTOM)
                                SKFIGURE.BITMAP _ BITMAP])
)

(MOVD 'READCOLOR1 'ORG.READCOLOR1)

(MOVD 'NEW.READCOLOR1 'READCOLOR1)

(REPLACE (IMAGEOPS IMFILLPOLYGON) OF \8DISPLAYIMAGEOPS WITH (FUNCTION POLYSHADE.DISPLAY))

(REPLACE (IMAGEOPS IMSCALEDBITBLT) OF \8DISPLAYIMAGEOPS WITH (FUNCTION 
                                                                          \SCALEDBITBLT.DISPLAY))
(PUTPROPS NEW-SKETCH-COLOR COPYRIGHT ("Fuji Xerox Co., Ltd" 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1340 32231 (\BBTCURVEPT 1350 . 9560) (BMOBJ.DISPLAYFN 9562 . 12391) (BITMAPOBJ.SNAPW 
12393 . 13123) (OPPOSITECOLOR 13125 . 13339) (\SCALEDBITBLT.DISPLAY 13341 . 14836) (BITMAPELT.INPUTFN 
14838 . 16015) (GET.BITMAP.POSITION 16017 . 16992) (BOX.DRAWFN1 16994 . 19884) (CIRCLE.DRAWFN 19886 . 
23179) (CLOSED.WIRE.DRAWFN 23181 . 25493) (SKETCHINCOLORP 25495 . 25922) (NEW.READCOLOR1 25924 . 26394
) (SK.FIGUREIMAGE 26396 . 32229)))))
STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/ARCHIVEBROWSER b/obsolete/lispusers/ARCHIVEBROWSER
deleted file mode 100644
index c4554d8f..00000000
--- a/obsolete/lispusers/ARCHIVEBROWSER
+++ /dev/null
@@ -1,506 +0,0 @@
-(FILECREATED " 4-Mar-87 17:04:08" {PHYLUM}<LISPUSERS>KOTO>ARCHIVEBROWSER.;3 28150  
-
-      changes to:  (VARS ARCHIVEBROWSERCOMS) (FNS AB.Delete.Command AB.Retrieve.Command 
-AB.Retrieve.Directory.Command AB.Retrieve.Renamed.Aux AB.Undelete.Command AB ARCHIVEBROWSER 
-AB.Make.Cedar.Filename AB.Retrieve.Renamed.Command)
-
-      previous date: "22-Sep-86 13:12:01" {QV}<BRIGGS>LISP>ARCHIVEBROWSER.;4)
-
-
-(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT ARCHIVEBROWSERCOMS)
-
-(RPAQQ ARCHIVEBROWSERCOMS ((* * the user's interface to the archive browser) (FNS ARCHIVEBROWSER AB)
- (* * command processing functions) (FNS AB.When.Selected.Fn AB.Command.Fn AB.Delete.Command 
-AB.Expunge.Command AB.Filter.Command AB.Recompute.Command AB.Retrieve.Command 
-AB.Retrieve.Directory.Command AB.Retrieve.Renamed.Command AB.Retrieve.Renamed.Aux AB.Sort.Command 
-AB.Undelete.Command) (* * miscellaneous functions) (FNS AB.Set.Browser.Title AB.Iconfn AB.Closefn 
-AB.Printfn AB.Prompt.For.Input AB.Read.Directory AB.Subitemp AB.Make.Cedar.Filename) (* * the user 
-that gets retrieval requests) (INITVARS (AB.archivist "Archivist")) (* * the structure for an archive 
-entry) (RECORDS AB.item) (* * the icon) (BITMAPS AB.icon AB.icon.mask) (INITVARS (AB.titled.icon (
-create TITLEDICON ICON _ AB.icon MASK _ AB.icon.mask TITLEREG _ (CREATEREGION 7 8 60 24)))) (* * the 
-font for the browser, which must be a fixed pitch font for now) (VARS (AB.browser.font (FONTCREATE (
-QUOTE TERMINAL) 10))) (* * based on the TableBrowser package) (FILES TABLEBROWSER) (DECLARE: 
-EVAL@COMPILE DONTCOPY (FILES TABLEBROWSERDECLS)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
-COMPILERVARS (ADDVARS (NLAMA AB) (NLAML) (LAMA)))))
-(* * the user's interface to the archive browser)
-
-(DEFINEQ
-
-(ARCHIVEBROWSER
-(LAMBDA (archivefilespec filter) (* N.H.Briggs " 2-Mar-87 16:56") (LET* ((menu (create MENU ITEMS _ (
-QUOTE ((Retrieve AB.Retrieve.Command "Retrieve selected files" (SUBITEMS ("Retrieve selected files" 
-AB.Retrieve.Command "Retrieve selected files") ("Retrieve to directory" AB.Retrieve.Directory.Command 
-"Retrieve selected files to a different directory") ("Retrieve renamed" AB.Retrieve.Renamed.Command 
-"Retrieve selected files specifying new name for each file"))) (Filter AB.Filter.Command 
-"Set filter for displayed file names") (Sort AB.Sort.Command "Sort entries by file name" (SUBITEMS (
-"Sort by file name" AB.Sort.Command "Sort entries by file name") ("Sort by creation date" (
-AB.Sort.Command CreationDate) "Sort entries by creation date of the file") ("Sort by archive date" (
-AB.Sort.Command Archive) "Sort entries by date that the file was archived") (Reverse (AB.Sort.Command 
-Reverse) "Reverse the order of the entries"))) (Recompute AB.Recompute.Command 
-"Redisplay browser items after re-reading archive directory" (SUBITEMS ("Same directory" 
-AB.Recompute.Command "Redisplay browser items after re-reading archive directory") ("New directory" (
-AB.Recompute.Command T) "Browse a different archive directory"))) ("" NIL "do nothing - a separator") 
-(Delete AB.Delete.Command "Delete selected items") (Undelete AB.Undelete.Command 
-"Undelete selected items" (SUBITEMS ("Undelete selected items" AB.Undelete.Command 
-"Undelete selected items") ("Undelete ALL items" (AB.Undelete.Command T) "Undelete all deleted items")
-)) ("" NIL "do nothing - a separator so you don't accidentally Expunge") (Expunge AB.Expunge.Command 
-"Expunge deleted items and rewrite the archive directory"))) CENTERFLG _ T TITLE _ " Commands " 
-WHENSELECTEDFN _ (QUOTE AB.When.Selected.Fn))) (promptfont (FONTCREATE (QUOTE HELVETICA) 10)) (
-promptheight (HEIGHTIFWINDOW (TIMES 2 (FONTPROP promptfont (QUOTE HEIGHT))) T)) (promptwindow) (
-windowregion (GETREGION (PLUS (fetch IMAGEWIDTH of menu) 144) (PLUS (fetch IMAGEHEIGHT of menu) 
-promptheight))) (window (CREATEW (CREATEREGION (fetch LEFT of windowregion) (fetch BOTTOM of 
-windowregion) (DIFFERENCE (fetch WIDTH of windowregion) (fetch IMAGEWIDTH of menu)) (DIFFERENCE (fetch
- HEIGHT of windowregion) promptheight)) "")) (browser (TB.MAKE.BROWSER NIL window (BQUOTE (PRINTFN 
-AB.Printfn FONT (\, AB.browser.font)))))) (ATTACHMENU menu window (QUOTE RIGHT) (QUOTE TOP)) (
-TB.USERDATA browser (LIST (QUOTE ARCHIVE) (PACKFILENAME.STRING (QUOTE HOST) (OR (FILENAMEFIELD 
-archivefilespec (QUOTE HOST)) (FILENAMEFIELD (DIRECTORYNAME) (QUOTE HOST))) (QUOTE DIRECTORY) (OR (
-FILENAMEFIELD archivefilespec (QUOTE DIRECTORY)) (CAR (FULLUSERNAME T))) (QUOTE NAME) (OR (
-FILENAMEFIELD archivefilespec (QUOTE NAME)) (QUOTE Archive)) (QUOTE EXTENSION) (OR (FILENAMEFIELD 
-archivefilespec (QUOTE EXTENSION)) (QUOTE directory)) (QUOTE BODY) archivefilespec) (QUOTE FILTER) (OR
- filter "*.*"))) (* (use something like this if the "attic" is used) L-CASE (OR filter (CONCAT (CAR (
-FULLUSERNAME T)) ">*.*"))) (SETQ promptwindow (GETPROMPTWINDOW window 2 (FONTCREATE (QUOTE HELVETICA) 
-10))) (AB.Set.Browser.Title browser) (WINDOWPROP promptwindow (QUOTE MINSIZE) (CONS 0 (fetch (REGION 
-HEIGHT) of (WINDOWPROP promptwindow (QUOTE REGION))))) (WINDOWPROP promptwindow (QUOTE MAXSIZE) (CONS 
-64000 (fetch (REGION HEIGHT) of (WINDOWPROP promptwindow (QUOTE REGION))))) (LINELENGTH MAX.SMALLP 
-promptwindow) (WINDOWPROP window (QUOTE ICONFN) (FUNCTION AB.Iconfn)) (WINDOWADDPROP window (QUOTE 
-CLOSEFN) (FUNCTION AB.Closefn) T) (AB.Command.Fn (SASSOC (QUOTE Recompute) (fetch (MENU ITEMS) of menu
-)) menu (QUOTE LEFT)))))
-
-(AB
-(NLAMBDA filespec% filter (* N.H.Briggs " 4-Mar-87 12:11") (LET ((patternandfilter (NLAMBDA.ARGS 
-filespec% filter))) (ARCHIVEBROWSER (CAR patternandfilter) (CADR patternandfilter)) NIL)))
-)
-(* * command processing functions)
-
-(DEFINEQ
-
-(AB.When.Selected.Fn
-(LAMBDA (Item Menu Key) (* N.H.Briggs "25-Jun-86 11:48") (if (AND (LISTP Item) (CADR Item)) then (
-TB.PROCESS (LIST (FUNCTION AB.Command.Fn) (KWOTE Item) (KWOTE Menu) (KWOTE Key)) (PACK* (QUOTE AB-) (
-CAR Item))))))
-
-(AB.Command.Fn
-(LAMBDA (item menu key) (* N.H.Briggs "18-Jun-86 13:09") (RESETLST (LET* ((realitem item) (window (
-WINDOWPROP (WFROMMENU menu) (QUOTE MAINWINDOW))) (browser (WINDOWPROP window (QUOTE TABLEBROWSER)))) (
-if (NOT (MEMBER item (fetch (MENU ITEMS) of menu))) then (* A subitem -- fetch main item) (SETQ item (
-for I in (fetch (MENU ITEMS) of menu) thereis (AB.Subitemp item I)))) (if (OBTAIN.MONITORLOCK (fetch (
-TABLEBROWSER TBLOCK) of browser) T T) then (RESETSAVE (SHADEITEM item menu MENUSELECTSHADE) (LIST (
-FUNCTION SHADEITEM) item menu WHITESHADE)) (LET ((function (CADR realitem)) (promptwindow (
-GETPROMPTWINDOW window)) extra) (if (OPENWP promptwindow) then (CLEARW promptwindow)) (if (LISTP 
-function) then (SETQ extra (CADR function)) (SETQ function (CAR function))) (APPLY* function browser 
-extra)) else (TB.BROWSER.BUSY browser))))))
-
-(AB.Delete.Command
-(LAMBDA (browser) (* N.H.Briggs " 4-Mar-87 17:01") (LET ((count 0) (browserpromptwindow (
-GETPROMPTWINDOW (TB.WINDOW browser)))) (DECLARE (SPECVARS count)) (TB.MAP.SELECTED.ITEMS browser (
-FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS count)) (TB.DELETE.ITEM browser item) (add count 1)
-))) (if (EQ count 0) then (printout browserpromptwindow "No items marked for deletion.") else (
-printout browserpromptwindow count " item" (if (IGREATERP count 1) then "s" else "") 
-" marked for deletion.")))))
-
-(AB.Expunge.Command
-(LAMBDA (browser) (* N.H.Briggs "18-Jun-86 12:23") (if (EQ (fetch (TABLEBROWSER TB#DELETED) of browser
-) 0) then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to expunge!") else (LET ((
-directorystream (OPENSTREAM (PACKFILENAME (QUOTE VERSION) NIL (QUOTE BODY) (LISTGET (TB.USERDATA 
-browser) (QUOTE ARCHIVE))) (QUOTE OUTPUT)))) (if (NOT directorystream) then (printout (GETPROMPTWINDOW
- (TB.WINDOW browser)) "Error opening (new version of) archive directory " (LISTGET (TB.USERDATA 
-browser) (QUOTE ARCHIVE)) " ...aborted.") else (LINELENGTH MAX.SMALLP directorystream) (* ensure 
-nothing wraps around) (LISTPUT (TB.USERDATA browser) (QUOTE ALLITEMS) (for item in (LISTGET (
-TB.USERDATA browser) (QUOTE ALLITEMS)) when (NOT (TB.ITEM.DELETED? browser item)) collect (printout 
-directorystream (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)) , (fetch (AB.item 
-AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of item))) (for media on (fetch (AB.item AB.Media) of (
-fetch (TABLEITEM TIDATA) of item)) by (CDDR media) do (printout directorystream ,, (CAR media)) (
-printout directorystream , (CADR media)) finally (printout directorystream T)) item)) (LISTPUT (
-TB.USERDATA browser) (QUOTE ARCHIVE) (L-CASE (FULLNAME directorystream))) (CLOSEF directorystream) (
-AB.Set.Browser.Title browser) (TB.MAP.DELETED.ITEMS browser (FUNCTION TB.REMOVE.ITEM)))))))
-
-(AB.Filter.Command
-(LAMBDA (browser) (* N.H.Briggs "18-Jun-86 12:28") (LET ((pattern (AB.Prompt.For.Input 
-"Files matching what? " (LISTGET (TB.USERDATA browser) (QUOTE FILTER)) browser T))) (if pattern then (
-LISTPUT (TB.USERDATA browser) (QUOTE FILTER) (L-CASE pattern)) (AB.Set.Browser.Title browser) (
-AB.Recompute.Command browser)))))
-
-(AB.Recompute.Command
-(LAMBDA (browser newdirectory?) (* N.H.Briggs "19-Sep-86 12:34") (LET* ((window (TB.WINDOW browser)) (
-windowregion (WINDOWPROP window (QUOTE REGION))) (region (CREATEREGION 0 0 (fetch (REGION WIDTH) of 
-windowregion) (fetch (REGION HEIGHT) of windowregion))) (namewidth 0) (userdata (TB.USERDATA browser))
- (filter (DIRECTORY.MATCH.SETUP (PACKFILENAME (QUOTE BODY) (LISTGET userdata (QUOTE FILTER))))) result
-) (if (NOT (ZEROP (fetch (TABLEBROWSER TB#DELETED) of browser))) then (if (MENU (create MENU ITEMS _ (
-QUOTE (("Expunge" (QUOTE Expunge) "Expunge items marked for deletion") ("Don't Expunge" NIL 
-"Don't expunge items marked for deletion"))) TITLE _ "Expunge deleted items?" CENTERFLG _ T)) then (
-AB.Expunge.Command browser))) (if (AND newdirectory? (SETQ result (AB.Prompt.For.Input 
-"New archive directory? " NIL browser T))) then (LISTPUT userdata (QUOTE ARCHIVE) (PACKFILENAME.STRING
- (QUOTE NAME) (OR (FILENAMEFIELD result (QUOTE NAME)) (QUOTE Archive)) (QUOTE EXTENSION) (OR (
-FILENAMEFIELD result (QUOTE EXTENSION)) (QUOTE directory)) (QUOTE BODY) result))) (if (OR (NOT 
-newdirectory?) (AND newdirectory? result)) then (TB.REPLACE.ITEMS browser) (LISTPUT userdata (QUOTE 
-ALLITEMS) (for item in (AB.Read.Directory browser) bind tableitem eachtime (SETQ tableitem (create 
-TABLEITEM TIDATA _ item)) collect (if (DIRECTORY.MATCH filter (PACKFILENAME (QUOTE BODY) (fetch (
-AB.item AB.Filename) of item))) then (SETQ namewidth (MAX namewidth (STRINGWIDTH (fetch (AB.item 
-AB.Filename) of item) AB.browser.font))) (TB.INSERT.ITEM browser tableitem)) tableitem)) (LISTPUT 
-userdata (QUOTE NAMEWIDTH) namewidth) (TB.DISPLAY.LINES browser (TB.FIRST.VISIBLE.ITEM# browser region
-) (TB.LAST.VISIBLE.ITEM# browser region))))))
-
-(AB.Retrieve.Command
-(LAMBDA (browser) (* N.H.Briggs " 4-Mar-87 16:54") (DECLARE (GLOBALVARS AB.archivist)) (PROG ((count 0
-) registry corestream) (DECLARE (SPECVARS corestream count)) (SETQ registry (SELECTQ (OR (LAFITEMODE) 
-(\LAFITE.INFER.MODE)) (GV ".pa") (NS ":PA") (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser)) 
-"Can't retrieve -- Lafite mode must be set to GV or NS")))) (SETQ corestream (OPENSTREAM (QUOTE 
-{NODIRCORE}) (QUOTE BOTH))) (LINELENGTH MAX.SMALLP corestream) (printout corestream 
-"Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " (FULLUSERNAME) T T) (
-TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS corestream count)) (
-printout corestream "Retrieve: " (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)) 
-" of " (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of item)) " from " (CAR (fetch (
-AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) " or " (CADR (fetch (AB.item AB.Media) of (
-fetch (TABLEITEM TIDATA) of item))) T) (add count 1)))) (if (EQ count 0) then (printout (
-GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to retrieve.") (CLOSEF corestream) (RETURN)) (SETQ 
-corestream (OPENTEXTSTREAM corestream)) (printout (GETPROMPTWINDOW (TB.WINDOW browser)) 
-"Sending mail to " AB.archivist registry " requesting " count " file" (if (NEQ count 1) then "s:  " 
-else ":  ")) (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) then (printout (GETPROMPTWINDOW (
-TB.WINDOW browser)) " done.") else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) " failed.")))))
-
-(AB.Retrieve.Directory.Command
-(LAMBDA (browser) (* N.H.Briggs " 4-Mar-87 16:53") (DECLARE (GLOBALVARS AB.archivist)) (PROG ((count 0
-) registry corestream newdirectory) (DECLARE (SPECVARS corestream count newdirectory)) (SETQ registry 
-(SELECTQ (OR (LAFITEMODE) (\LAFITE.INFER.MODE)) (GV ".pa") (NS ":PA") (RETURN (printout (
-GETPROMPTWINDOW (TB.WINDOW browser)) "Can't retrieve -- Lafite mode must be set to GV or NS")))) (if (
-NOT (SETQ newdirectory (AB.Prompt.For.Input "Directory to retrieve into? " NIL browser T))) then (
-RETURN)) (SETQ corestream (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (LINELENGTH MAX.SMALLP 
-corestream) (printout corestream "Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " (
-FULLUSERNAME) T T) (TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS 
-corestream count newdirectory)) (printout corestream "Retrieve: " (fetch (AB.item AB.Filename) of (
-fetch (TABLEITEM TIDATA) of item)) " of " (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM 
-TIDATA) of item)) " from " (CAR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) 
-" or " (CADR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) " as " (
-AB.Make.Cedar.Filename (PACKFILENAME.STRING (QUOTE DIRECTORY) newdirectory (QUOTE VERSION) NIL (QUOTE 
-BODY) (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)))) T) (add count 1)))) (if (
-EQ count 0) then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to retrieve.") (CLOSEF 
-corestream) (RETURN)) (SETQ corestream (OPENTEXTSTREAM corestream)) (printout (GETPROMPTWINDOW (
-TB.WINDOW browser)) "Sending mail to " AB.archivist registry " requesting " count " file" (if (NEQ 
-count 1) then "s:  " else ":  ")) (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) then (printout (
-GETPROMPTWINDOW (TB.WINDOW browser)) " done.") else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) 
-" failed.")))))
-
-(AB.Retrieve.Renamed.Command
-(LAMBDA (browser) (* N.H.Briggs " 3-Mar-87 12:34") (DECLARE (GLOBALVARS AB.archivist)) (PROG ((count 0
-) registry corestream) (DECLARE (SPECVARS corestream count)) (SETQ registry (SELECTQ (OR (LAFITEMODE) 
-(\LAFITE.INFER.MODE)) (GV ".pa") (NS ":PA") (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser)) 
-"Can't retrieve -- Lafite mode must be set to GV or NS")))) (SETQ corestream (OPENSTREAM (QUOTE 
-{NODIRCORE}) (QUOTE BOTH))) (LINELENGTH MAX.SMALLP corestream) (printout corestream 
-"Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " (FULLUSERNAME) T T) (
-TB.MAP.SELECTED.ITEMS browser (FUNCTION AB.Retrieve.Renamed.Aux)) (if (EQ count 0) then (printout (
-GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to retrieve.") (CLOSEF corestream) (RETURN)) (SETQ 
-corestream (OPENTEXTSTREAM corestream)) (printout (GETPROMPTWINDOW (TB.WINDOW browser)) 
-"Sending mail to " AB.archivist registry " requesting " count " file" (if (NEQ count 1) then "s:  " 
-else ":  ")) (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) then (printout (GETPROMPTWINDOW (
-TB.WINDOW browser)) " done.") else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) " failed.")))))
-
-(AB.Retrieve.Renamed.Aux
-(LAMBDA (browser item) (* N.H.Briggs " 4-Mar-87 16:52") (DECLARE (SPECVARS corestream count)) (LET ((
-newname (AB.Prompt.For.Input (CONCAT "Retrieve " (fetch (AB.item AB.Filename) of (fetch (TABLEITEM 
-TIDATA) of item)) " as ?") (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)) browser
- "... skipped"))) (if newname then (printout corestream "Retrieve: " (fetch (AB.item AB.Filename) of (
-fetch (TABLEITEM TIDATA) of item)) " of " (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM 
-TIDATA) of item)) " from " (CAR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) 
-" or " (CADR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) " as " (
-AB.Make.Cedar.Filename (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) newname)) T) (add count 1
-)))))
-
-(AB.Sort.Command
-(LAMBDA (browser sorttype) (* N.H.Briggs "17-Jun-86 12:47") (LET ((items (fetch (TABLEBROWSER TBITEMS)
- of browser))) (if (EQ sorttype (QUOTE Reverse)) then (SETQ items (DREVERSE items)) else (SORT items (
-SELECTQ sorttype (CreationDate (FUNCTION (LAMBDA (x y) (IGREATERP (IDATE (fetch (AB.item 
-AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of x))) (IDATE (fetch (AB.item AB.Creation.Date) of (
-fetch (TABLEITEM TIDATA) of y))))))) (Archive (FUNCTION (LAMBDA (x y) (ILESSP (fetch (AB.item 
-AB.Sequence.Number) of (fetch (TABLEITEM TIDATA) of x)) (fetch (AB.item AB.Sequence.Number) of (fetch 
-(TABLEITEM TIDATA) of y)))))) (FUNCTION (LAMBDA (x y) (ALPHORDER (fetch (AB.item AB.Filename) of (
-fetch (TABLEITEM TIDATA) of x)) (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of y)) (
-UPPERCASEARRAY))))))) (for item in items as i from 1 do (replace TI# of item with i)) (
-TB.REPLACE.ITEMS browser items) (TB.REDISPLAY.ITEMS browser))))
-
-(AB.Undelete.Command
-(LAMBDA (browser all?) (* N.H.Briggs " 4-Mar-87 17:00") (LET ((count 0) (browserpromptwindow (
-GETPROMPTWINDOW (TB.WINDOW browser)))) (DECLARE (SPECVARS count)) (if all? then (TB.MAP.DELETED.ITEMS 
-browser (FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS count)) (TB.UNDELETE.ITEM browser item) (
-add count 1)))) else (TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) (DECLARE (
-SPECVARS count)) (TB.UNDELETE.ITEM browser item) (add count 1))))) (if (EQ count 0) then (printout 
-browserpromptwindow "No items were undeleted.") else (printout browserpromptwindow count " item" (if (
-NEQ count 1) then "s" else "") " undeleted.")))))
-)
-(* * miscellaneous functions)
-
-(DEFINEQ
-
-(AB.Set.Browser.Title
-(LAMBDA (browser) (* N.H.Briggs "17-Jun-86 15:45") (LET ((archive (LISTGET (TB.USERDATA browser) (
-QUOTE ARCHIVE))) (filter (LISTGET (TB.USERDATA browser) (QUOTE FILTER)))) (WINDOWPROP (GETPROMPTWINDOW
- (TB.WINDOW browser)) (QUOTE TITLE) (CONCAT "Archive Browser" (OR (AND archive (CONCAT " " archive)) 
-"") (OR (AND filter (CONCAT " - files " filter)) ""))))))
-
-(AB.Iconfn
-(LAMBDA (window icon) (* N.H.Briggs "19-Sep-86 18:58") (DECLARE (GLOBALVARS AB.titled.icon)) (LET* ((
-browser (WINDOWPROP window (QUOTE TABLEBROWSER))) (archive (LISTGET (TB.USERDATA browser) (QUOTE 
-ARCHIVE))) (directory (UNPACKFILENAME.STRING archive (QUOTE DIRECTORY))) (host (UNPACKFILENAME.STRING 
-archive (QUOTE HOST))) (title (PACKFILENAME.STRING (QUOTE HOST) host (QUOTE DIRECTORY) (SUBSTRING 
-directory 1 (STRPOS directory ">"))))) (if icon then (ICONW.TITLE icon title) icon else (TITLEDICONW 
-AB.titled.icon title (FONTCREATE (QUOTE MODERN) 8) NIL NIL NIL (CHARCODE (})))))))
-
-(AB.Closefn
-(LAMBDA (window) (* edited: "20-Jun-86 12:42") (LET ((browser (WINDOWPROP window (QUOTE TABLEBROWSER))
-)) (if (NOT (ZEROP (fetch (TABLEBROWSER TB#DELETED) of browser))) then (if (MENU (create MENU ITEMS _ 
-(QUOTE (("Expunge" (QUOTE Expunge) "Expunge items marked for deletion") ("Don't Expunge" NIL 
-"Don't expunge items marked for deletion"))) TITLE _ "Expunge deleted items?" CENTERFLG _ T)) then (
-AB.Expunge.Command browser))) NIL)))
-
-(AB.Printfn
-(LAMBDA (browser item window) (* N.H.Briggs "22-Sep-86 13:09") (LET* ((entry (fetch TIDATA of item)) (
-namewidth (OR (LISTGET (TB.USERDATA browser) (QUOTE NAMEWIDTH)) 0)) (offset (DSPXPOSITION NIL window))
- (datestart (IPLUS offset namewidth 10))) (* if this is to work for variable spaced fonts it has to be
- smart about the widths of date and media fields too) (PRIN1 (fetch (AB.item AB.Filename) of entry) 
-window) (if (ZEROP namewidth) then (PRIN1 " " window) else (BLTSHADE WHITESHADE window (DSPXPOSITION 
-NIL window) (IDIFFERENCE (DSPYPOSITION NIL window) (FONTPROP AB.browser.font (QUOTE DESCENT))) (
-IDIFFERENCE datestart (DSPXPOSITION NIL window)) (FONTPROP AB.browser.font (QUOTE HEIGHT))) (
-DSPXPOSITION datestart window)) (PRIN1 (fetch (AB.item AB.Creation.Date) of entry) window) (PRIN1 
-"   " window) (for media in (fetch (AB.item AB.Media) of entry) do (PRIN1 media window) (PRIN1 " " 
-window)))))
-
-(AB.Prompt.For.Input
-(LAMBDA (prompt default browser abortflag) (* N.H.Briggs "22-Apr-86 17:32") (* * Prompt for input for 
-browser browser with question prompt offering default answer DEFAULT. If abortflag is true and 
-response is NIL, prints "... aborted" or abortflag (should be a text string)) (LET* ((promptwindow (
-GETPROMPTWINDOW (TB.WINDOW browser))) (promptwidth (STRINGWIDTH prompt promptwindow)) (windowwidth (
-WINDOWPROP promptwindow (QUOTE WIDTH))) result) (CLEARW promptwindow) (if (IGREATERP (IPLUS 
-promptwidth (STRINGWIDTH (OR default "XXX") promptwindow)) windowwidth) then (* Prompt plus default 
-response will overflow the width of the window, so be a nice guy and break it up) (for i from (
-IDIFFERENCE (NCHARS prompt) 4) to 10 by -1 bind (excesswidth _ (IDIFFERENCE promptwidth windowwidth)) 
-when (AND (EQ (NTHCHARCODE prompt i) (CHARCODE SPACE)) (IGREATERP (STRINGWIDTH (SUBSTRING prompt i) 
-promptwindow) excesswidth)) do (RETURN (SETQ prompt (CONCAT (SUBSTRING prompt 1 (IPLUS i -1)) "
-" (SUBSTRING prompt (IPLUS i 1))))))) (SETQ result (CAR (NLSETQ (PROMPTFORWORD prompt default NIL 
-promptwindow NIL (QUOTE TTY) (CHARCODE (CR ESC)))))) (if (AND (EQ result NIL) abortflag) then (
-PRINTOUT promptwindow (if (EQ abortflag T) then "... aborted" else abortflag))) (TERPRI promptwindow) 
-result)))
-
-(AB.Read.Directory
-(LAMBDA (browser) (* N.H.Briggs "22-Sep-86 12:53") (LET ((directorystream (AND (LISTGET (TB.USERDATA 
-browser) (QUOTE ARCHIVE)) (CAR (NLSETQ (OPENSTREAM (LISTGET (TB.USERDATA browser) (QUOTE ARCHIVE)) (
-QUOTE INPUT)))))) (linerdtable (COPYREADTABLE (QUOTE ORIG))) (promptwindow (GETPROMPTWINDOW (TB.WINDOW
- browser))) items) (if (NOT directorystream) then (printout promptwindow 
-"Can't find archive directory " (LISTGET (TB.USERDATA browser) (QUOTE ARCHIVE))) (LISTPUT (TB.USERDATA
- browser) (QUOTE ARCHIVE) NIL) (AB.Set.Browser.Title browser) NIL else (LISTPUT (TB.USERDATA browser) 
-(QUOTE ARCHIVE) (L-CASE (FULLNAME directorystream))) (AB.Set.Browser.Title browser) (SETSEPR (LIST (
-CONSTANT (CHARCODE EOL))) NIL linerdtable) (SETBRK NIL NIL linerdtable) (bind start end inputline 
-repeatuntil (EOFP directorystream) eachtime (SETQ inputline (RSTRING directorystream linerdtable)) (
-READC directorystream) as i from 1 collect (create AB.item AB.Filename _ (L-CASE (SUBSTRING inputline 
-1 (SUB1 (SETQ end (STRPOS " " inputline))))) AB.Creation.Date _ (SUBSTRING inputline (ADD1 end) (SUB1 
-(SETQ end (STRPOS "  " inputline (ADD1 end))))) AB.Media _ (first (SETQ end (ADD1 end)) repeatwhile 
-end eachtime (SETQ start (ADD1 end)) (while (EQUAL (SUBSTRING inputline start start) " ") do (SETQ 
-start (ADD1 start))) (SETQ end (STRPOS " " inputline start)) collect (SUBSTRING inputline start (AND 
-end (SUB1 end)))) AB.Sequence.Number _ i) finally (CLOSEF directorystream))))))
-
-(AB.Subitemp
-(LAMBDA (subitem item) (* N.H.Briggs "16-Apr-86 18:32") (* * True if subitem appears among the 
-subitems of item or descendents) (LET ((sub (CADDDR item))) (AND sub (EQ (CAR (LISTP sub)) (QUOTE 
-SUBITEMS)) (OR (MEMBER subitem sub) (for i in (CDR sub) thereis (AB.Subitemp subitem i)))))))
-
-(AB.Make.Cedar.Filename
-(LAMBDA (filename) (* N.H.Briggs " 3-Mar-87 12:08") (LET ((unpackedfilename (UNPACK filename))) (PACK 
-(SUBLIS (QUOTE (({ . %[) (} . %]) (; . !))) unpackedfilename)))))
-)
-(* * the user that gets retrieval requests)
-
-
-(RPAQ? AB.archivist "Archivist")
-(* * the structure for an archive entry)
-
-[DECLARE: EVAL@COMPILE 
-
-(RECORD AB.item (AB.Filename AB.Creation.Date AB.Media AB.Sequence.Number))
-]
-(* * the icon)
-
-
-(RPAQ AB.icon (READBITMAP))
-(73 73
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"O@@@@@@AN@@@@@@@@AH@"
-"ML@@@@@CK@@@@@@@@AH@"
-"LOOOOOOOOOOOOOOOOIH@"
-"LJ@@@@@DHG@@@@@@AIH@"
-"LK@@@@AHHAL@@@@@FIH@"
-"LIH@@@A@H@GH@@@@LIH@"
-"LHF@@@G@H@@OL@@GHIH@"
-"LHC@@COOOOOOGOOO@IH@"
-"LHAH@C@CN@@A@@@F@IH@"
-"LH@LON@FK@@A@@AL@IH@"
-"LH@FNBAOOOOA@@CL@IH@"
-"LH@CLBCHHL@A@@FH@IH@"
-"LH@AKOOOOOOI@@MH@IH@"
-"LH@ADB@@L@LA@AI@@IH@"
-"LH@ANB@@L@CA@FA@@IH@"
-"LH@@KCOOOOOOMOC@@IH@"
-"LH@@IH@CL@@@CJB@@IH@"
-"LH@@HH@FF@@@GBB@@IH@"
-"LH@@HDALG@@@LFC@@IH@"
-"LH@@HCOOOOOOHDA@@IH@"
-"LH@@HCL@F@@G@DA@@IH@"
-"LH@@HAOOOOOO@DAH@IH@"
-"OH@AHAOOOOOO@D@H@IH@"
-"LO@C@AOOOOOO@D@L@IH@"
-"LION@CAHC@FA@D@GHIH@"
-"LH@N@F@HA@LA@D@AOIH@"
-"LH@GNL@DAAHAHBAO@IH@"
-"LH@BGO@CAB@@LCOB@IH@"
-"LH@B@MNAIFAOOO@F@IH@"
-"LH@B@DCLOMNCHB@D@IH@"
-"LH@B@D@COO@F@B@D@IH@"
-"LH@B@D@@FGLB@B@D@IH@"
-"LH@B@L@GL@CO@C@F@IH@"
-"LH@B@HCL@@@GNAHC@IH@"
-"LH@FAKL@@@@@AOLAHIH@"
-"LH@DAL@@@@@@@AN@LIH@"
-"LH@OO@@@@@@@@@CNFIH@"
-"LHCL@@@@@@@@@@@CNIH@"
-"OOO@@@@@@@@@@@@@AIH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LH@@@@@@@@@@@@@@@IH@"
-"LOOOOOOOOOOOOOOOOIH@"
-"L@@@@@@@@@@@@@@@@AH@"
-"L@@@@@@@@@@@@@@@@AH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@")
-
-(RPAQ AB.icon.mask (READBITMAP))
-(73 73
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@"
-"OOOOOOOOOOOOOOOOOOH@")
-
-(RPAQ? AB.titled.icon (create TITLEDICON ICON _ AB.icon MASK _ AB.icon.mask TITLEREG _ (CREATEREGION
- 7 8 60 24)))
-(* * the font for the browser, which must be a fixed pitch font for now)
-
-
-(RPAQ AB.browser.font (FONTCREATE (QUOTE TERMINAL) 10))
-(* * based on the TableBrowser package)
-
-(FILESLOAD TABLEBROWSER)
-(DECLARE: EVAL@COMPILE DONTCOPY 
-(FILESLOAD TABLEBROWSERDECLS)
-)
-(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA AB)
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA )
-)
-(PUTPROPS ARCHIVEBROWSER COPYRIGHT ("Xerox Corporation" 1986 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (1797 5673 (ARCHIVEBROWSER 1807 . 5473) (AB 5475 . 5671)) (5715 18075 (
-AB.When.Selected.Fn 5725 . 5965) (AB.Command.Fn 5967 . 6830) (AB.Delete.Command 6832 . 7357) (
-AB.Expunge.Command 7359 . 8764) (AB.Filter.Command 8766 . 9109) (AB.Recompute.Command 9111 . 10870) (
-AB.Retrieve.Command 10872 . 12460) (AB.Retrieve.Directory.Command 12462 . 14401) (
-AB.Retrieve.Renamed.Command 14403 . 15599) (AB.Retrieve.Renamed.Aux 15601 . 16431) (AB.Sort.Command 
-16433 . 17398) (AB.Undelete.Command 17400 . 18073)) (18112 23830 (AB.Set.Browser.Title 18122 . 18509) 
-(AB.Iconfn 18511 . 19112) (AB.Closefn 19114 . 19567) (AB.Printfn 19569 . 20498) (AB.Prompt.For.Input 
-20500 . 21823) (AB.Read.Directory 21825 . 23323) (AB.Subitemp 23325 . 23630) (AB.Make.Cedar.Filename 
-23632 . 23828)))))
-STOP
diff --git a/obsolete/lispusers/ARCHIVEBROWSER.LCOM b/obsolete/lispusers/ARCHIVEBROWSER.LCOM
deleted file mode 100644
index 2677a0ed..00000000
Binary files a/obsolete/lispusers/ARCHIVEBROWSER.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/ARCHIVETOOL b/obsolete/lispusers/ARCHIVETOOL
deleted file mode 100644
index a9dbc1e4..00000000
--- a/obsolete/lispusers/ARCHIVETOOL
+++ /dev/null
@@ -1,1321 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "10-Mar-89 17:03:42" {POOH/N}<POOH>BURWELL>LISP>ARCHIVETOOL;4 77278  
-
-      changes to%:  (FNS FB.DoArchiveCommands)
-                    (VARS ARCHIVETOOLCOMS)
-
-      previous date%: " 1-Dec-88 14:12:21" {POOH/N}<POOH>BURWELL>LISP>ARCHIVETOOL;2)
-
-
-(* "
-Copyright (c) 1985, 1986, 1988, 1989 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT ARCHIVETOOLCOMS)
-
-(RPAQQ ARCHIVETOOLCOMS
-       [(COMS 
-
-(* ;;; "the user's interface to the archive browser")
-
-              (FNS ARCHIVEBROWSER AB)
-              
-
-(* ;;; "command processing functions")
-
-              (FNS AB.When.Selected.Fn AB.Command.Fn AB.Delete.Command AB.Expunge.Command 
-                   AB.Filter.Command AB.Recompute.Command AB.Retrieve.Command 
-                   AB.Retrieve.Directory.Command AB.Retrieve.Renamed.Command AB.Retrieve.Renamed.Aux
-                   AB.Sort.Command AB.Undelete.Command)
-              
-
-(* ;;; "miscellaneous functions")
-
-              (FNS AB.Set.Browser.Title AB.Iconfn AB.Closefn AB.Printfn AB.Prompt.For.Input 
-                   AB.Read.Directory AB.Subitemp AB.Make.Cedar.Filename)
-              
-
-(* ;;; "the user that gets retrieval requests")
-
-              (INITVARS (AB.archivist "Archivist"))
-              
-
-(* ;;; "the structure for an archive entry")
-
-              (RECORDS AB.item)
-              
-
-(* ;;; "the icon")
-
-              (BITMAPS AB.icon AB.icon.mask)
-              [INITVARS (AB.titled.icon (create TITLEDICON ICON _ AB.icon MASK _ AB.icon.mask 
-                                               TITLEREG _ (CREATEREGION 7 8 60 24]
-              
-
-(* ;;; "the font for the browser, which must be a fixed pitch font for now")
-
-              (VARS (AB.browser.font (FONTCREATE 'TERMINAL 10)))
-              
-
-(* ;;; "based on the TableBrowser package")
-
-              
-
-(* ;;; " took out WORDFNS")
-
-              (FILES TABLEBROWSER))
-        (COMS (* LOAD the FILEBROWSER first)
-              (FILES FILEBROWSER))
-        [COMS (* ArchiveTool File Browser Interface Functions)
-              (FNS Arch.ConvertToCedarFileName FB.ArchiveCommand FB.ArchiveAllCommand 
-                   FB.ArchiveAndDeleteCommand FB.ArchiveAndDeleteAllCommand FB.DoArchiveCommands)
-              (GLOBALVARS Arch.CcToSelfFlg Arch.VerifyNotArchivedFlg OKCedarCharBitTable)
-              [VARS (OKCedarCharBitTable (MAKEBITTABLE (APPEND (CHARCODE (%. $ - + * < > { }))
-                                                              (for i from (CHARCODE a)
-                                                                   to
-                                                                   (CHARCODE z)
-                                                                   collect i)
-                                                              (for i from (CHARCODE A)
-                                                                   to
-                                                                   (CHARCODE Z)
-                                                                   collect i)
-                                                              (CHARCODE (0 1 2 3 4 5 6 7 8 9]
-              (INITVARS (Arch.CcToSelfFlg T)
-                     (Arch.VerifyNotArchivedFlg NIL))
-              (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (BackgroundMenuCommands (ArchiveBrowser
-                                                                                '(ARCHIVEBROWSER)
-                                                                                
-                                                                       "Brings up an archive browser"
-                                                                                )))
-                     (P (SETQ BackgroundMenu)))
-              (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
-                                                      TABLEBROWSERDECLS)
-                     (FILES (LOADCOMP)
-                            FILEBROWSER))
-              (DECLARE%: DONTEVAL@LOAD DOCOPY
-                     (P (if (NOT (SASSOC "Archive" FB.MENU.ITEMS))
-                            then
-                            (PUTASSOC "Archive" '(FB.ArchiveCommand 
-                                            "Archives selected files by sending mail to Archivist.pa"
-                                                        (SUBITEMS ("Archive" FB.ArchiveCommand 
-                                            "Archives selected files by sending mail to Archivist.pa"
-                                                                         )
-                                                               ("Archive ALL Files" 
-                                                                      FB.ArchiveAllCommand 
-                                  "Archives ALL files in the browser by sending mail to Archivist.pa"
-                                                                      )
-                                                               ("Archive and Delete" 
-                                                                      FB.ArchiveAndDeleteCommand 
-                   "Archives selected files by sending an Archive and Delete request to Archivist.pa"
-                                                                      )
-                                                               ("Archive and Delete ALL Files" 
-                                                                      FB.ArchiveAndDeleteAllCommand 
-         "Archives ALL files in the browser by sending an Archive and Delete request to Archivist.pa"
-                                                                      )))
-                                   FB.MENU.ITEMS)
-                            else
-                            (RPLACD (SASSOC "Archive" FB.MENU.ITEMS)
-                                   '(FB.ArchiveCommand 
-                                           "Archives selected files by sending mail to Archivist.pa"
-                                           (SUBITEMS ("Archive" FB.ArchiveCommand 
-                                            "Archives selected files by sending mail to Archivist.pa"
-                                                            )
-                                                  ("Archive ALL Files" FB.ArchiveAllCommand 
-                                  "Archives ALL files in the browser by sending mail to Archivist.pa"
-                                                         )
-                                                  ("Archive and Delete" FB.ArchiveAndDeleteCommand 
-                   "Archives selected files by sending an Archive and Delete request to Archivist.pa"
-                                                         )
-                                                  ("Archive and Delete ALL Files" 
-                                                         FB.ArchiveAndDeleteAllCommand 
-         "Archives ALL files in the browser by sending an Archive and Delete request to Archivist.pa"
-                                                         ]
-        (COMS (* Functions that aren't used any more)
-              (FNS Arch.ParseReturnMsg Arch.BackgroundMenuFn))
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA AB)
-                                                                             (NLAML)
-                                                                             (LAMA])
-
-
-
-(* ;;; "the user's interface to the archive browser")
-
-(DEFINEQ
-
-(ARCHIVEBROWSER
-  [LAMBDA (archivefilespec filter)                           (* N.H.Briggs " 2-Mar-87 16:56")
-    (LET* [(menu (create MENU
-                        ITEMS _ '((Retrieve AB.Retrieve.Command "Retrieve selected files"
-                                         (SUBITEMS ("Retrieve selected files" AB.Retrieve.Command 
-                                                          "Retrieve selected files")
-                                                ("Retrieve to directory" 
-                                                       AB.Retrieve.Directory.Command 
-                                                   "Retrieve selected files to a different directory"
-                                                       )
-                                                ("Retrieve renamed" AB.Retrieve.Renamed.Command 
-                                          "Retrieve selected files specifying new name for each file"
-                                                       )))
-                                  (Filter AB.Filter.Command "Set filter for displayed file names")
-                                  (Sort AB.Sort.Command "Sort entries by file name"
-                                        (SUBITEMS ("Sort by file name" AB.Sort.Command 
-                                                         "Sort entries by file name")
-                                               ("Sort by creation date" (AB.Sort.Command CreationDate
-                                                                               )
-                                                      "Sort entries by creation date of the file")
-                                               ("Sort by archive date" (AB.Sort.Command Archive)
-                                                      
-                                                    "Sort entries by date that the file was archived"
-                                                      )
-                                               (Reverse (AB.Sort.Command Reverse)
-                                                      "Reverse the order of the entries")))
-                                  (Recompute AB.Recompute.Command 
-                                         "Redisplay browser items after re-reading archive directory"
-                                         (SUBITEMS ("Same directory" AB.Recompute.Command 
-                                         "Redisplay browser items after re-reading archive directory"
-                                                          )
-                                                ("New directory" (AB.Recompute.Command T)
-                                                       "Browse a different archive directory")))
-                                  ("" NIL "do nothing - a separator")
-                                  (Delete AB.Delete.Command "Delete selected items")
-                                  (Undelete AB.Undelete.Command "Undelete selected items"
-                                         (SUBITEMS ("Undelete selected items" AB.Undelete.Command 
-                                                          "Undelete selected items")
-                                                ("Undelete ALL items" (AB.Undelete.Command T)
-                                                       "Undelete all deleted items")))
-                                  ("" NIL 
-                                      "do nothing - a separator so you don't accidentally Expunge")
-                                  (Expunge AB.Expunge.Command 
-                                         "Expunge deleted items and rewrite the archive directory"))
-                        CENTERFLG _ T
-                        TITLE _ " Commands "
-                        WHENSELECTEDFN _ 'AB.When.Selected.Fn))
-           (promptfont (FONTCREATE 'HELVETICA 10))
-           (promptheight (HEIGHTIFWINDOW (TIMES 2 (FONTPROP promptfont 'HEIGHT))
-                                T))
-           (promptwindow)
-           (windowregion (GETREGION (PLUS (fetch IMAGEWIDTH of menu)
-                                          144)
-                                (PLUS (fetch IMAGEHEIGHT of menu)
-                                      promptheight)))
-           (window (CREATEW (CREATEREGION (fetch LEFT of windowregion)
-                                   (fetch BOTTOM of windowregion)
-                                   (DIFFERENCE (fetch WIDTH of windowregion)
-                                          (fetch IMAGEWIDTH of menu))
-                                   (DIFFERENCE (fetch HEIGHT of windowregion)
-                                          promptheight))
-                          ""))
-           (browser (TB.MAKE.BROWSER NIL window `(PRINTFN AB.Printfn FONT ,AB.browser.font]
-          (ATTACHMENU menu window 'RIGHT 'TOP)
-          (TB.USERDATA browser (LIST 'ARCHIVE (PACKFILENAME.STRING 'HOST (OR (FILENAMEFIELD
-                                                                              archivefilespec
-                                                                              'HOST)
-                                                                             (FILENAMEFIELD
-                                                                              (DIRECTORYNAME)
-                                                                              'HOST))
-                                                     'DIRECTORY
-                                                     (OR (FILENAMEFIELD archivefilespec 'DIRECTORY)
-                                                         (CAR (FULLUSERNAME T)))
-                                                     'NAME
-                                                     (OR (FILENAMEFIELD archivefilespec 'NAME)
-                                                         'Archive)
-                                                     'EXTENSION
-                                                     (OR (FILENAMEFIELD archivefilespec 'EXTENSION)
-                                                         'directory)
-                                                     'BODY archivefilespec)
-                                     'FILTER
-                                     (OR filter "*.*")))     (* (use something like this if the 
-                                                             "attic" is used) L-CASE
-                                                             (OR filter (CONCAT (CAR
-                                                             (FULLUSERNAME T)) ">*.*")))
-          (SETQ promptwindow (GETPROMPTWINDOW window 2 (FONTCREATE 'HELVETICA 10)))
-          (AB.Set.Browser.Title browser)
-          [WINDOWPROP promptwindow 'MINSIZE (CONS 0 (fetch (REGION HEIGHT) of (WINDOWPROP
-                                                                               promptwindow
-                                                                               'REGION]
-          [WINDOWPROP promptwindow 'MAXSIZE (CONS 64000 (fetch (REGION HEIGHT)
-                                                           of (WINDOWPROP promptwindow 'REGION]
-          (LINELENGTH MAX.SMALLP promptwindow)
-          (WINDOWPROP window 'ICONFN (FUNCTION AB.Iconfn))
-          (WINDOWADDPROP window 'CLOSEFN (FUNCTION AB.Closefn)
-                 T)
-          (AB.Command.Fn (SASSOC 'Recompute (fetch (MENU ITEMS) of menu))
-                 menu
-                 'LEFT])
-
-(AB
-  [NLAMBDA filespec% filter                                  (* N.H.Briggs " 4-Mar-87 12:11")
-    (LET ((patternandfilter (NLAMBDA.ARGS filespec% filter)))
-         (ARCHIVEBROWSER (CAR patternandfilter)
-                (CADR patternandfilter))
-         NIL])
-)
-
-
-
-(* ;;; "command processing functions")
-
-(DEFINEQ
-
-(AB.When.Selected.Fn
-  [LAMBDA (Item Menu Key)                                    (* N.H.Briggs "25-Jun-86 11:48")
-    (if (AND (LISTP Item)
-             (CADR Item))
-        then (TB.PROCESS (LIST (FUNCTION AB.Command.Fn)
-                               (KWOTE Item)
-                               (KWOTE Menu)
-                               (KWOTE Key))
-                    (PACK* 'AB- (CAR Item])
-
-(AB.Command.Fn
-  [LAMBDA (item menu key)                                    (* N.H.Briggs "18-Jun-86 13:09")
-    (RESETLST
-        (LET* [(realitem item)
-               (window (WINDOWPROP (WFROMMENU menu)
-                              'MAINWINDOW))
-               (browser (WINDOWPROP window 'TABLEBROWSER]
-              [if (NOT (MEMBER item (fetch (MENU ITEMS) of menu)))
-                  then                                       (* A subitem -- fetch main item)
-                       (SETQ item (for I in (fetch (MENU ITEMS) of menu)
-                                     thereis (AB.Subitemp item I]
-              (if (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of browser)
-                         T T)
-                  then (RESETSAVE (SHADEITEM item menu MENUSELECTSHADE)
-                              (LIST (FUNCTION SHADEITEM)
-                                    item menu WHITESHADE))
-                       (LET ((function (CADR realitem))
-                             (promptwindow (GETPROMPTWINDOW window))
-                             extra)
-                            (if (OPENWP promptwindow)
-                                then (CLEARW promptwindow))
-                            (if (LISTP function)
-                                then (SETQ extra (CADR function))
-                                     (SETQ function (CAR function)))
-                            (APPLY* function browser extra))
-                else (TB.BROWSER.BUSY browser))))])
-
-(AB.Delete.Command
-  [LAMBDA (browser)                                          (* N.H.Briggs "16-Apr-86 20:56")
-    (LET ((count 0))
-         [TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item)
-                                                    (TB.DELETE.ITEM browser item)
-                                                    (add count 1]
-         (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                count " item" (if (IGREATERP count 1)
-                                  then "s"
-                                else "")
-                " marked for deletion."])
-
-(AB.Expunge.Command
-  [LAMBDA (browser)                                          (* N.H.Briggs "18-Jun-86 12:23")
-    (if (EQ (fetch (TABLEBROWSER TB#DELETED) of browser)
-            0)
-        then (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                    "Nothing to expunge!")
-      else (LET [(directorystream (OPENSTREAM (PACKFILENAME 'VERSION NIL 'BODY (LISTGET (TB.USERDATA
-                                                                                         browser)
-                                                                                      'ARCHIVE))
-                                         'OUTPUT]
-                (if (NOT directorystream)
-                    then (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                                "Error opening (new version of) archive directory "
-                                (LISTGET (TB.USERDATA browser)
-                                       'ARCHIVE)
-                                " ...aborted.")
-                  else (LINELENGTH MAX.SMALLP directorystream) 
-                                                             (* ensure nothing wraps around)
-                       (LISTPUT (TB.USERDATA browser)
-                              'ALLITEMS
-                              (for item in (LISTGET (TB.USERDATA browser)
-                                                  'ALLITEMS) when (NOT (TB.ITEM.DELETED? browser item
-                                                                              ))
-                                 collect (printout directorystream (fetch (AB.item AB.Filename)
-                                                                      of (fetch (TABLEITEM TIDATA)
-                                                                            of item))
-                                                %,
-                                                (fetch (AB.item AB.Creation.Date)
-                                                   of (fetch (TABLEITEM TIDATA) of item)))
-                                       (for media on (fetch (AB.item AB.Media)
-                                                        of (fetch (TABLEITEM TIDATA) of item))
-                                          by (CDDR media) do (printout directorystream %,,
-                                                                    (CAR media))
-                                                             (printout directorystream %,
-                                                                    (CADR media))
-                                          finally (printout directorystream T))
-                                       item))
-                       (LISTPUT (TB.USERDATA browser)
-                              'ARCHIVE
-                              (L-CASE (FULLNAME directorystream)))
-                       (CLOSEF directorystream)
-                       (AB.Set.Browser.Title browser)
-                       (TB.MAP.DELETED.ITEMS browser (FUNCTION TB.REMOVE.ITEM])
-
-(AB.Filter.Command
-  [LAMBDA (browser)                                          (* N.H.Briggs "18-Jun-86 12:28")
-    (LET ((pattern (AB.Prompt.For.Input "Files matching what? " (LISTGET (TB.USERDATA browser)
-                                                                       'FILTER)
-                          browser T)))
-         (if pattern
-             then (LISTPUT (TB.USERDATA browser)
-                         'FILTER
-                         (L-CASE pattern))
-                  (AB.Set.Browser.Title browser)
-                  (AB.Recompute.Command browser])
-
-(AB.Recompute.Command
-  [LAMBDA (browser newdirectory?)                            (* N.H.Briggs "19-Sep-86 12:34")
-    (LET* ((window (TB.WINDOW browser))
-           (windowregion (WINDOWPROP window 'REGION))
-           (region (CREATEREGION 0 0 (fetch (REGION WIDTH) of windowregion)
-                          (fetch (REGION HEIGHT) of windowregion)))
-           (namewidth 0)
-           (userdata (TB.USERDATA browser))
-           [filter (DIRECTORY.MATCH.SETUP (PACKFILENAME 'BODY (LISTGET userdata 'FILTER]
-           result)
-          (if (NOT (ZEROP (fetch (TABLEBROWSER TB#DELETED) of browser)))
-              then (if (MENU (create MENU
-                                    ITEMS _ '(("Expunge" 'Expunge "Expunge items marked for deletion"
-                                                     )
-                                              ("Don't Expunge" NIL 
-                                                     "Don't expunge items marked for deletion"))
-                                    TITLE _ "Expunge deleted items?"
-                                    CENTERFLG _ T))
-                       then (AB.Expunge.Command browser)))
-          (if (AND newdirectory? (SETQ result (AB.Prompt.For.Input "New archive directory? " NIL 
-                                                     browser T)))
-              then (LISTPUT userdata 'ARCHIVE (PACKFILENAME.STRING 'NAME (OR (FILENAMEFIELD
-                                                                              result
-                                                                              'NAME)
-                                                                             'Archive)
-                                                     'EXTENSION
-                                                     (OR (FILENAMEFIELD result 'EXTENSION)
-                                                         'directory)
-                                                     'BODY result)))
-          (if (OR (NOT newdirectory?)
-                  (AND newdirectory? result))
-              then (TB.REPLACE.ITEMS browser)
-                   (LISTPUT userdata 'ALLITEMS
-                          (for item in (AB.Read.Directory browser) bind tableitem
-                             eachtime (SETQ tableitem (create TABLEITEM
-                                                             TIDATA _ item))
-                             collect (if (DIRECTORY.MATCH filter (PACKFILENAME 'BODY
-                                                                        (fetch (AB.item AB.Filename)
-                                                                           of item)))
-                                         then (SETQ namewidth (MAX namewidth
-                                                                   (STRINGWIDTH (fetch (AB.item
-                                                                                        AB.Filename)
-                                                                                   of item)
-                                                                          AB.browser.font)))
-                                              (TB.INSERT.ITEM browser tableitem))
-                                   tableitem))
-                   (LISTPUT userdata 'NAMEWIDTH namewidth)
-                   (TB.DISPLAY.LINES browser (TB.FIRST.VISIBLE.ITEM# browser region)
-                          (TB.LAST.VISIBLE.ITEM# browser region])
-
-(AB.Retrieve.Command
-  [LAMBDA (browser)                                          (* N.H.Briggs " 3-Mar-87 12:41")
-    (DECLARE (GLOBALVARS AB.archivist))
-    (PROG ((count 0)
-           registry corestream)
-          [SETQ registry (SELECTQ (OR (LAFITEMODE)
-                                      (\LAFITE.INFER.MODE))
-                             (GV ".pa")
-                             (NS ":PA")
-                             (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                                            "Can't retrieve -- Lafite mode must be set to GV or NS"]
-          (SETQ corestream (OPENSTREAM '{NODIRCORE} 'BOTH))
-          (LINELENGTH MAX.SMALLP corestream)
-          (printout corestream "Subject: Retrieve request" T "To: " AB.archivist registry T "cc: "
-                 (FULLUSERNAME)
-                 T T)
-          [TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item)
-                                                     (printout corestream "Retrieve: "
-                                                            (fetch (AB.item AB.Filename)
-                                                               of (fetch (TABLEITEM TIDATA)
-                                                                     of item))
-                                                            " of "
-                                                            (fetch (AB.item AB.Creation.Date)
-                                                               of (fetch (TABLEITEM TIDATA)
-                                                                     of item))
-                                                            " from "
-                                                            (CAR (fetch (AB.item AB.Media)
-                                                                    of (fetch (TABLEITEM TIDATA)
-                                                                          of item)))
-                                                            " or "
-                                                            (CADR (fetch (AB.item AB.Media)
-                                                                     of (fetch (TABLEITEM TIDATA)
-                                                                           of item)))
-                                                            T)
-                                                     (add count 1]
-          (SETQ corestream (OPENTEXTSTREAM corestream))
-          (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                 "Sending mail to " AB.archivist registry " requesting " count " file"
-                 (if (NEQ count 1)
-                     then "s:  "
-                   else ":  "))
-          (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream)))
-              then (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                          " done.")
-            else (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                        " failed."])
-
-(AB.Retrieve.Directory.Command
-  [LAMBDA (browser)                                          (* N.H.Briggs " 3-Mar-87 12:41")
-    (DECLARE (GLOBALVARS AB.archivist))
-    (PROG ((count 0)
-           registry corestream newdirectory)
-          [SETQ registry (SELECTQ (OR (LAFITEMODE)
-                                      (\LAFITE.INFER.MODE))
-                             (GV ".pa")
-                             (NS ":PA")
-                             (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                                            "Can't retrieve -- Lafite mode must be set to GV or NS"]
-          (if (NOT (SETQ newdirectory (AB.Prompt.For.Input "Directory to retrieve into? " NIL browser
-                                             T)))
-              then (RETURN))
-          (SETQ corestream (OPENSTREAM '{NODIRCORE} 'BOTH))
-          (LINELENGTH MAX.SMALLP corestream)
-          (printout corestream "Subject: Retrieve request" T "To: " AB.archivist registry T "cc: "
-                 (FULLUSERNAME)
-                 T T)
-          [TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item)
-                                                     (printout
-                                                      corestream "Retrieve: "
-                                                      (fetch (AB.item AB.Filename)
-                                                         of (fetch (TABLEITEM TIDATA) of item))
-                                                      " of "
-                                                      (fetch (AB.item AB.Creation.Date)
-                                                         of (fetch (TABLEITEM TIDATA) of item))
-                                                      " from "
-                                                      (CAR (fetch (AB.item AB.Media)
-                                                              of (fetch (TABLEITEM TIDATA)
-                                                                    of item)))
-                                                      " or "
-                                                      (CADR (fetch (AB.item AB.Media)
-                                                               of (fetch (TABLEITEM TIDATA)
-                                                                     of item)))
-                                                      " as "
-                                                      [AB.Make.Cedar.Filename
-                                                       (PACKFILENAME.STRING
-                                                        'DIRECTORY newdirectory 'VERSION NIL
-                                                        'BODY
-                                                        (fetch (AB.item AB.Filename)
-                                                           of (fetch (TABLEITEM TIDATA) of item]
-                                                      T)
-                                                     (add count 1]
-          (SETQ corestream (OPENTEXTSTREAM corestream))
-          (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                 "Sending mail to " AB.archivist registry " requesting " count " file"
-                 (if (NEQ count 1)
-                     then "s:  "
-                   else ":  "))
-          (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream)))
-              then (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                          " done.")
-            else (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                        " failed."])
-
-(AB.Retrieve.Renamed.Command
-  [LAMBDA (browser)                                          (* N.H.Briggs " 3-Mar-87 12:34")
-    (DECLARE (GLOBALVARS AB.archivist))
-    (PROG ((count 0)
-           registry corestream)
-          (DECLARE (SPECVARS corestream count))
-          [SETQ registry (SELECTQ (OR (LAFITEMODE)
-                                      (\LAFITE.INFER.MODE))
-                             (GV ".pa")
-                             (NS ":PA")
-                             (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                                            "Can't retrieve -- Lafite mode must be set to GV or NS"]
-          (SETQ corestream (OPENSTREAM '{NODIRCORE} 'BOTH))
-          (LINELENGTH MAX.SMALLP corestream)
-          (printout corestream "Subject: Retrieve request" T "To: " AB.archivist registry T "cc: "
-                 (FULLUSERNAME)
-                 T T)
-          (TB.MAP.SELECTED.ITEMS browser (FUNCTION AB.Retrieve.Renamed.Aux))
-          (if (EQ count 0)
-              then (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                          "Nothing to retrieve.")
-                   (CLOSEF corestream)
-                   (RETURN))
-          (SETQ corestream (OPENTEXTSTREAM corestream))
-          (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                 "Sending mail to " AB.archivist registry " requesting " count " file"
-                 (if (NEQ count 1)
-                     then "s:  "
-                   else ":  "))
-          (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream)))
-              then (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                          " done.")
-            else (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                        " failed."])
-
-(AB.Retrieve.Renamed.Aux
-  [LAMBDA (browser item)                                     (* N.H.Briggs " 3-Mar-87 12:38")
-    (LET ((newname (AB.Prompt.For.Input (CONCAT "Retrieve " (fetch (AB.item AB.Filename)
-                                                               of (fetch (TABLEITEM TIDATA)
-                                                                     of item))
-                                               " as ?")
-                          (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item))
-                          browser "... skipped")))
-         (if newname
-             then (printout corestream "Retrieve: " (fetch (AB.item AB.Filename)
-                                                       of (fetch (TABLEITEM TIDATA) of item))
-                         " of "
-                         (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of item))
-                         " from "
-                         (CAR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item)))
-                         " or "
-                         (CADR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item)))
-                         " as "
-                         (AB.Make.Cedar.Filename (PACKFILENAME.STRING 'VERSION NIL 'BODY newname))
-                         T)
-                  (add count 1))
-         (HELP])
-
-(AB.Sort.Command
-  [LAMBDA (browser sorttype)                                 (* N.H.Briggs "17-Jun-86 12:47")
-    (LET ((items (fetch (TABLEBROWSER TBITEMS) of browser)))
-         [if (EQ sorttype 'Reverse)
-             then (SETQ items (DREVERSE items))
-           else (SORT items (SELECTQ sorttype
-                                (CreationDate [FUNCTION (LAMBDA (x y)
-                                                          (IGREATERP
-                                                           (IDATE (fetch (AB.item AB.Creation.Date)
-                                                                     of (fetch (TABLEITEM TIDATA)
-                                                                           of x)))
-                                                           (IDATE (fetch (AB.item AB.Creation.Date)
-                                                                     of (fetch (TABLEITEM TIDATA)
-                                                                           of y])
-                                (Archive [FUNCTION (LAMBDA (x y)
-                                                     (ILESSP (fetch (AB.item AB.Sequence.Number)
-                                                                of (fetch (TABLEITEM TIDATA)
-                                                                      of x))
-                                                            (fetch (AB.item AB.Sequence.Number)
-                                                               of (fetch (TABLEITEM TIDATA)
-                                                                     of y])
-                                (FUNCTION (LAMBDA (x y)
-                                            (ALPHORDER (fetch (AB.item AB.Filename)
-                                                          of (fetch (TABLEITEM TIDATA) of x))
-                                                   (fetch (AB.item AB.Filename)
-                                                      of (fetch (TABLEITEM TIDATA) of y))
-                                                   (UPPERCASEARRAY]
-         (for item in items as i from 1 do (replace TI# of item with i))
-         (TB.REPLACE.ITEMS browser items)
-         (TB.REDISPLAY.ITEMS browser])
-
-(AB.Undelete.Command
-  [LAMBDA (browser all?)                                     (* N.H.Briggs "16-Apr-86 21:01")
-    (LET ((count 0))
-         [if all?
-             then [TB.MAP.DELETED.ITEMS browser (FUNCTION (LAMBDA (browser item)
-                                                            (TB.UNDELETE.ITEM browser item)
-                                                            (add count 1]
-           else (TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item)
-                                                           (TB.UNDELETE.ITEM browser item)
-                                                           (add count 1]
-         (printout (GETPROMPTWINDOW (TB.WINDOW browser))
-                count " item" (if (NEQ count 1)
-                                  then "s"
-                                else "")
-                " undeleted."])
-)
-
-
-
-(* ;;; "miscellaneous functions")
-
-(DEFINEQ
-
-(AB.Set.Browser.Title
-  [LAMBDA (browser)                                          (* N.H.Briggs "17-Jun-86 15:45")
-    (LET [(archive (LISTGET (TB.USERDATA browser)
-                          'ARCHIVE))
-          (filter (LISTGET (TB.USERDATA browser)
-                         'FILTER]
-         (WINDOWPROP (GETPROMPTWINDOW (TB.WINDOW browser))
-                'TITLE
-                (CONCAT "Archive Browser" (OR (AND archive (CONCAT " " archive))
-                                              "")
-                       (OR (AND filter (CONCAT " - files " filter))
-                           ""])
-
-(AB.Iconfn
-  [LAMBDA (window icon)                                      (* N.H.Briggs "19-Sep-86 18:58")
-    (DECLARE (GLOBALVARS AB.titled.icon))
-    (LET* [(browser (WINDOWPROP window 'TABLEBROWSER))
-           (archive (LISTGET (TB.USERDATA browser)
-                           'ARCHIVE))
-           (directory (UNPACKFILENAME.STRING archive 'DIRECTORY))
-           (host (UNPACKFILENAME.STRING archive 'HOST))
-           (title (PACKFILENAME.STRING 'HOST host 'DIRECTORY (SUBSTRING directory 1 (STRPOS directory
-                                                                                           ">"]
-          (if icon
-              then (ICONW.TITLE icon title)
-                   icon
-            else (TITLEDICONW AB.titled.icon title (FONTCREATE 'MODERN 8)
-                        NIL NIL NIL (CHARCODE (}])
-
-(AB.Closefn
-  [LAMBDA (window)                                           (* edited%: "20-Jun-86 12:42")
-    (LET [(browser (WINDOWPROP window 'TABLEBROWSER]
-         (if (NOT (ZEROP (fetch (TABLEBROWSER TB#DELETED) of browser)))
-             then (if (MENU (create MENU
-                                   ITEMS _ '(("Expunge" 'Expunge "Expunge items marked for deletion")
-                                             ("Don't Expunge" NIL 
-                                                    "Don't expunge items marked for deletion"))
-                                   TITLE _ "Expunge deleted items?"
-                                   CENTERFLG _ T))
-                      then (AB.Expunge.Command browser)))
-         NIL])
-
-(AB.Printfn
-  [LAMBDA (browser item window)                              (* N.H.Briggs "22-Sep-86 13:09")
-    (LET* ((entry (fetch TIDATA of item))
-           (namewidth (OR (LISTGET (TB.USERDATA browser)
-                                 'NAMEWIDTH)
-                          0))
-           (offset (DSPXPOSITION NIL window))
-           (datestart (IPLUS offset namewidth 10)))
-
-         (* if this is to work for variable spaced fonts it has to be smart about the 
-         widths of date and media fields too)
-
-          (PRIN1 (fetch (AB.item AB.Filename) of entry)
-                 window)
-          (if (ZEROP namewidth)
-              then (PRIN1 " " window)
-            else (BLTSHADE WHITESHADE window (DSPXPOSITION NIL window)
-                        (IDIFFERENCE (DSPYPOSITION NIL window)
-                               (FONTPROP AB.browser.font 'DESCENT))
-                        (IDIFFERENCE datestart (DSPXPOSITION NIL window))
-                        (FONTPROP AB.browser.font 'HEIGHT))
-                 (DSPXPOSITION datestart window))
-          (PRIN1 (fetch (AB.item AB.Creation.Date) of entry)
-                 window)
-          (PRIN1 "   " window)
-          (for media in (fetch (AB.item AB.Media) of entry) do (PRIN1 media window)
-                                                               (PRIN1 " " window])
-
-(AB.Prompt.For.Input
-  [LAMBDA (prompt default browser abortflag)                 (* N.H.Briggs "22-Apr-86 17:32")
-
-         (* * Prompt for input for browser browser with question prompt offering default 
-         answer DEFAULT. If abortflag is true and response is NIL, prints "... aborted" or 
-         abortflag (should be a text string))
-
-    (LET* ((promptwindow (GETPROMPTWINDOW (TB.WINDOW browser)))
-           (promptwidth (STRINGWIDTH prompt promptwindow))
-           (windowwidth (WINDOWPROP promptwindow 'WIDTH))
-           result)
-          (CLEARW promptwindow)
-          [if (IGREATERP (IPLUS promptwidth (STRINGWIDTH (OR default "XXX")
-                                                   promptwindow))
-                     windowwidth)
-              then 
-
-         (* Prompt plus default response will overflow the width of the window, so be a 
-         nice guy and break it up)
-
-                   (for i from (IDIFFERENCE (NCHARS prompt)
-                                      4) to 10 by -1 bind (excesswidth _ (IDIFFERENCE promptwidth 
-                                                                                windowwidth))
-                      when (AND (EQ (NTHCHARCODE prompt i)
-                                    (CHARCODE SPACE))
-                                (IGREATERP (STRINGWIDTH (SUBSTRING prompt i)
-                                                  promptwindow)
-                                       excesswidth))
-                      do (RETURN (SETQ prompt (CONCAT (SUBSTRING prompt 1 (IPLUS i -1))
-                                                     "
-"
-                                                     (SUBSTRING prompt (IPLUS i 1]
-          [SETQ result (CAR (NLSETQ (PROMPTFORWORD prompt default NIL promptwindow NIL 'TTY
-                                           (CHARCODE (CR ESC]
-          (if (AND (EQ result NIL)
-                   abortflag)
-              then (PRINTOUT promptwindow (if (EQ abortflag T)
-                                              then "... aborted"
-                                            else abortflag)))
-          (TERPRI promptwindow)
-          result])
-
-(AB.Read.Directory
-  [LAMBDA (browser)                                          (* N.H.Briggs "22-Sep-86 12:53")
-    (LET ([directorystream (AND (LISTGET (TB.USERDATA browser)
-                                       'ARCHIVE)
-                                (CAR (NLSETQ (OPENSTREAM (LISTGET (TB.USERDATA browser)
-                                                                'ARCHIVE)
-                                                    'INPUT]
-          (linerdtable (COPYREADTABLE 'ORIG))
-          (promptwindow (GETPROMPTWINDOW (TB.WINDOW browser)))
-          items)
-         (if (NOT directorystream)
-             then (printout promptwindow "Can't find archive directory " (LISTGET (TB.USERDATA 
-                                                                                         browser)
-                                                                                'ARCHIVE))
-                  (LISTPUT (TB.USERDATA browser)
-                         'ARCHIVE NIL)
-                  (AB.Set.Browser.Title browser)
-                  NIL
-           else (LISTPUT (TB.USERDATA browser)
-                       'ARCHIVE
-                       (L-CASE (FULLNAME directorystream)))
-                (AB.Set.Browser.Title browser)
-                (SETSEPR (LIST (CONSTANT (CHARCODE EOL)))
-                       NIL linerdtable)
-                (SETBRK NIL NIL linerdtable)
-                (bind start end inputline repeatuntil (EOFP directorystream)
-                   eachtime (SETQ inputline (RSTRING directorystream linerdtable))
-                         (READC directorystream) as i from 1
-                   collect (create AB.item
-                                  AB.Filename _ [L-CASE (SUBSTRING inputline 1
-                                                               (SUB1 (SETQ end (STRPOS " " inputline]
-                                  AB.Creation.Date _ [SUBSTRING inputline (ADD1 end)
-                                                            (SUB1 (SETQ end (STRPOS "  " inputline
-                                                                                   (ADD1 end]
-                                  AB.Media _ [first (SETQ end (ADD1 end)) repeatwhile end
-                                                eachtime (SETQ start (ADD1 end))
-                                                      (while (EQUAL (SUBSTRING inputline start start)
-                                                                    " ") do (SETQ start (ADD1 start))
-                                                             )
-                                                      (SETQ end (STRPOS " " inputline start))
-                                                collect (SUBSTRING inputline start
-                                                               (AND end (SUB1 end]
-                                  AB.Sequence.Number _ i) finally (CLOSEF directorystream])
-
-(AB.Subitemp
-  [LAMBDA (subitem item)                                     (* N.H.Briggs "16-Apr-86 18:32")
-
-         (* * True if subitem appears among the subitems of item or descendents)
-
-    (LET ((sub (CADDDR item)))
-         (AND sub (EQ (CAR (LISTP sub))
-                      'SUBITEMS)
-              (OR (MEMBER subitem sub)
-                  (for i in (CDR sub) thereis (AB.Subitemp subitem i])
-
-(AB.Make.Cedar.Filename
-  [LAMBDA (filename)                                         (* N.H.Briggs " 3-Mar-87 12:08")
-    (LET ((unpackedfilename (UNPACK filename)))
-         (PACK (SUBLIS '(({ . %[)
-                         (} . %])
-                         (; . !))
-                      unpackedfilename])
-)
-
-
-
-(* ;;; "the user that gets retrieval requests")
-
-
-(RPAQ? AB.archivist "Archivist")
-
-
-
-(* ;;; "the structure for an archive entry")
-
-(DECLARE%: EVAL@COMPILE
-
-(RECORD AB.item (AB.Filename AB.Creation.Date AB.Media AB.Sequence.Number))
-)
-
-
-
-(* ;;; "the icon")
-
-
-(RPAQQ AB.icon #*(73 73)OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@O@@@@@@AN@@@@@@@@AH@ML@@@@@CK@@@@@@@@AH@LOOOOOOOOOOOOOOOOIH@LJ@@@@@DHG@@@@@@AIH@LK@@@@AHHAL@@@@@FIH@LIH@@@A@H@GH@@@@LIH@LHF@@@G@H@@OL@@GHIH@LHC@@COOOOOOGOOO@IH@LHAH@C@CN@@A@@@F@IH@LH@LON@FK@@A@@AL@IH@LH@FNBAOOOOA@@CL@IH@LH@CLBCHHL@A@@FH@IH@LH@AKOOOOOOI@@MH@IH@LH@ADB@@L@LA@AI@@IH@LH@ANB@@L@CA@FA@@IH@LH@@KCOOOOOOMOC@@IH@LH@@IH@CL@@@CJB@@IH@LH@@HH@FF@@@GBB@@IH@LH@@HDALG@@@LFC@@IH@LH@@HCOOOOOOHDA@@IH@LH@@HCL@F@@G@DA@@IH@LH@@HAOOOOOO@DAH@IH@OH@AHAOOOOOO@D@H@IH@LO@C@AOOOOOO@D@L@IH@LION@CAHC@FA@D@GHIH@LH@N@F@HA@LA@D@AOIH@LH@GNL@DAAHAHBAO@IH@LH@BGO@CAB@@LCOB@IH@LH@B@MNAIFAOOO@F@IH@LH@B@DCLOMNCHB@D@IH@LH@B@D@COO@F@B@D@IH@LH@B@D@@FGLB@B@D@IH@LH@B@L@GL@CO@C@F@IH@LH@B@HCL@@@GNAHC@IH@LH@FAKL@@@@@AOLAHIH@LH@DAL@@@@@@@AN@LIH@LH@OO@@@@@@@@@CNFIH@LHCL@@@@@@@@@@@CNIH@OOO@@@@@@@@@@@@@AIH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LOOOOOOOOOOOOOOOOIH@L@@@@@@@@@@@@@@@@AH@L@@@@@@@@@@@@@@@@AH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@
-)
-
-(RPAQQ AB.icon.mask #*(73 73)OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@
-)
-
-(RPAQ? AB.titled.icon (create TITLEDICON ICON _ AB.icon MASK _ AB.icon.mask TITLEREG _
-                                 (CREATEREGION 7 8 60 24)))
-
-
-
-(* ;;; "the font for the browser, which must be a fixed pitch font for now")
-
-
-(RPAQ AB.browser.font (FONTCREATE 'TERMINAL 10))
-
-
-
-(* ;;; "based on the TableBrowser package")
-
-
-
-
-(* ;;; " took out WORDFNS")
-
-
-(FILESLOAD TABLEBROWSER)
-
-
-
-(* LOAD the FILEBROWSER first)
-
-
-(FILESLOAD FILEBROWSER)
-
-
-
-(* ArchiveTool File Browser Interface Functions)
-
-(DEFINEQ
-
-(Arch.ConvertToCedarFileName
-  [LAMBDA (FileEntry LispFileName BROWSER)               (* ; "Edited  1-Dec-88 12:47 by bbb")
-
-(* ;;; "Convert a Lisp file name to a Cedar filename with the [host] naming convention and the ! version numbering")
-
-    (DECLARE (GLOBALVARS OKCedarCharBitTable))
-    (DECLARE (SPECVARS SkippedBadFileName))
-    (LET* ((UnpackedName (UNPACKFILENAME.STRING LispFileName))
-           (Host (LISTGET UnpackedName 'HOST))
-           (Name (LISTGET UnpackedName 'NAME))
-           (Extension (LISTGET UnpackedName 'EXTENSION))
-           (Directory (LISTGET UnpackedName 'DIRECTORY))
-           (Version (LISTGET UnpackedName 'VERSION))
-           BadCharPos NewLispFileName (OldLispFileName (ALLOCSTRING (NCHARS LispFileName)))
-           (GoodFileName T)
-           DirectoryEnd)
-          (if (OR (STRING-EQUAL Host "Core")
-                      (STRPOS ":" Host)
-                      (STRPOS "dsk" (L-CASE Host)
-                             1)
-                      (STRPOS "/n" Host)
-                      (STRING-EQUAL Host "Floppy"))
-              then 
-
-                    (* ;; "we can only archive files on an IFS (as of June/88)")
-
-                    (FB.PROMPTWPRINT BROWSER T (CONCAT 
-                                             "You can only archive files stored on an IFS. The host "
-                                                      Host " is NOT an IFS!"))
-                    (SETQ GoodFileName NIL)
-            elseif (AND (STRING-EQUAL Name "")
-                            (STRING-EQUAL Extension ""))
-              then 
-
-                    (* ;; "This is a file with no name - we want to skip the dif files")
-
-                    (SETQ GoodFileName NIL)
-            elseif (AND (STRING-EQUAL (L-CASE Name)
-                                   "archive")
-                            (STRING-EQUAL (L-CASE Extension)
-                                   "directory"))
-              then 
-
-                    (* ;; 
-                  " we don't want to ask to archive the file archive.directory so just skip it")
-
-                    (SETQ GoodFileName NIL)
-            elseif (STRPOS ":" LispFileName 1)
-              then (FB.PROMPTWPRINT BROWSER T (CONCAT LispFileName 
-                                                  " has a colon in the name which Lisp can't handle."
-                                                         )
-                              " You need to manually call RENAMEFILE to eliminate the colons quoting all colons with a single quote."
-                              )
-                    (SETQ GoodFileName NIL)
-            elseif (SETQ BadCharPos (STRPOSL OKCedarCharBitTable Name 1 T))
-              then (FB.PROMPTWPRINT BROWSER T "Invalid character %"" (NTHCHAR Name BadCharPos)
-                              "%" in file " LispFileName ".  Only alphanumeric and .$-+ are allowed."
-                              )
-                    (if (STRING-EQUAL (FB.PROMPTFORINPUT 
-                                                 "Shall I replace all bad chars with $ (Y/N):" "Y" 
-                                                 BROWSER NIL T)
-                                   "Y")
-                        then (SETQ OldLispFileName (CONCAT LispFileName))
-                              (while (AND BadCharPos (ILEQ BadCharPos (NCHARS Name)))
-                                 do (SETQ Name (RPLCHARCODE Name BadCharPos (CHARCODE $)))
-                                       (SETQ BadCharPos (STRPOSL OKCedarCharBitTable Name BadCharPos
-                                                               T)))
-                              (SETQ NewLispFileName (PACKFILENAME.STRING 'NAME Name 'BODY 
-                                                           LispFileName))
-                              (FB.COPY/RENAME.ONE BROWSER FileEntry OldLispFileName NewLispFileName
-                                     'Rename
-                                     (FUNCTION RENAMEFILE))
-                      else (FB.PROMPTWPRINT BROWSER "Skipping " LispFileName ".")
-                            (SETQ SkippedBadFileName T)
-                            (SETQ GoodFileName NIL)))
-          (if GoodFileName
-              then (L-CASE (CONCAT "[" Host "]<" Directory ">" Name
-                                      (if (NOT (STRING-EQUAL Extension ""))
-                                          then (CONCAT "." Extension)
-                                        else "")
-                                      "!" Version])
-
-(FB.ArchiveCommand
-  [LAMBDA (BROWSER)                                          (* N.H.Briggs " 3-Apr-86 20:43")
-
-         (* * Called from FileBrowser Archive command --
-         Archive all selected files)
-
-    (FB.DoArchiveCommands BROWSER 'Archive])
-
-(FB.ArchiveAllCommand
-  [LAMBDA (BROWSER)                                          (* ; "Edited 28-Apr-88 17:58 by bbb")
-
-         (* * Called from FileBrowser Archive All Files command --
-         Archive all files)
-
-    (FB.DoArchiveCommands BROWSER 'ArchiveAll])
-
-(FB.ArchiveAndDeleteCommand
-  [LAMBDA (BROWSER)                                          (* ; "Edited 28-Apr-88 15:47 by bbb")
-
-         (* * Called from FileBrowser Archive and Delete command --
-         Archive and Delete all selected files)
-
-    (FB.DoArchiveCommands BROWSER 'ArchiveAndDelete])
-
-(FB.ArchiveAndDeleteAllCommand
-  [LAMBDA (BROWSER)                                          (* ; "Edited 28-Apr-88 16:52 by bbb")
-
-         (* * Called from FileBrowser Archive and Delete All Files command --
-         Archive and Delete all files)
-
-    (FB.DoArchiveCommands BROWSER 'ArchiveAndDeleteAll])
-
-(FB.DoArchiveCommands
-  [LAMBDA (BROWSER TypeOfArchive)                        (* ; "Edited 10-Mar-89 17:03 by bbb")
-
-(* ;;; "Called from FileBrowser Archive command -- Archive all selected files")
-
-    (DECLARE (GLOBALVARS Arch.CcToSelfFlg))
-    (FB.ALLOW.ABORT BROWSER)
-    (PROG (FileEntriesList REGISTRY CoreStream CedarFileNameList Pattern MakeRequestFLG FilesSelected
-                 ArchivedFiles ArchiveDirectory DotStarPosition SkippedBadFileName)
-          (if (OR (EQ TypeOfArchive 'Archive)
-                      (EQ TypeOfArchive 'ArchiveAndDelete))
-              then (SETQ FilesSelected T))
-          (SETQ Pattern (Arch.ConvertToCedarFileName NIL (fetch PATTERN of BROWSER)
-                               BROWSER))
-
-     (* ;; "Now we need to fix the pattern because in Cedar *.* will only match files that do have extensions.  If there is a  %".*%" then replace this with %"*%"")
-
-          [if (NULL Pattern)
-              then (RETURN)
-            elseif (SETQ DotStarPosition (STRPOS ".*" Pattern))
-              then (SETQ Pattern (CONCAT (SUBSTRING Pattern 1 (SUB1 DotStarPosition))
-                                            (if (NEQ (NTHCHAR Pattern (SUB1 DotStarPosition))
-                                                         '*)
-                                                then "*"
-                                              else "")
-                                            (SUBSTRING Pattern (PLUS 2 DotStarPosition]
-          [SETQ FileEntriesList (if FilesSelected
-                                    then (FB.SELECTEDFILES BROWSER)
-                                  else                   (* ; 
-                                                  "Collect everything that is not a directory item")
-                                        (TB.COLLECT.ITEMS (fetch (FILEBROWSER TABLEBROWSER)
-                                                             of BROWSER)
-                                               (FUNCTION (LAMBDA (BROWSER ITEM)
-                                                           (NOT (fetch TIUNSELECTABLE
-                                                                   of ITEM]
-          (if (NULL FileEntriesList)
-              then (RETURN))
-          (if (AND Arch.VerifyNotArchivedFlg [SETQ ArchiveDirectory
-                                                  (PACKFILENAME.STRING 'NAME "Archive" 'EXTENSION 
-                                                         "Directory" 'VERSION NIL 'BODY
-                                                         (SUBSTRING Pattern 1 (STRPOS ">" Pattern 1]
-                       (INFILEP ArchiveDirectory))
-              then (SETQ ArchivedFiles (CL:MAKE-HASH-TABLE :TEST 'CL:EQUAL)) 
-
-                    (* ;; 
-         "Note that the Archive.Directory has: Filename <1 or more spaces> CreationDate <2 spaces>")
-
-                    (LET ((ArchiveDirectoryStream (OPENSTREAM ArchiveDirectory 'INPUT))
-                          Line EOFP)
-                         (while (AND (SETQ Line (CL:READ-LINE ArchiveDirectoryStream EOFP))
-                                         (NULL EOFP)) bind End FileName CreationDate
-                            do (SETQ End (STRPOS " " Line))
-                                  [SETQ FileName (CONCAT (L-CASE (SUBSTRING Line 1 (SUB1 End]
-                                  [SETQ CreationDate (IDATE (SUBSTRING Line (ADD1 End)
-                                                                   (SUB1 (STRPOS "  " Line
-                                                                                (ADD1 End]
-                                  (CL:SETF (CL:GETHASH FileName ArchivedFiles)
-                                         CreationDate))
-                         (CLOSEF ArchiveDirectoryStream))    (* COLLECTWORDFILE ArchiveDirectory
-                                                           (FUNCTION (LAMBDA (Line)
-                                                           (LET* ((End (STRPOS " " Line))
-                                                           (FileName (CONCAT (L-CASE
-                                                           (SUBSTRING Line 1 (SUB1 End)))))
-                                                           (CreationDate (IDATE
-                                                           (SUBSTRING Line (ADD1 End)
-                                                           (SUB1 (STRPOS "  " Line
-                                                           (ADD1 End))))))) (CL:SETF
-                                                           (CL:GETHASH FileName ArchivedFiles) 
-                                                           CreationDate)))) NIL
-                                                           (FUNCTION DREADLINE) T))
-
-(* ;;; "Determine right away if they can send mail to the Archivist")
-
-          [SETQ REGISTRY (SELECTQ (OR (LAFITEMODE)
-                                      (\LAFITE.INFER.MODE))
-                             (GV ".pa")
-                             (NS ":PA")
-                             (RETURN (FB.PROMPTWPRINT BROWSER T 
-                                            "Can't -- Lafite mode must be set to GV or NS"]
-          (if FilesSelected
-              then (FB.PROMPTWPRINT BROWSER "Validating and preparing archive request for "
-                              (CONCAT (LENGTH FileEntriesList)
-                                     " file"
-                                     (COND
-                                        ((CDR FileEntriesList)
-                                         "s")
-                                        (T "")))
-                              "."))
-
-(* ;;; "Convert the file names and enter them into the msg.  SkippedBadFileName is set to T in  Arch.ConvertToCedarFileName if there is an invalid Cedar file which the user chooses not to rename to a valid name")
-
-          (SETQ SkippedBadFileName NIL)
-          (SETQ CedarFileNameList
-           (for FileName
-              in (bind CedarFileName ArchivedFileDate for FileEntry in 
-                                                                                      FileEntriesList
-                        when (AND (SETQ CedarFileName (Arch.ConvertToCedarFileName
-                                                           FileEntry
-                                                           (FB.FETCHFILENAME FileEntry)
-                                                           BROWSER))
-                                      (if (NULL ArchivedFiles)
-                                          then T
-                                        else (SETQ ArchivedFileDate (CL:GETHASH CedarFileName 
-                                                                               ArchivedFiles))
-                                              (if (EQP ArchivedFileDate (GETFILEINFO (
-                                                                                     FB.FETCHFILENAME
-                                                                                          FileEntry)
-                                                                                   'ICREATIONDATE))
-                                                  then (FB.PROMPTWPRINT BROWSER T (
-                                                                                     FB.FETCHFILENAME
-                                                                                       FileEntry)
-                                                                  " has already been archived!" 
-                                                                  "  Skipping it.")
-                                                        (SETQ SkippedBadFileName T)
-                                                        NIL
-                                                else T))) collect CedarFileName) collect
-                                                                                         FileName))
-          (if CedarFileNameList
-              then [if (AND (NOT FilesSelected)
-                                    SkippedBadFileName)
-                           then 
-
-                                 (* ;; "the person has asked to archive and delete all the files in the browser yet something was wrong with some of their names or else it has already been archived")
-
-                                 (SETQ TypeOfArchive (SELECTQ TypeOfArchive
-                                                         (ArchiveAll 'Archive)
-                                                         (ArchiveAndDeleteAll 
-                                                              'ArchiveAndDelete)
-                                                         (SHOULDNT] 
-
-(* ;;; "Setup the header fields for the msg")
-
-                    (SETQ CoreStream (OPENSTREAM '{NODIRCORE} 'BOTH))
-                    (LINELENGTH 1000 CoreStream)             (* ; "In case of long file names")
-
-(* ;;; "Old code (printout CoreStream %"Subject: Archive request%" T %"To: Archivist%" REGISTRY T %"Cc: %")")
-
-                    (printout CoreStream "Subject: Archive request" (SELECTQ TypeOfArchive
-                                                                        ((ArchiveAll 
-                                                                                ArchiveAndDeleteAll)
-                                                                             
-                                                                             (CONCAT 
-                                                                                 " for all files in "
-                                                                                    Pattern))
-                                                                        (CONCAT " for some files in "
-                                                                               Pattern))
-                           T "To: Archivist" REGISTRY T "Cc: ")
-                    [COND
-                       (Arch.CcToSelfFlg (printout CoreStream (FULLUSERNAME]
-                    (TERPRI CoreStream)
-                    (TERPRI CoreStream)
-                    (SELECTQ TypeOfArchive
-                        (ArchiveAll (printout CoreStream "Archive:  " Pattern)
-                                    (SETQ MakeRequestFLG T))
-                        (ArchiveAndDeleteAll 
-                             (printout CoreStream "ArchiveAndDelete:  " Pattern)
-                             (SETQ MakeRequestFLG T))
-                        ((Archive ArchiveAndDelete) 
-                             (for CedarFileName in CedarFileNameList when CedarFileName
-                                do (SELECTQ TypeOfArchive
-                                           (Archive (printout CoreStream "Archive:  " CedarFileName T
-                                                           ))
-                                           (ArchiveAndDelete 
-                                                (printout CoreStream "ArchiveAndDelete:  " 
-                                                       CedarFileName T))
-                                           (SHOULDNT))
-                                      (SETQ MakeRequestFLG T)))
-                        (SHOULDNT)) 
-
-(* ;;; "Send the mail off thru the Grapevine")
-
-                    (if MakeRequestFLG
-                        then (SETQ CoreStream (OPENTEXTSTREAM CoreStream NIL NIL NIL
-                                                         (LIST 'FONT LAFITEEDITORFONT)))
-                              (ADD.PROCESS (LIST (FUNCTION \SENDMESSAGE)
-                                                 (KWOTE CoreStream))
-                                     'NAME
-                                     'ArchiveRequest])
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS Arch.CcToSelfFlg Arch.VerifyNotArchivedFlg OKCedarCharBitTable)
-)
-
-(RPAQ OKCedarCharBitTable
-      [MAKEBITTABLE (APPEND (CHARCODE (%. $ - + * < > { }))
-                           (for i from (CHARCODE a)
-                                to
-                                (CHARCODE z)
-                                collect i)
-                           (for i from (CHARCODE A)
-                                to
-                                (CHARCODE Z)
-                                collect i)
-                           (CHARCODE (0 1 2 3 4 5 6 7 8 9])
-
-(RPAQ? Arch.CcToSelfFlg T)
-
-(RPAQ? Arch.VerifyNotArchivedFlg NIL)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(ADDTOVAR BackgroundMenuCommands (ArchiveBrowser '(ARCHIVEBROWSER)
-                                            "Brings up an archive browser"))
-
-
-(SETQ BackgroundMenu)
-)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-
-(FILESLOAD (SOURCE)
-       TABLEBROWSERDECLS)
-
-
-(FILESLOAD (LOADCOMP)
-       FILEBROWSER)
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-[if (NOT (SASSOC "Archive" FB.MENU.ITEMS))
-    then (PUTASSOC "Archive" '(FB.ArchiveCommand 
-                                         "Archives selected files by sending mail to Archivist.pa"
-                                         (SUBITEMS ("Archive" FB.ArchiveCommand 
-                                            "Archives selected files by sending mail to Archivist.pa"
-                                                          )
-                                                ("Archive ALL Files" FB.ArchiveAllCommand 
-                                  "Archives ALL files in the browser by sending mail to Archivist.pa"
-                                                       )
-                                                ("Archive and Delete" FB.ArchiveAndDeleteCommand 
-                   "Archives selected files by sending an Archive and Delete request to Archivist.pa"
-                                                       )
-                                                ("Archive and Delete ALL Files" 
-                                                       FB.ArchiveAndDeleteAllCommand 
-         "Archives ALL files in the browser by sending an Archive and Delete request to Archivist.pa"
-                                                       )))
-                    FB.MENU.ITEMS)
-  else (RPLACD (SASSOC "Archive" FB.MENU.ITEMS)
-                  '(FB.ArchiveCommand "Archives selected files by sending mail to Archivist.pa"
-                          (SUBITEMS ("Archive" FB.ArchiveCommand 
-                                           "Archives selected files by sending mail to Archivist.pa")
-                                 ("Archive ALL Files" FB.ArchiveAllCommand 
-                                  "Archives ALL files in the browser by sending mail to Archivist.pa"
-                                        )
-                                 ("Archive and Delete" FB.ArchiveAndDeleteCommand 
-                   "Archives selected files by sending an Archive and Delete request to Archivist.pa"
-                                        )
-                                 ("Archive and Delete ALL Files" FB.ArchiveAndDeleteAllCommand 
-         "Archives ALL files in the browser by sending an Archive and Delete request to Archivist.pa"
-                                        ]
-)
-
-
-
-(* Functions that aren't used any more)
-
-(DEFINEQ
-
-(Arch.ParseReturnMsg
-  [LAMBDA (Window)                                           (* bvm%: "19-Sep-85 12:32")
-
-         (* * Parse an archive response msg contained in Window.
-         Returns a list of the files archived.)
-
-    (PROG (TextObj TextStream CHAR#)
-          (RETURN
-           (COND
-              ((WINDOWP Window)
-               (SETQ TextObj (WINDOWPROP Window 'TEXTOBJ))
-               (SETQ TextStream (WINDOWPROP Window 'TEXTSTREAM))
-               (SETQ CHAR# 0)
-               (while (SETQ CHAR# (TEDIT.FIND TextStream "Archived:" (ADD1 CHAR#)))
-                  collect (PACKFILENAME 'BODY
-                                 (U-CASE (PACKC (DSUBLIS (CHARCODE (("[" . "{")
-                                                                    ("]" . "}")))
-                                                       (PROGN (SETFILEPTR TextStream CHAR#)
-                                                              (READ TextStream)
-                                                              (until (NEQ (PEEKC TextStream)
-                                                                          '% )
-                                                                 do (BIN TextStream))
-                                                              (until (EQ (PEEKC TextStream)
-                                                                         '% )
-                                                                 collect (BIN TextStream])
-
-(Arch.BackgroundMenuFn
-  [LAMBDA NIL                                                (* fgh%: " 6-Feb-85 01:03")
-
-         (* * Archive tool called from background menu.
-         Get from the user a window containing an archive system response message, parse 
-         the messsage, and delete the archived files.)
-
-    (PROG (Window PromptWindow FileList)
-          (PROMPTPRINT "Click in the window containing the response from Archivist.pa")
-          (SETQ Window (WHICHW (GETPOSITION)))
-          (CLRPROMPT)
-          (COND
-             ([AND (WINDOWP Window)
-                   (TEXTSTREAMP (WINDOWPROP Window 'TEXTSTREAM]
-              (SETQ FileList (Arch.ParseReturnMsg Window))
-              (COND
-                 [FileList (SETQ PromptWindow (GETPROMPTWINDOW Window 5))
-                        (COND
-                           ((MEMBER (PROMPTFORWORD "Okay to delete files? " "Yes" NIL PromptWindow)
-                                   '("Yes" "yes" "Y" "y"))
-                            (CLEARW PromptWindow)
-                            (bind Deleted? for File in FileList
-                               do (SETQ Deleted? (DELFILE File))
-                                  (printout PromptWindow (CONCAT File (COND
-                                                                         (Deleted? "  deleted.")
-                                                                         (T "  not deleted.")))
-                                         T)
-                                  (DISMISS 500))
-                            (printout PromptWindow "Deletions Completed" T)
-                            (DISMISS 2000)
-                            (REMOVEPROMPTWINDOW Window]
-                 (T (SETQ PromptWindow (GETPROMPTWINDOW Window 1))
-                    (printout PromptWindow "No archived files found in message.")
-                    (DISMISS 2000)
-                    (REMOVEPROMPTWINDOW Window])
-)
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA AB)
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA )
-)
-(PUTPROPS ARCHIVETOOL COPYRIGHT ("Xerox Corporation" 1985 1986 1988 1989))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (7582 15419 (ARCHIVEBROWSER 7592 . 15136) (AB 15138 . 15417)) (15467 38810 (
-AB.When.Selected.Fn 15477 . 15895) (AB.Command.Fn 15897 . 17465) (AB.Delete.Command 17467 . 18090) (
-AB.Expunge.Command 18092 . 21221) (AB.Filter.Command 21223 . 21826) (AB.Recompute.Command 21828 . 
-25391) (AB.Retrieve.Command 25393 . 28482) (AB.Retrieve.Directory.Command 28484 . 32193) (
-AB.Retrieve.Renamed.Command 32195 . 34005) (AB.Retrieve.Renamed.Aux 34007 . 35508) (AB.Sort.Command 
-35510 . 37893) (AB.Undelete.Command 37895 . 38808)) (38853 48488 (AB.Set.Browser.Title 38863 . 39473) 
-(AB.Iconfn 39475 . 40325) (AB.Closefn 40327 . 41097) (AB.Printfn 41099 . 42508) (AB.Prompt.For.Input 
-42510 . 44744) (AB.Read.Directory 44746 . 47727) (AB.Subitemp 47729 . 48164) (AB.Make.Cedar.Filename 
-48166 . 48486)) (52285 70125 (Arch.ConvertToCedarFileName 52295 . 56895) (FB.ArchiveCommand 56897 . 
-57174) (FB.ArchiveAllCommand 57176 . 57465) (FB.ArchiveAndDeleteCommand 57467 . 57789) (
-FB.ArchiveAndDeleteAllCommand 57791 . 58120) (FB.DoArchiveCommands 58122 . 70123)) (73559 77045 (
-Arch.ParseReturnMsg 73569 . 75078) (Arch.BackgroundMenuFn 75080 . 77043)))))
-STOP
diff --git a/obsolete/lispusers/ARCHIVETOOL.LCOM b/obsolete/lispusers/ARCHIVETOOL.LCOM
deleted file mode 100644
index 28243eeb..00000000
Binary files a/obsolete/lispusers/ARCHIVETOOL.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/BIGGER-FONT b/obsolete/lispusers/BIGGER-FONT
deleted file mode 100644
index c403cbce..00000000
--- a/obsolete/lispusers/BIGGER-FONT
+++ /dev/null
@@ -1,33 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "26-Jan-89 11:18:56" {QV}<PEDERSEN>LISP>BIGGER-FONT.;5 2459   
-
-      changes to%:  (VARS BIGGER-FONTCOMS)
-
-      previous date%: "25-Jan-89 12:04:51" {QV}<PEDERSEN>LISP>BIGGER-FONT.;4)
-
-
-(* "
-Copyright (c) 1989 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT BIGGER-FONTCOMS)
-
-(RPAQQ BIGGER-FONTCOMS ((ALISTS (FONTDEFS BIGGER)) (DECLARE%: DONTEVAL@LOAD DOCOPY (APPENDVARS (FONTVARS (ARBUTTONFONT BIGFONT) (ARBOLDFONT BOLDFONT) (ARFONT TEXTFONT) (*WHO-LINE-NAME-FONT* BOLDFONT T) (*WHO-LINE-VALUE-FONT* DEFAULTFONT T) (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT DEFAULTFONT) (FB.MENUFONT MENUFONT) (LAFITEEDITORFONT TEXTFONT) (LAFITEENDOFMESSAGEFONT COMMENTFONT) (LAFITEMSGICONFONT LITTLEFONT) (LAFITEBROWSERFONT DEFAULTFONT) (LAFITEFIXEDWIDTHFONT NIL) (LAFITETITLEFONT BIGFONT) (LAFITEMENUFONT MENUFONT) (LAFITE.FOLDER.MENU.FONT MENUFONT) (LAFITEDISPLAYFONT TEXTFONT T) ((NLSETQ (SEDIT:RESET))) ((NLSETQ (FILEWATCHPROP (QUOTE FONT) TINYFONT))))) (P (IF (>= SCREENWIDTH 1400) THEN (FONTSET (QUOTE BIGGER) T))))))
-
-(ADDTOVAR FONTDEFS (BIGGER (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 12) (GACHA 8) (TERMINAL 8)) (ITALICFONT 1 (HELVETICA 12 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 12 BRR) (HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 10) (HELVETICA 6 MIR) (MODERN 8 MIR)) (TINYFONT 6 (GACHA 10) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 14 BRR) NIL (MODERN 10 BRR)) (MENUFONT 5 (HELVETICA 12)) (COMMENTFONT 6 (HELVETICA 12) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (TIMESROMAN 12) NIL (CLASSIC 10)))))
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(APPENDTOVAR FONTVARS (ARBUTTONFONT BIGFONT) (ARBOLDFONT BOLDFONT) (ARFONT TEXTFONT) (*WHO-LINE-NAME-FONT* BOLDFONT T)
- (*WHO-LINE-VALUE-FONT* DEFAULTFONT T) (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT DEFAULTFONT)
- (FB.MENUFONT MENUFONT) (LAFITEEDITORFONT TEXTFONT) (LAFITEENDOFMESSAGEFONT COMMENTFONT) (LAFITEMSGICONFONT LITTLEFONT)
- (LAFITEBROWSERFONT DEFAULTFONT) (LAFITEFIXEDWIDTHFONT NIL) (LAFITETITLEFONT BIGFONT) (LAFITEMENUFONT MENUFONT)
- (LAFITE.FOLDER.MENU.FONT MENUFONT) (LAFITEDISPLAYFONT TEXTFONT T) ((NLSETQ (SEDIT:RESET))) ((NLSETQ (FILEWATCHPROP (QUOTE FONT) TINYFONT)))
-)
-
-
-(IF (>= SCREENWIDTH 1400) THEN (FONTSET (QUOTE BIGGER) T))
-)
-(PUTPROPS BIGGER-FONT COPYRIGHT ("Xerox Corporation" 1989))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
diff --git a/obsolete/lispusers/BIGGER-FONT.LCOM b/obsolete/lispusers/BIGGER-FONT.LCOM
deleted file mode 100644
index ca58d19d..00000000
--- a/obsolete/lispusers/BIGGER-FONT.LCOM
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "31-Aug-94 14:46:03" ("compiled on " {DSK}<lispcore>lispusers>BIGGER-FONT.;1) 
"28-Jul-94 17:28:46" bcompl'd in "Medley 28-Jul-94 ..." dated "28-Jul-94 17:35:29")
(FILECREATED "26-Jan-89 11:18:56" {QV}<PEDERSEN>LISP>BIGGER-FONT.;5 2459 changes to%: (VARS 
BIGGER-FONTCOMS) previous date%: "25-Jan-89 12:04:51" {QV}<PEDERSEN>LISP>BIGGER-FONT.;4)
(PRETTYCOMPRINT BIGGER-FONTCOMS)
(RPAQQ BIGGER-FONTCOMS ((ALISTS (FONTDEFS BIGGER)) (DECLARE%: DONTEVAL@LOAD DOCOPY (APPENDVARS (
FONTVARS (ARBUTTONFONT BIGFONT) (ARBOLDFONT BOLDFONT) (ARFONT TEXTFONT) (*WHO-LINE-NAME-FONT* BOLDFONT
 T) (*WHO-LINE-VALUE-FONT* DEFAULTFONT T) (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (
FB.PROMPTFONT DEFAULTFONT) (FB.MENUFONT MENUFONT) (LAFITEEDITORFONT TEXTFONT) (LAFITEENDOFMESSAGEFONT 
COMMENTFONT) (LAFITEMSGICONFONT LITTLEFONT) (LAFITEBROWSERFONT DEFAULTFONT) (LAFITEFIXEDWIDTHFONT NIL)
 (LAFITETITLEFONT BIGFONT) (LAFITEMENUFONT MENUFONT) (LAFITE.FOLDER.MENU.FONT MENUFONT) (
LAFITEDISPLAYFONT TEXTFONT T) ((NLSETQ (SEDIT:RESET))) ((NLSETQ (FILEWATCHPROP (QUOTE FONT) TINYFONT))
))) (P (IF (>= SCREENWIDTH 1400) THEN (FONTSET (QUOTE BIGGER) T))))))
(ADDTOVAR FONTDEFS (BIGGER (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 12) (GACHA 8) (TERMINAL 8)) (
ITALICFONT 1 (HELVETICA 12 MIR) (GACHA 8 MIR) (MODERN 8 MIR)) (BOLDFONT 2 (HELVETICA 12 BRR) (
HELVETICA 8 BRR) (MODERN 8 BRR)) (LITTLEFONT 3 (HELVETICA 10) (HELVETICA 6 MIR) (MODERN 8 MIR)) (
TINYFONT 6 (GACHA 10) (GACHA 6) (TERMINAL 6)) (BIGFONT 4 (HELVETICA 14 BRR) NIL (MODERN 10 BRR)) (
MENUFONT 5 (HELVETICA 12)) (COMMENTFONT 6 (HELVETICA 12) (HELVETICA 8) (MODERN 8)) (TEXTFONT 7 (
TIMESROMAN 12) NIL (CLASSIC 10)))))
(APPENDTOVAR FONTVARS (ARBUTTONFONT BIGFONT) (ARBOLDFONT BOLDFONT) (ARFONT TEXTFONT) (
*WHO-LINE-NAME-FONT* BOLDFONT T) (*WHO-LINE-VALUE-FONT* DEFAULTFONT T) (FB.ICONFONT LITTLEFONT) (
FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT DEFAULTFONT) (FB.MENUFONT MENUFONT) (LAFITEEDITORFONT 
TEXTFONT) (LAFITEENDOFMESSAGEFONT COMMENTFONT) (LAFITEMSGICONFONT LITTLEFONT) (LAFITEBROWSERFONT 
DEFAULTFONT) (LAFITEFIXEDWIDTHFONT NIL) (LAFITETITLEFONT BIGFONT) (LAFITEMENUFONT MENUFONT) (
LAFITE.FOLDER.MENU.FONT MENUFONT) (LAFITEDISPLAYFONT TEXTFONT T) ((NLSETQ (SEDIT:RESET))) ((NLSETQ (
FILEWATCHPROP (QUOTE FONT) TINYFONT))))
(IF (>= SCREENWIDTH 1400) THEN (FONTSET (QUOTE BIGGER) T))
(PUTPROPS BIGGER-FONT COPYRIGHT ("Xerox Corporation" 1989))
NIL
\ No newline at end of file
diff --git a/obsolete/lispusers/COLOR b/obsolete/lispusers/COLOR
deleted file mode 100644
index 13695db2..00000000
--- a/obsolete/lispusers/COLOR
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10)
(FILECREATED "27-Jan-87 15:56:46" {ERIS}<IRIS>NEXT>COLOR.;2 65054  

      changes to%:  (VARS COLORCOMS EditColorMapHeight EditColorMapWidth DICOLOR.hueMapping 
                          DICOLOR.lightnessMapping DICOLOR.saturationMapping NEWCOLORITEM 
                          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 DICOLOR.saturationConstants DICOLOR.noSaturation 
                          DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid 
                          DICOLOR.lightnessConstants DICOLOR.black DICOLOR.veryDark DICOLOR.dark 
                          DICOLOR.medium DICOLOR.light DICOLOR.veryLight DICOLOR.white)
                    (FNS DISPLAYCOLORLEVELS DISPLAYHLSLEVELS HLSLEVEL HLSTORGB HLSVALUEFN 
                         HLSVALUEFROMLEVEL LEVELFROMHLSVALUE RAINBOWMAP RGBTOHLS OVERPAINT 
                         BITMAPFROMSTRING SHADEBITMAP EDITCOLORMAP GETCOLOR#FROMUSER 
                         GETCOLOR#FROMSCREEN DISPLAYCOLORLEVEL FILLINREGION AREAFILL CENTEREDLEFT 
                         OUTLINEAREA OUTLINEREGION ADJUSTCOLORMAP SHOWCOLORBLOCKS MAPOFACOLOR 
                         CNSMENUINIT CNSTOCSL CNSTORGB CSLTOCNS DICOLOR.FROM.USER GETCNS HLSTOCSL 
                         CSLTOHLS RGBTOCNS DICOLOR.hueN DICOLOR.hueNvalue DICOLOR.hueNname 
                         DICOLOR.lightnessN DICOLOR.lightnessNvalue DICOLOR.lightnessNname 
                         DICOLOR.saturationN DICOLOR.saturationNvalue DICOLOR.saturationNname)
                    (RECORDS hueRecord lightnessRecord saturationRecord)

      previous date%: "16-Jan-87 18:20:53" {ERIS}<IRIS>NEXT>COLOR.;1)


(* "
Copyright (c) 1982, 1983, 1985, 1986, 1987 by 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.070 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.070 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 ("Xerox Corporation" 1982 1983 1985 1986 1987))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (5033 20085 (DISPLAYCOLORLEVELS 5043 . 6161) (DISPLAYHLSLEVELS 6163 . 6503) (HLSLEVEL 
6505 . 7240) (HLSTORGB 7242 . 8671) (HLSVALUEFN 8673 . 9550) (HLSVALUEFROMLEVEL 9552 . 9884) (
LEVELFROMHLSVALUE 9886 . 10223) (RAINBOWMAP 10225 . 17234) (RGBTOHLS 17236 . 20083)) (20086 21872 (
OVERPAINT 20096 . 20857) (BITMAPFROMSTRING 20859 . 21349) (SHADEBITMAP 21351 . 21870)) (21910 38520 (
EDITCOLORMAP 21920 . 23139) (EDITCOLORMAP.BUTTONEVENTFN 23141 . 26871) (EDITCOLORMAP.REDISPLAYFN 26873
 . 29232) (EDITCOLORMAP.VALUELEVEL 29234 . 29727) (EDITCOLORMAP.WINDOWLEVEL 29729 . 30232) (
CHANGECOLORLEVELS 30234 . 32361) (GETCOLOR#FROMUSER 32363 . 33681) (GETCOLOR#FROMSCREEN 33683 . 34241)
 (DISPLAYCOLORLEVEL 34243 . 35667) (FILLINREGION 35669 . 36136) (AREAFILL 36138 . 36400) (CENTEREDLEFT
 36402 . 36728) (OUTLINEAREA 36730 . 37959) (OUTLINEREGION 37961 . 38518)) (38521 45894 (
ADJUSTCOLORMAP 38531 . 39051) (SHOWCOLORBLOCKS 39053 . 40520) (MAPOFACOLOR 40522 . 42173) (
COLORHEXPATTERN 42175 . 45892)) (46360 55962 (CNSMENUINIT 46370 . 47005) (CNSTOCSL 47007 . 48269) (
CNSTORGB 48271 . 48518) (CSLTOCNS 48520 . 49593) (DICOLOR.FROM.USER 49595 . 51354) (GETCNS 51356 . 
51560) (HLSTOCSL 51562 . 55062) (CSLTOHLS 55064 . 55732) (RGBTOCNS 55734 . 55960)) (58806 61057 (
DICOLOR.hueN 58816 . 59134) (DICOLOR.hueNvalue 59136 . 59315) (DICOLOR.hueNname 59317 . 59494) (
DICOLOR.lightnessN 59496 . 59844) (DICOLOR.lightnessNvalue 59846 . 60043) (DICOLOR.lightnessNname 
60045 . 60240) (DICOLOR.saturationN 60242 . 60653) (DICOLOR.saturationNvalue 60655 . 60855) (
DICOLOR.saturationNname 60857 . 61055)))))
STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/COLOROBJ b/obsolete/lispusers/COLOROBJ
deleted file mode 100644
index b4b09e9d..00000000
--- a/obsolete/lispusers/COLOROBJ
+++ /dev/null
@@ -1,166 +0,0 @@
-(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
diff --git a/obsolete/lispusers/COLOROBJ.LCOM b/obsolete/lispusers/COLOROBJ.LCOM
deleted file mode 100644
index 985e4893..00000000
Binary files a/obsolete/lispusers/COLOROBJ.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/COLOROBJ.TEDIT b/obsolete/lispusers/COLOROBJ.TEDIT
deleted file mode 100644
index 9be15d91..00000000
Binary files a/obsolete/lispusers/COLOROBJ.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/EDITKEYS b/obsolete/lispusers/EDITKEYS
deleted file mode 100644
index f221788d..00000000
--- a/obsolete/lispusers/EDITKEYS
+++ /dev/null
@@ -1,141 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
-(FILECREATED " 4-Dec-2023 21:06:15" {WMEDLEY}<lispusers>EDITKEYS.;6 7146   
-
-      :EDIT-BY rmk
-
-      :CHANGES-TO (VARS EDITKEYSCOMS)
-
-      :PREVIOUS-DATE "25-Oct-2022 10:58:27" {WMEDLEY}<lispusers>EDITKEYS.;5)
-
-
-(PRETTYCOMPRINT EDITKEYSCOMS)
-
-(RPAQQ EDITKEYSCOMS
-       ((VARS KEY.TEMPLATE)
-        (FNS BUILDFNKEYS KEY.BITMAP)
-        (P                                                   (* ; "could have (STRIKEOUT)")
-                                                             (* ; "RMK:  Removed (HELP HELP)")
-           (BUILDFNKEYS '((BOLD BOLD)
-                          (ITALICS ITALICS)
-                          (CASE CASE)
-                          (STRIKEOUT (STRIKE- OUT))
-                          (UNDERLINE (UNDER- LINE))
-                          (SUPERSCRIPT (SUPER/ SUB))
-                          (LARGER (LARGER SMALLER))
-                          (DEFAULTS DEFAULTS)
-                          (CENTER JUSTIFY)
-                          (AGAIN REDO))
-                  '(Tedit Keys)
-                  1))))
-
-(RPAQQ KEY.TEMPLATE #*(78 48)OOOOOOOOOOOOOOOOOOOLON@@@@@@@@@@@@@@@AOLO@@@@@@@@@@@@@@@@@CLO@@@@@@@@@@@@@@@@@CLMH@@@@@@@@@@@@@@@@DLNLGOOOOOOOOOOOOOOHHLMFL@@@@@@@@@@@@@@M@LJK@@@@@@@@@@@@@@@B@DMF@@@@@@@@@@@@@@@A@DJN@@@@@@@@@@@@@@@AHDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMF@@@@@@@@@@@@@@@AHDJJ@@@@@@@@@@@@@@@A@DMG@@@@@@@@@@@@@@@B@DNEL@@@@@@@@@@@@@@O@LLIGOOOOOOOOOOOOOOMHLOBBJJJJJJJJJJJJJJJLLNDEEEEEEEEEEEEEEEEGLOHJJJJJJJJJJJJJJJJKLOLEEEEEEEEEEEEEEEEOLOOOOOOOOOOOOOOOOOOOL
-)
-(DEFINEQ
-
-(BUILDFNKEYS
-  [LAMBDA (KEYS TITLE NROWS)
-
-    (* ;; "Edited 20-Jul-2022 08:40 by rmk:  BKSYSBUF only if the TTY is TEDIT, change title to Tedit Keys, expand with left button.  Move with background menu")
-
-    (* ;; "Edited 20-Jul-2022 07:56 by rmk")
-                                                             (* lmm " 5-Nov-85 15:35")
-    (LET
-     (ICONWINDOW)
-     [SETQ ICONWINDOW
-      (SHRINKW
-       (ADDMENU
-        [create
-         MENU
-         ITEMS _
-         [for KEY in KEYS
-            collect
-            (LIST (KEY.BITMAP (CADR KEY))
-                  (LET [(KEYN (OR (SMALLP (CAR KEY))
-                                  (\KEYNAMETONUMBER (CAR KEY]
-                       (for LST in (LIST \DOVEKEYACTIONS \DLIONKEYACTIONS \ORIGKEYACTIONS)
-                          do (AND [SETQ $$VAL (for KEY in LST
-                                                 when (EQ (OR (SMALLP (CAR KEY))
-                                                              (\KEYNAMETONUMBER (CAR KEY)))
-                                                          KEYN) do (RETURN (CADR KEY]
-                                  (RETURN (LIST (OR (SMALLP (CAR $$VAL))
-                                                    (CHARCODE.DECODE (CAR $$VAL)))
-                                                (OR (SMALLP (CADR $$VAL))
-                                                    (CHARCODE.DECODE (CADR $$VAL]
-         TITLE _ (SUBSTRING TITLE 2 -2)
-         MENUROWS _ NROWS
-         WHENSELECTEDFN _ (FUNCTION (LAMBDA (X)
-                                      (CL:WHEN (EQ '\TEDIT.PROCENTRYFN (FETCH (PROCESS PROCTTYENTRYFN
-                                                                                     ) OF (
-                                                                                          TTY.PROCESS
-                                                                                           )))
-                                          [BKSYSCHARCODE (if (SHIFTDOWNP 'SHIFT)
-                                                             then (CADR (CADR X))
-                                                           else (CAR (CADR X])]
-        NIL
-        (create POSITION
-               XCOORD _ (PLUS (DIFFERENCE (QUOTIENT SCREENWIDTH 2)
-                                     (QUOTIENT (TIMES (BITMAPWIDTH KEY.TEMPLATE)
-                                                      (LENGTH KEYS))
-                                            2))
-                              (TIMES 2 WBorder))
-               YCOORD _ 0))
-       (KEY.BITMAP TITLE)
-       '(0 . 0]
-     [WINDOWPROP ICONWINDOW 'BUTTONEVENTFN (FUNCTION (LAMBDA (ICONW)
-                                                       (CL:WHEN (LASTMOUSESTATE (OR LEFT MIDDLE))
-                                                           (CURSOR (PROG1 (CURSOR WAITINGCURSOR)
-                                                                          (EXPANDW ICONW))))]
-     ICONWINDOW])
-
-(KEY.BITMAP
-  [LAMBDA (X)                                                (* lmm " 5-Nov-85 14:04")
-    (PROG ((BITMAP (BITMAPCOPY KEY.TEMPLATE))
-           DS QUARTER REGION)
-          (SETQ DS (DSPCREATE BITMAP))
-          (DSPFONT MENUFONT DS)
-          (COND
-             ((LISTP X)
-          
-          (* this is supposed to have two labels, one on top of the other)
-
-              (SETQ QUARTER (IQUOTIENT (BITMAPHEIGHT BITMAP)
-                                   4))
-              (CENTERPRINTINREGION (CADR X)
-                     (SETQ REGION (create REGION
-                                         LEFT _ 0
-                                         BOTTOM _ QUARTER
-                                         WIDTH _ (BITMAPWIDTH BITMAP)
-                                         HEIGHT _ QUARTER))
-                     DS)
-              (replace BOTTOM of REGION with (ITIMES 2 QUARTER))
-              (CENTERPRINTINREGION (CAR X)
-                     REGION DS))
-             (T (CENTERPRINTINREGION X (create REGION
-                                              LEFT _ 0
-                                              BOTTOM _ 0
-                                              WIDTH _ (BITMAPWIDTH BITMAP)
-                                              HEIGHT _ (BITMAPHEIGHT BITMAP))
-                       DS)))
-          (RETURN BITMAP])
-)
-
-                                                             (* ; "could have (STRIKEOUT)")
-
-                                                             (* ; "RMK:  Removed (HELP HELP)")
-
-(BUILDFNKEYS '((BOLD BOLD)
-               (ITALICS ITALICS)
-               (CASE CASE)
-               (STRIKEOUT (STRIKE- OUT))
-               (UNDERLINE (UNDER- LINE))
-               (SUPERSCRIPT (SUPER/ SUB))
-               (LARGER (LARGER SMALLER))
-               (DEFAULTS DEFAULTS)
-               (CENTER JUSTIFY)
-               (AGAIN REDO))
-       '(Tedit Keys)
-       1)
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (2120 6542 (BUILDFNKEYS 2130 . 5158) (KEY.BITMAP 5160 . 6540)))))
-STOP
diff --git a/obsolete/lispusers/EDITKEYS.LCOM b/obsolete/lispusers/EDITKEYS.LCOM
deleted file mode 100644
index 98975a58..00000000
Binary files a/obsolete/lispusers/EDITKEYS.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/EDITKEYS.TEDIT b/obsolete/lispusers/EDITKEYS.TEDIT
deleted file mode 100644
index 32ed4d68..00000000
Binary files a/obsolete/lispusers/EDITKEYS.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/ENDNOTE b/obsolete/lispusers/ENDNOTE
deleted file mode 100644
index cdfda194..00000000
--- a/obsolete/lispusers/ENDNOTE
+++ /dev/null
@@ -1,419 +0,0 @@
-(FILECREATED "18-Feb-87 15:43:31" {SUMEX-AIM}PS:<TMAX.SOURCES>ENDNOTE.;4 15652  
-
-      changes to:  (FNS NOTE.BUTTONEVENTINFN)
-
-      previous date: "18-Feb-87 10:11:49" {SUMEX-AIM}PS:<GILMURRAY.LISP>ENDNOTE.;6)
-
-
-(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.)
-
-(PRETTYCOMPRINT ENDNOTECOMS)
-
-(RPAQQ ENDNOTECOMS ((* Developed under support from NIH grant RR-00785.)
-		      (* Written by Frank Gilmurray and Sami Shaio.)
-		      (FNS ADD.ENDNOTE INSERT.ENDNOTES INSERT.ENDNOTES.TEXT DELETE.ENDNOTES 
-			   NOTESREGIONP SET.ENDNOTE.STYLE MAP.ENDNOTE.LOOKS GET.ENDNOTE.FONTS)
-		      (FNS ENDNOTEP NOTE.PUTFN NOTE.GETFN NOTE.BUTTONEVENTINFN)
-		      (RECORDS ENDNOTEFONTS)
-		      (* * Allow user to edit Endnote text in another TEdit window.)
-		      (FNS AUX.TEDIT AUX.TEDIT.AFTERQUITFN AUX.TEDIT.TITLEMENUFN)
-		      (* * Delimit text between two markers known as REGION MARKERS.)
-		      (FNS REGMARKOBJ REGMARKOBJP REGMARK.DISPLAYFN REGMARK.IMAGEBOXFN REGMARK.PUTFN 
-			   REGMARK.GETFN REGMARK.BUTTONEVENTINFN)
-		      (RECORDS REGMARKOBJ)))
-
-
-
-(* Developed under support from NIH grant RR-00785.)
-
-
-
-
-(* Written by Frank Gilmurray and Sami Shaio.)
-
-(DEFINEQ
-
-(ADD.ENDNOTE
-  (LAMBDA (STREAM WINDOW)                                    (* fsg "17-Feb-87 10:47")
-
-          (* * Insert an ENDNOTE ImageObject as a superscript. Displayed as a number when updated.)
-
-
-    (LET ((NOBJ (NUMBEROBJ 'NOTE)))
-         (TEDIT.INSERT.OBJECT NOBJ STREAM)
-         (COND
-	   ((UPDATE? WINDOW)
-	     (UPDATE.NUMBEROBJS WINDOW 'ENDNOTEP))
-	   (T NIL))
-         (replace (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM of NOBJ)
-	    with (TEDIT.GETINPUT STREAM "Endnote text:"))
-         (TEDIT.PROMPTPRINT STREAM "" T))))
-
-(INSERT.ENDNOTES
-  (LAMBDA (STREAM WINDOW)                                    (* fsg "18-Feb-87 09:38")
-
-          (* * Inserts text of endnotes at the end of the TEdit document. The text is inserted between two Region marking 
-	  imageobjs.)
-
-
-    (LET* ((TEXTOBJ (TEXTOBJ STREAM))
-	   (LIST.OF.ENDNOTES (TSP.LIST.OF.OBJECTS TEXTOBJ 'ENDNOTEP))
-	   (CARETPOSITION (fetch CH# of (TEDIT.GETSEL STREAM))))
-          (DELETE.ENDNOTES STREAM)
-          (COND
-	    (LIST.OF.ENDNOTES (TEDIT.PROMPTPRINT STREAM 
-						  "Inserting notes at the end of the document..."
-						   T)
-			      (TEDIT.INSERT.OBJECT (REGMARKOBJ 'ENDNOTES
-								   'Endnotes-START)
-						     STREAM
-						     (ADD1 (fetch TEXTLEN of TEXTOBJ)))
-			      (TEDIT.LOOKS STREAM '(PROTECTED ON)
-					     (fetch TEXTLEN of TEXTOBJ)
-					     1)
-			      (TEDIT.INSERT STREAM (CONCAT (CHARACTER (CHARCODE EOL))
-							       "Notes"
-							       (CHARACTER (CHARCODE EOL)))
-					      (ADD1 (fetch TEXTLEN of TEXTOBJ))
-					      (fetch (ENDNOTEFONTS TITLE.FONT)
-						 of (GET.ENDNOTE.FONTS WINDOW))
-					      T)
-			      (INSERT.ENDNOTES.TEXT STREAM TEXTOBJ LIST.OF.ENDNOTES)
-			      (TEDIT.INSERT.OBJECT (REGMARKOBJ 'ENDNOTES
-								   'Endnotes-END)
-						     STREAM
-						     (ADD1 (fetch TEXTLEN of TEXTOBJ)))
-			      (TEDIT.LOOKS STREAM '(PROTECTED ON)
-					     (fetch TEXTLEN of TEXTOBJ)
-					     1)
-			      (TEDIT.PROMPTPRINT STREAM "done")
-			      (TEDIT.NORMALIZECARET TEXTOBJ (TEDIT.SETSEL STREAM CARETPOSITION 1))
-			      )
-	    (T NIL)))))
-
-(INSERT.ENDNOTES.TEXT
-  (LAMBDA (STREAM TEXTOBJ LIST.OF.ENDNOTES)                  (* fsg " 7-Jan-87 14:31")
-
-          (* * Here to print the text of each endnote.)
-
-
-    (LET ((TEXTLOOKS (fetch (ENDNOTEFONTS TEXT.FONT) of (GET.ENDNOTE.FONTS WINDOW))))
-         (for ENDNOTEOBJ in LIST.OF.ENDNOTES
-	    do (LET ((NUMSTRING (MKSTRING (fetch (NUMBEROBJ NUMSTRING)
-						 of (fetch OBJECTDATUM of (CAR ENDNOTEOBJ)))))
-		       (TEXT (fetch (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM
-									of (CAR ENDNOTEOBJ)))))
-		      (TEDIT.INSERT STREAM NUMSTRING (ADD1 (fetch TEXTLEN of TEXTOBJ))
-				      TEXTLOOKS T)
-		      (TEDIT.INSERT STREAM (CONCAT " " TEXT (CHARACTER (CHARCODE EOL)))
-				      (ADD1 (fetch TEXTLEN of TEXTOBJ))
-				      TEXTLOOKS T))))))
-
-(DELETE.ENDNOTES
-  (LAMBDA (STREAM)                                           (* fsg "18-Feb-87 09:11")
-
-          (* * Delete the Endnotes, i.e. delete the start/end REGMARK ImageObjects and all the text between them.)
-
-
-    (LET* ((TEXTOBJ (TEXTOBJ STREAM))
-	   (NOTEMARKER.LIST (TSP.LIST.OF.OBJECTS TEXTOBJ 'NOTESREGIONP))
-	   (NOTES.START (CADAR NOTEMARKER.LIST))
-	   (NOTES.END (CADADR NOTEMARKER.LIST)))
-          (AND NOTEMARKER.LIST (TEDIT.DELETE STREAM NOTES.START (IDIFFERENCE (ADD1 NOTES.END)
-										   NOTES.START))))))
-
-(NOTESREGIONP
-  (LAMBDA (IMOBJ)                                            (* fsg "26-Jan-87 09:41")
-    (AND (REGMARKOBJP IMOBJ)
-	   (EQ (fetch REGION.USE of (fetch OBJECTDATUM of IMOBJ))
-		 'ENDNOTES))))
-
-(SET.ENDNOTE.STYLE
-  (LAMBDA (STREAM WINDOW)                                    (* fsg " 9-Jan-87 09:18")
-
-          (* * Set the font of the ENDNOTE number, title, or text.)
-
-
-    (LET ((NOTE.FONTS (GET.ENDNOTE.FONTS WINDOW))
-	  (NOTE.TYPE (MENU (create MENU
-				       TITLE _ "ENDNOTE Fonts"
-				       CENTERFLG _ T
-				       ITEMS _ '(Number Title Text))))
-	  OLD.FONT NEW.FONT)
-         (AND NOTE.TYPE (PROGN (SETQ OLD.FONT (SELECTQ NOTE.TYPE
-							       (Number (fetch (ENDNOTEFONTS 
-										      NUMBER.FONT)
-									  of NOTE.FONTS))
-							       (Title (fetch (ENDNOTEFONTS 
-										       TITLE.FONT)
-									 of NOTE.FONTS))
-							       (Text (fetch (ENDNOTEFONTS TEXT.FONT)
-									of NOTE.FONTS))
-							       NIL))
-				   (TEDIT.PROMPTPRINT STREAM (CONCAT "Change Endnote " NOTE.TYPE 
-									 " font "
-									 (LIST (ABBREVIATE.FONT
-										   OLD.FONT))
-									 " to...")
-							T)
-				   (SETQ NEW.FONT (FONTCREATE (GET.TSP.FONT WINDOW OLD.FONT)))
-				   (COND
-				     ((NEQ OLD.FONT NEW.FONT)
-				       (SELECTQ NOTE.TYPE
-						  (Number (replace (ENDNOTEFONTS NUMBER.FONT)
-							     of NOTE.FONTS with NEW.FONT))
-						  (Title (replace (ENDNOTEFONTS TITLE.FONT)
-							    of NOTE.FONTS with NEW.FONT))
-						  (Text (replace (ENDNOTEFONTS TEXT.FONT)
-							   of NOTE.FONTS with NEW.FONT))
-						  NIL)
-				       (AND (EQ NOTE.TYPE 'Number)
-					      (MAP.ENDNOTE.LOOKS STREAM NEW.FONT)))
-				     (T NIL))
-				   (TEDIT.PROMPTPRINT STREAM "" T))))))
-
-(MAP.ENDNOTE.LOOKS
-  (LAMBDA (STREAM NUMBERFONT)                                (* fsg " 9-Jan-87 09:09")
-
-          (* * Here to update the ENDNOTE looks. Only the ENDNOTE superscript numbers are updated.)
-
-
-    (LET ((LIST.OF.NOTES (TSP.LIST.OF.OBJECTS (TEXTOBJ STREAM)
-						'ENDNOTEP)))
-         (AND LIST.OF.NOTES (PROGN (TEDIT.PROMPTPRINT STREAM "Updating ENDNOTE Number looks..." 
-							    T)
-				       (for NOTE/CH# in LIST.OF.NOTES
-					  do (TEDIT.LOOKS STREAM NUMBERFONT (CADR NOTE/CH#)
-							      1))
-				       (TEDIT.PROMPTPRINT STREAM "done."))))))
-
-(GET.ENDNOTE.FONTS
-  (LAMBDA (WINDOW)                                           (* fsg " 5-Jan-87 10:40")
-
-          (* * Setup the default ENDNOTE fonts for number, title, and text.)
-
-
-    (OR (WINDOWPROP WINDOW 'ENDNOTE.FONTS)
-	  (PROGN (WINDOWPROP WINDOW 'ENDNOTE.FONTS
-				 (create ENDNOTEFONTS
-					   NUMBER.FONT _ GP.DefaultFont
-					   TITLE.FONT _ GP.DefaultFont
-					   TEXT.FONT _ GP.DefaultFont))
-		   (WINDOWPROP WINDOW 'ENDNOTE.FONTS)))))
-)
-(DEFINEQ
-
-(ENDNOTEP
-  (LAMBDA (IMOBJ)                                            (* ss: " 2-Jul-85 16:51")
-    (AND (NUMBEROBJP IMOBJ)
-	   (EQ (fetch USE of (fetch OBJECTDATUM of IMOBJ))
-		 'NOTE))))
-
-(NOTE.PUTFN
-  (LAMBDA (NUMBEROBJ STREAM WINDOW)                        (* fsg "28-Jan-87 13:48")
-
-          (* * Used to put a numberobj that is functioning as an endnote.)
-
-
-    (replace (NUMBEROBJ FONT) of (fetch OBJECTDATUM of NUMBEROBJ)
-       with (for NOTEFONT in (GET.ENDNOTE.FONTS WINDOW) collect (LIST.FONT.PROPS NOTEFONT)
-		     ))
-    (PRIN4 (LIST 'Endnote
-		     (IMAGEOBJPROP NUMBEROBJ 'TAG)
-		     (fetch OBJECTDATUM of NUMBEROBJ))
-	     STREAM)))
-
-(NOTE.GETFN
-  (LAMBDA (NEWOBJ USE/TEXT WINDOW)                           (* fsg " 8-Jan-87 10:19")
-
-          (* * Used to get a numberobj that is functioning as an endnote.)
-
-
-    (WINDOWPROP WINDOW 'ENDNOTE.FONTS
-		  (for NOTEFONT in (fetch (NUMBEROBJ FONT) of USE/TEXT)
-		     collect (FONTCREATE NOTEFONT)))
-    (replace (NUMBEROBJ FONT) of USE/TEXT with NIL)
-    (replace OBJECTDATUM of NEWOBJ with USE/TEXT)
-    NEWOBJ))
-
-(NOTE.BUTTONEVENTINFN
-  (LAMBDA (NUMBEROBJ STREAM)                               (* fsg "18-Feb-87 11:16")
-
-          (* * Bring up another TEdit window where user can edit the text of an Endnote.)
-
-
-    (MENU (create MENU
-		      TITLE _ 'Endnotes% Menu
-		      CENTERFLG _ T
-		      ITEMS _ '((Edit% Endnote (AUX.TEDIT NUMBEROBJ
-							  (CONCAT "Endnote #"
-								  (fetch NUMSTRING of
-									 (fetch OBJECTDATUM of 
-										NUMBEROBJ)))
-							  STREAM))
-				(Tag% Endnote (XREF.TAG.OBJECT NUMBEROBJ STREAM)))))))
-)
-[DECLARE: EVAL@COMPILE 
-
-(RECORD ENDNOTEFONTS (NUMBER.FONT TITLE.FONT TEXT.FONT))
-]
-(* * Allow user to edit Endnote text in another TEdit window.)
-
-(DEFINEQ
-
-(AUX.TEDIT
-  (LAMBDA (IMOBJ TITLE STREAM)                               (* fsg "20-Jan-87 15:46")
-
-          (* * Open a TEdit window where the user can view/edit the text of the selected Endnote.)
-
-
-    (LET* ((MAINWINDOW (\TEDIT.MAINW STREAM))
-	   (AUXWINDOW (CREATEW (WINDOWPROP MAINWINDOW 'AUXW.REGION)
-				 TITLE)))
-          (WINDOWPROP AUXWINDOW 'MAIN.WINDOW
-			MAINWINDOW)
-          (WINDOWPROP AUXWINDOW 'NOTE.IMAGEOBJ
-			IMOBJ)
-          (TEDIT (MKSTRING (fetch (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM
-									  of IMOBJ)))
-		   AUXWINDOW NIL '(AFTERQUITFN AUX.TEDIT.AFTERQUITFN TITLEMENUFN 
-					       AUX.TEDIT.TITLEMENUFN)))))
-
-(AUX.TEDIT.AFTERQUITFN
-  (LAMBDA (AUXWINDOW)                                        (* fsg "20-Jan-87 15:56")
-
-          (* * Here AFTER user finished with Endnote TEdit process.)
-
-
-    (LET ((MAINWINDOW (WINDOWPROP AUXWINDOW 'MAIN.WINDOW)))
-         (WINDOWPROP MAINWINDOW 'AUXW.REGION
-		       (WINDOWPROP AUXWINDOW 'REGION))
-         (GIVE.TTY.PROCESS MAINWINDOW)
-         (TEDIT.NORMALIZECARET (TEXTOBJ MAINWINDOW)))))
-
-(AUX.TEDIT.TITLEMENUFN
-  (LAMBDA (AUXWINDOW)                                        (* fsg "20-Jan-87 15:49")
-
-          (* * Here when left or middle button hit in title bar.)
-
-
-    (LET ((ITEM (MENU (create MENU
-				  CENTERFLG _ T
-				  ITEMS _ '(Save% Changes Abort% Changes)))))
-         (AND ITEM (PROGN (SELECTQ ITEM
-					 (Save% Changes (replace (NUMBEROBJ NUMBER.TEXT)
-							   of (fetch OBJECTDATUM
-								   of (WINDOWPROP AUXWINDOW
-										      'NOTE.IMAGEOBJ))
-							   with (COERCETEXTOBJ (TEXTSTREAM
-										     AUXWINDOW)
-										   'STRINGP)))
-					 NIL)
-			      (TEDIT.QUIT (TEXTSTREAM AUXWINDOW)))))))
-)
-(* * Delimit text between two markers known as REGION MARKERS.)
-
-(DEFINEQ
-
-(REGMARKOBJ
-  (LAMBDA (USE MARKING)                                      (* ss: "15-Jul-85 11:54")
-    (LET ((NEWOBJ (IMAGEOBJCREATE (create REGMARKOBJ
-					      REGION.USE _ USE
-					      MARKING _ MARKING)
-				    (IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN)
-						      (FUNCTION REGMARK.IMAGEBOXFN)
-						      (FUNCTION REGMARK.PUTFN)
-						      (FUNCTION REGMARK.GETFN)
-						      (FUNCTION NILL)
-						      (FUNCTION REGMARK.BUTTONEVENTINFN)
-						      (FUNCTION NILL)
-						      (FUNCTION NILL)
-						      (FUNCTION NILL)
-						      (FUNCTION NILL)
-						      (FUNCTION NILL)
-						      (FUNCTION NILL)
-						      (FUNCTION NILL)))))
-         (IMAGEOBJPROP NEWOBJ 'TYPE
-			 'REGMARKOBJ)
-     NEWOBJ)))
-
-(REGMARKOBJP
-  (LAMBDA (IMOBJ)                                            (* ss: "12-Jul-85 15:04")
-    (AND IMOBJ (EQ (IMAGEOBJPROP IMOBJ 'TYPE)
-		       'REGMARKOBJ))))
-
-(REGMARK.DISPLAYFN
-  (LAMBDA (OBJ STREAM)                                       (* fsg "18-Feb-87 09:18")
-
-          (* * REGMARK is just a marker, it doesn't actually display anything.)
-
-
-    NIL))
-
-(REGMARK.IMAGEBOXFN
-  (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN)                  (* fsg "17-Feb-87 10:22")
-
-          (* * REGMARK is just a marker, it doesn't actually display anything.)
-
-
-    (create IMAGEBOX
-	      XSIZE _ 0
-	      YSIZE _ 0
-	      YDESC _ 0
-	      XKERN _ 0)))
-
-(REGMARK.PUTFN
-  (LAMBDA (MARKOBJ STREAM)                                   (* fsg "28-Jan-87 14:10")
-    (PRIN2 (LIST 'Region
-		     (IMAGEOBJPROP MARKOBJ 'TAG)
-		     (LIST (fetch REGION.USE of (fetch OBJECTDATUM of MARKOBJ))
-			     (fetch MARKING of (fetch OBJECTDATUM of MARKOBJ))))
-	     STREAM)))
-
-(REGMARK.GETFN
-  (LAMBDA (STREAM)                                           (* fsg "28-Jan-87 16:06")
-    (OR (WINDOWPROP (PROCESSPROP (THIS.PROCESS)
-				       'WINDOW)
-			'IMAGEOBJ.MENUW)
-	  (TSP.FMMENU (TEXTSTREAM (PROCESSPROP (THIS.PROCESS)
-						     'WINDOW))))
-    (LET* ((REGMARK.ARGS (CDR (READ STREAM)))
-	   (NEWOBJ (APPLY 'REGMARKOBJ
-			    (CADR REGMARK.ARGS))))
-          (IMAGEOBJPROP NEWOBJ 'TAG
-			  (CAR REGMARK.ARGS))
-      NEWOBJ)))
-
-(REGMARK.BUTTONEVENTINFN
-  (LAMBDA (MARKOBJ STREAM)                                   (* fsg "18-Feb-87 10:07")
-
-          (* * This function is never called because the REGMARK ImageObjects are protected after they are inserted and 
-	  anything protected can't be selected.)
-
-
-    (AND (MOUSESTATE MIDDLE)
-	   (LET ((MARKDATUM (fetch OBJECTDATUM of MARKOBJ)))
-	        (TEDIT.PROMPTPRINT STREAM (CONCAT "Region used for " (fetch REGION.USE
-									    of MARKDATUM)
-						      (COND
-							((fetch MARKING of MARKDATUM)
-							  (CONCAT ", Marker is "
-								    (fetch MARKING of MARKDATUM)))
-							(T "")))
-				     T)))))
-)
-[DECLARE: EVAL@COMPILE 
-
-(RECORD REGMARKOBJ (REGION.USE MARKING))
-]
-(PUTPROPS ENDNOTE COPYRIGHT ("Leland Stanford Junior University" 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (1240 8234 (ADD.ENDNOTE 1252 . 1873) (INSERT.ENDNOTES 1877 . 3628) (INSERT.ENDNOTES.TEXT
- 3632 . 4538) (DELETE.ENDNOTES 4542 . 5135) (NOTESREGIONP 5139 . 5384) (SET.ENDNOTE.STYLE 5388 . 7086)
- (MAP.ENDNOTE.LOOKS 7090 . 7727) (GET.ENDNOTE.FONTS 7731 . 8231)) (8236 10115 (ENDNOTEP 8248 . 8477) (
-NOTE.PUTFN 8481 . 9034) (NOTE.GETFN 9038 . 9547) (NOTE.BUTTONEVENTINFN 9551 . 10112)) (10280 12228 (
-AUX.TEDIT 10292 . 11019) (AUX.TEDIT.AFTERQUITFN 11023 . 11495) (AUX.TEDIT.TITLEMENUFN 11499 . 12225)) 
-(12302 15479 (REGMARKOBJ 12314 . 13131) (REGMARKOBJP 13135 . 13328) (REGMARK.DISPLAYFN 13332 . 13548) 
-(REGMARK.IMAGEBOXFN 13552 . 13859) (REGMARK.PUTFN 13863 . 14228) (REGMARK.GETFN 14232 . 14759) (
-REGMARK.BUTTONEVENTINFN 14763 . 15476)))))
-STOP
diff --git a/obsolete/lispusers/EVAL-WHEN-PATCH b/obsolete/lispusers/EVAL-WHEN-PATCH
deleted file mode 100644
index 44523995..00000000
--- a/obsolete/lispusers/EVAL-WHEN-PATCH
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(filecreated " 2-Jun-87 14:51:46" {dsk}<lispfiles>work>eval-when-patch.\;1 30488  

      |changes| |to:|  (vars eval-when-patchcoms)
                       (fns addtocom delfromcom getdefcurrent importeval infilecom))


; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.

(prettycomprint eval-when-patchcoms)

(rpaqq eval-when-patchcoms ((fns addtocom delfromcom getdefcurrent importeval infilecom)))
(defineq

(addtocom
  (lambda (com name type near listname)                     (* \; "Edited  2-May-87 19:04 by Pavel")
                                                             (* \; 
                          "tries to insert NAME into the prettycom COM;  returns NIL if unsuccessful")

    (prog (tem)
          (cond
             ((and near (not (infilecoms? near type (list com))))
              (return)))
          (cond
             ((setq tem (|fetch| add |of| (car com)))
              (return (cond
                         ((or (null listname)
                              (infilecoms? listname 'filevars (list com)))
                          (and (setq tem (apply* tem com name type near))
                               (markaschanged comsname 'vars))
                          tem)))))
          (return
           (selectq (car com)
               (fns (and (eq type 'fns)
                         (addtocom1 com name near listname)))
               ((vars initvars) 
                    (cond
                       ((or (eq (car com)
                                'vars)
                            near listname)                   (* \; 
                                    "Don't stick on INITVARS unless NEAR or LISTNAME says we should.")

                        (selectq type
                            (expressions (cond
                                            ((eq (car name)
                                                 'setq)
                                             (addtocom1 com (cdr name)
                                                    near listname))))
                            (vars (addtocom1 com name near listname))
                            nil))))
               (coms (addtocoms (cond
                                   ((eq (cadr com)
                                        '*)
                                    (cond
                                       ((litatom (caddr com))
                                        (caddr com))
                                       (t (return))))
                                   (t (cdr com)))
                            name type near listname))
               (declare\: (and (or listname near)
                               (addtocoms (cond
                                             ((eq (cadr com)
                                                  '*)
                                              (cond
                                                 ((litatom (caddr com))
                                                  (caddr com))
                                                 (t (return))))
                                             (t (cdr com)))
                                      name type near listname)))
               (cl:eval-when (and (or listname near)
                                  (addtocoms (cond
                                                ((eq (cl:third com)
                                                     '*)
                                                 (cond
                                                    ((litatom (cl:fourth com))
                                                     (cl:fourth com))
                                                    (t (return))))
                                                (t (cddr com)))
                                         name type near listname)))
               ((prop ifprop) 
                    (selectq type
                        (props (cond
                                  ((eq (cadr com)
                                       (cadr name))
                                   (addtocom1 (cdr com)
                                          (car name)
                                          near listname))
                                  ((and (eq (car name)
                                            (caddr com))
                                        (null (cdddr com)))
                                   (/rplaca (cdr com)
                                          (union (mklist (cdr name))
                                                 (mklist (cadr com))))
                                   (markaschanged comsname 'vars)
                                   t)))
                        (macros (cond
                                   ((and (|for| prop |inside| (cadr com)
                                                |always|
                                                (eqmemb prop macroprops))
                                         (|for| prop |in| macroprops |always|
                                                (or (eqmemb prop (cadr com))
                                                    (not (getprop name prop)))))
          
          (* |;;| "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed")

                                    (addtocom1 (cdr com)
                                           name near listname))))
                        nil))
               ((props alists) 
                    (and (eq type (car com))
                         (addtocom1 com
                                (/nconc1 (or (assoc (car name)
                                                    (cond
                                                       ((eq (cadr com)
                                                            '*)
                                                        (cond
                                                           ((litatom (caddr com))
                                                            (and (or (null listname)
                                                                     (eq (caddr com)
                                                                         listname))
                                                                 (gettopval (caddr com))))
                                                           (t (return))))
                                                       (t (cdr com))))
                                             (list (car name)))
                                       (cadr name))
                                near listname)))
               (p (cond
                     ((and (eq type 'expressions)
                           (neq (car name)
                                'setq))
                      (addtocom1 com name near listname))))
               (and (eq (car com)
                        type)
                    (addtocom1 com name near listname)))))))

(delfromcom
  (lambda (com name type)                                   (* \; "Edited  2-May-87 19:02 by Pavel")
                                                             (* \; "Tries to delete NAME from COM")

    (prog (tem var new)
          (cond
             ((setq tem (|fetch| delete |of| (car com)))
              (and (setq tem (apply* tem com name type))
                   (markaschanged comsname 'vars))
              (return tem)))
          (return (selectq (car com)
                      ((declare\: coms) 
                           (delfromcoms (cond
                                           ((eq (cadr com)
                                                '*)
                                            (cond
                                               ((litatom (caddr com))
                                                (caddr com))
                                               (t (return))))
                                           (t (cdr com)))
                                  name type))
                      ((cl:eval-when) 
                           (delfromcoms (cond
                                           ((eq (cl:third com)
                                                '*)
                                            (cond
                                               ((litatom (cl:fourth com))
                                                (cl:fourth com))
                                               (t (return))))
                                           (t (cddr com)))
                                  name type))
                      ((alists props) 
                           (and (eq type (car com))
                                (cond
                                   ((eq (cadr com)
                                        '*)
                                    (cond
                                       ((and (litatom (setq var (caddr com)))
                                             (setq tem (assoc (car name)
                                                              (gettopval var)))
                                             (neq (cdr tem)
                                                  (setq tem (removeitem (cadr name)
                                                                   (cdr tem)))))
                                        (saveset var tem t 'noprint)
                                        t)))
                                   ((and (cdr (setq tem (assoc (car name)
                                                               (cdr com))))
                                         (neq (cdr tem)
                                              (setq new (removeitem (cadr name)
                                                               (cdr tem)))))
                                    (/rplacd tem new)
                                    (markaschanged comsname 'vars)
                                    t))))
                      (blocks 
          
          (* |;;| "Remove function name from blocks declarations.  This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.")

                              (and (eq type 'fns)
                                   (|for| block |in| (infilecomtail com t)
                                          |do|
                                          (and (memb name block)
                                               (/dremove name block))
                                          (|for| x |in| block |when| (and (listp x)
                                                                          (memb name (cdr x)))
                                                 |do|
                                                 (/rplacd x (remove name (cdr x)))))))
                      ((prop ifprop) 
                           (selectq type
                               (props (return (cond
                                                 ((eq (cadr com)
                                                      (cadr name))
                                                  (delfromcom1 (cdr com)
                                                         (car name)))
                                                 ((and (eqmemb (cadr name)
                                                              (cadr com))
                                                       (null (cdr (setq tem (prettycom1 (cdr com)))))
                                                       (eq (car tem)
                                                           (car name)))
                                                  (/rplaca (cdr com)
                                                         (remove (cadr name)
                                                                (mklist (cadr com))))
                                                  (markaschanged comsname 'vars)
                                                  t))))
                               (cond
                                  ((|for| prop |inside| (cadr com)
                                          |always|
                                          (eq type (getprop prop 'proptype)))
                                   (delfromcom1 (cdr com)
                                          name)))))
                      ((records initrecords sysrecords) 
                           (and (eq type 'records)
                                (delfromcom1 com name)))
                      (p (and (eq type 'expressions)
                              (delfromcom1 com name)))
                      ((vars initvars) 
                           (and (eq type 'vars)
                                (delfromcom1 com name t)))
                      (and (eq type (car com))
                           (delfromcom1 com name)))))))

(getdefcurrent
  (lambda (name type options)                               (* \; "Edited  2-May-87 19:00 by Pavel")
                                                             (* \; 
                                                             "Gets the current definition--source=0")

    (let
     (def)
     (cond
        ((and (setq def (|fetch| getdef |of| type))
              (neq def t))
          
          (* |;;| "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.")

         (or (neq (setq def (apply* def name type options))
                  (|fetch| nulldef |of| type))
             (getdeferr name type options))
         def)
        (t
         (or
          (neq
           (setq def
            (selectq type
                (fns (and (litatom name)
                          (exprp (setq def (virginfn name)))
                          def))
                (vars (|if| (litatom name)
                            |then|
                            (gettopval name)
                            |else|
                            'nobind))
                ((fields records) 
                     (|if| (litatom name)
                           |then|
                           (setq def (selectq type
                                         (records (reclook name))
                                         (mkprogn (fieldlook name))))
                           (|if| (eqmemb 'edit options)
                                 |then|
                                 (copy def)
                                 |else| def)))
                (files                                       (* \; 
                "what is the `definition' of a file?  -- I guess the COMS which say what it contains")

                       (|if| (litatom name)
                             |then|
                             (|if| (setq def (getfiledef name))
                                   |then|
                                   (updatefiles)
                                   (list (listp (gettopval (filecoms def)))
                                         (|fetch| tobedumped |of| (|fetch| fileprop |of| def))
                                         (listp (|fetch| filedates |of| def))))))
                (templates (|if| (and (litatom name)
                                      (setq def (gettemplate name)))
                                 |then|
                                 (list 'settemplate (kwote name)
                                       (kwote def))))
                (macros (|if| (and (litatom name)
                                   (setq def (|for| x |on| (getproplist name)
                                                    |by|
                                                    (cddr x)
                                                    |when|
                                                    (fmemb (car x)
                                                           macroprops)
                                                    |join|
                                                    (list (car x)
                                                          (cadr x)))))
                              |then|
                              `(putprops ,name ,@def)))
                (expressions (listp name))
                (props (and (listp name)
                            (and (setq def (some (getproplist (car name))
                                                 (function (lambda (x)
                                                             (eq x (cadr name))))
                                                 (function cddr)))
                                 (list 'putprops (car name)
                                       (cadr name)
                                       (cadr def)))))
                (filepkgcoms (and (litatom name)
                                  (prog ((com (filepkgcom name))
                                         (typ (filepkgtype name)))
                                        (return (cond
                                                   ((and com typ)
                                                    (list (cons 'com com)
                                                          (cons 'type typ)))
                                                   (com (list (cons 'com com)))
                                                   (typ (list (cons 'type typ))))))))
                (filevars (cond
                             ((and (litatom name)
                                   (listp (setq def (gettopval name)))
                                   (whereis name 'filevars))
                              def)
                             (t 'nobind)))
                (let
                 ((coms (list (makenewcom name type)))
                  file)
                 (cond
                    ((not (setq def (getdefcom coms)))
                     (with-reader-environment
                      *old-interlisp-read-environment*
                      (resetlst
                       (resetsave prettyflg)
                       (resetsave fontchangeflg)
                       (resetsave (output (setq file (openstream '{nodircore} 'both))))
                       (prettydefcoms coms)
                       (setfileptr file 0)
                       (setq def
                        (|for| x |in| (readfile file)
                               |join|
                               (selectq (car x)
                                   ((*) 
                                        nil)
                                   (declare\: (|for| y |on| (cdr x)
                                                     |unless|
                                                     (selectq (car y)
                                                         ((copywhen eval@loadwhen eval@compilewhen) 
                                                              (return (list y)))
                                                         (fmemb (car y)
                                                                declaretagslst))
                                                     |collect|
                                                     (car y)))
                                   (cl:eval-when (cddr x))
                                   (progn (cdr x))
                                   (list x))))
                       (setq nocopy t)))))
                 (mkprogn def))))
           (|fetch| nulldef |of| type))
          (getdeferr name type options))
         def)))))

(importeval
  (lambda (form returnflg)                                  (* \; "Edited  2-May-87 18:57 by Pavel")
          
          (* |;;| "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms")

    (and (listp form)
         (selectq (car form)
             (declare\: (for z in (cdr form)
                             join
                             (importeval z returnflg)))
             (cl:eval-when (for z in (cddr form)
                                join
                                (importeval z returnflg)))
             (/declaredatatype                               (* \; 
                      "Ignore datatype initializations -- we only need the record declaration itself")

                  nil)
             (progn                                          (* \; "default: eval and/or return it")

                    (and (neq returnflg t)
                         (eval form))
                    (and returnflg (list form)))))))

(infilecom
  (lambda (com)                                             (* \; "Edited  2-May-87 19:03 by Pavel")

    (cond
       ((nlistp com)
        (cond
           ((eq type 'vars)
            (infilecomsval com))))
       ((eq (car com)
            commentflg)
          
          (* |;;| 
 "must be special case'd first so that (* * values) doesn't make it look like `values' is a variable")
                                                             (* \; 
    "don't know why I should bother, but someone might want to know all of the comments on a file???")

        (cond
           ((eq type commentflg)
            (infilecomsval com t)))
        nil)
       (t
        (prog ((comname (car com))
               (tail (cdr com))
               cfn tem)
              (cond
                 ((cond
                     ((setq cfn (|fetch| (filepkgcom contents)
                                       |of| comname))
                      (setq tem (apply* cfn com (cond
                                                   ((and (null onfiletype)
                                                         (listp name))
                                                             (* \; 
                                                        "call from WHEREIS of a name which is a list")

                                                    (list name))
                                                   (t name))
                                       type onfiletype)))
                     ((setq cfn (|fetch| (filepkgcom prettytype)
                                       |of| comname))        (* \; "for compatability")

                      (setq tem (apply* cfn com type name))))
                  (cond
                     ((nlistp tem)
                      (cond
                         ((eq tem t)
                          (cond
                             ((or (eq name t)
                                  (null onfiletype))
                              (retfrom 'infilecoms? t))))))
                     (t (infilecomsvals tem))))
                 ((listp tail)
          
          (* |;;| "this SELECTQ handles the `exceptional cases' for the built in types.  There is an explicit RETURN in the SELECTQ clause if the default is handled")

                  (selectq comname
                      ((prop ifprop) 
                           (setq tail (cdr tail)))
                      nil)
                  (cond
                     ((eq (car tail)
                          '*)
                      (cond
                         ((litatom (cadr tail))
                          (selectq type
                              ((vars filevars) 
                                   (infilecomsval (cadr tail)))
                              nil))
                         ((and (listp (cadr tail))
                               (eq onfiletype 'update)
                               (eq type 'vars)
                               (eq (caadr tail)
                                   'progn)
                               (fmemb (car (last (cadr tail)))
                                      name))
                          (setq val (cons (cadr tail)
                                          val))))))
                  (selectq comname
                      ((coms export) 
                           (infilecoms (infilecomtail com)))
                      (cl:eval-when (infilecoms (infilecomtail (cdr com))))
                      (declare\:                             (* \; "skip over DECLARE: tags")

                                 (return (and (not (fmemb 'compilervars com))
                                              (ifcdeclare (infilecomtail com)
                                                     (eq type 'declare\:)))))
                      (original                              (* \; "dont expand macros")

                                (prog ((origflg t))
                                      (infilecoms (infilecomtail com))))
                      ((prop ifprop)                         (* \; 
                                         "this currently does not handle `pseudo-types' of PROPNAMES")

                           (selectq type
                               (props (ifcpropscan (infilecomtail (cdr com))
                                             (cadr com)))
                               (macros (infilecomsmacro (infilecomtail (cdr com))
                                              (cadr com)))
                               nil))
                      (props (return (ifcprops com)))
                      (macros (return (selectq type
                                          (props (ifcpropscan (infilecomtail com)
                                                        macroprops))
                                          (macros (infilecomsvals (infilecomtail com)))
                                          nil)))
                      (alists                                (* \; 
                        "sigh.  This should probably also `coerce' when asking for LISPXMACROS, etc.")

                              (return (selectq type
                                          (alists (infilepairs (infilecomtail com)))
                                          nil)))
                      (p (return (selectq type
                                     ((expressions p) 
                                          (infilecomsvals (infilecomtail com t)
                                                 t))
                                     (cond
                                        ((null onfiletype)   (* \; "for WHEREIS and FILECOMSLST")

                                         (selectq type
                                             (i.s.oprs (ifcexprtype com 'i.s.opr))
                                             (templates (ifcexprtype com 'settemplate))
                                             nil))))))
                      ((addvars appendvars) 
                           (selectq type
                               (vars (return (and (null onfiletype)
                                                  (|for| x |in| (infilecomtail com t)
                                                         |do|
                                                         (infilecomsval (car x)
                                                                t)))))
                               (alists (return (|for| x |in| (infilecomtail com)
                                                      |when|
                                                      (eqmemb 'alist (getprop (car x)
                                                                            'vartype))
                                                      |do|
                                                      (|for| z |in| (cdr x)
                                                             |do|
                                                             (infilecomsval (list (car x)
                                                                                  (car z))
                                                                    t)))))
                               (or (eq type comname)
                                   (return))))
                      ((vars initvars filevars uglyvars horriblevars constants array) 
                           (return (cond
                                      ((eq type 'expressions)
                                       (|for| x |in| (infilecomtail com)
                                              |when|
                                              (listp x)
                                              |do|
                                              (infilecomsval (cons 'setq x)
                                                     t)))
                                      ((or (eq type 'vars)
                                           (eq type comname))(* \; 
                     "either want all VARS, or else want all FILEVARS and this is a FILEVARS command")

                                       (|for| x |in| (infilecomtail com)
                                              |do|
                                              (cond
                                                 ((listp x)
                                                  (and (car x)
                                                       (infilecomsval (car x)
                                                              t)))
                                                 (x (infilecomsval x (eq comname 'initvars)))))))))
                      (defs (return (|for| x |in| (infilecomtail com)
                                           |when|
                                           (eq type (car x))
                                           |do|
                                           (infilecomsvals (cdr x)))))
                      (files (return))
                      nil)
          
          (* |;;| "Exceptional cases now handled.  If TYPE matches (CAR COM) then scan the tail as usual.  Else expand the com's MACRO, if it has one, unless there was a CONTENTS function")

                  (cond
                     ((eq comname type)
                      (infilecomsvals (infilecomtail com)))
                     ((and (or (null cfn)
                               (and (eq cfn t)
                                    (null onfiletype)))
                           (null origflg)
                           (setq tem (|fetch| (filepkgcom macro)
                                            |of| comname)))
                      (infilecoms (subpair (car tem)
                                         (infilecomtail com)
                                         (cdr tem))))))))))))
)
(putprops eval-when-patch copyright ("Xerox Corporation" 1987))
(declare\: dontcopy
  (filemap (nil (475 30395 (addtocom 485 . 7020) (delfromcom 7022 . 12896) (getdefcurrent 12898 . 19529)
 (importeval 19531 . 20542) (infilecom 20544 . 30393)))))
stop
\ No newline at end of file
diff --git a/obsolete/lispusers/FASTEDITBM b/obsolete/lispusers/FASTEDITBM
deleted file mode 100644
index fa5e7dda..00000000
--- a/obsolete/lispusers/FASTEDITBM
+++ /dev/null
@@ -1,1431 +0,0 @@
-(FILECREATED "16-Nov-87 17:15:41" {ERINYES}<LISPUSERS>KOTO>FASTEDITBM.;3 68144  
-
-      changes to:  (FNS EXPANDBITMAP)
-		   (VARS FASTEDITBMCOMS)
-
-      previous date: " 4-Sep-87 15:58:23" {ERINYES}<LISPUSERS>KOTO>FASTEDITBM.;2)
-
-
-(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT FASTEDITBMCOMS)
-
-(RPAQQ FASTEDITBMCOMS ((DECLARE: DONTCOPY (MACROS UPDATE/BM/DISPLAY))
-			 (P (SETQ EDITBMMENU NIL))
-			 (FNS GRID)
-			 (FNS EDITBM EDITBMCLOSEFN TILEAREA EDITBMBUTTONFN EDITBMSCROLLFN 
-			      \EDITBM/PUTUP/DISPLAY EDITBMRESHAPEFN EDITBMREPAINTFN.NEW 
-			      EDITBMREPAINTFN RESETGRID.NEW)
-			 (FNS SCALEBM BLTPATTERN BLTPATTERN.REPLACEDISPLAY)
-			 (FNS EXPANDBITMAP EXPANDBM)))
-(DECLARE: DONTCOPY 
-(DECLARE: EVAL@COMPILE 
-[PUTPROPS UPDATE/BM/DISPLAY MACRO ((BM W)
-	   (BITBLT BM (WINDOWPROP W (QUOTE DXOFFSET))
-		   (WINDOWPROP W (QUOTE DYOFFSET))
-		   W 0 (WINDOWPROP W (QUOTE BMDISPLAYBOTTOM))
-		   (WINDOWPROP W (QUOTE BMDISPLAYWIDTH))
-		   1000 NIL (QUOTE REPLACE]
-)
-)
-(SETQ EDITBMMENU NIL)
-(DEFINEQ
-
-(GRID
-  [LAMBDA (GRIDSPEC WIDTH HEIGHT BORDER DS GRIDSHADE)        (* N.H.Briggs " 4-Sep-87 15:39")
-                                                             (* ; "draws a grid")
-    (PROG ((X0 (fetch (REGION LEFT) of GRIDSPEC))
-	     (Y0 (fetch (REGION BOTTOM) of GRIDSPEC))
-	     (SQWIDTH (fetch (REGION WIDTH) of GRIDSPEC))
-	     (SQHEIGHT (fetch (REGION HEIGHT) of GRIDSPEC))
-	     (GRIDSHADE (COND
-			  ((TEXTUREP GRIDSHADE))
-			  (T BLACKSHADE)))
-	     LINELENGTH TWICEBORDER MAXIMUMCOLOR TOTALHEIGHT GRIDBM TEMPBM)
-	    (SETQ TOTALHEIGHT (ITIMES HEIGHT SQHEIGHT))
-	    (COND
-	      ((OR (ZEROP BORDER)
-		     (NULL BORDER))                        (* ; "don't draw anything.")
-		(RETURN))
-	      [(NUMBERP BORDER)
-		(SETQ TWICEBORDER (ITIMES BORDER 2))
-		(PROGN                                     (* ;; 
-							     
-"draw vertical lines use BITBLT so that we don't have to correct for the width of the line since line drawing will put the coordinate in the middle."
-)
-			 (BLTSHADE GRIDSHADE DS X0 Y0 BORDER TOTALHEIGHT (QUOTE REPLACE))
-			 (for X from (IDIFFERENCE (IPLUS X0 SQWIDTH)
-							BORDER)
-			    to (IDIFFERENCE (IPLUS X0 (ITIMES (SUB1 WIDTH)
-								      SQWIDTH))
-						BORDER)
-			    by SQWIDTH do (BLTSHADE GRIDSHADE DS X Y0 TWICEBORDER TOTALHEIGHT
-							  (QUOTE REPLACE)))
-			 (BLTSHADE GRIDSHADE DS (IDIFFERENCE (IPLUS X0 (ITIMES WIDTH SQWIDTH))
-								 BORDER)
-				     Y0 BORDER TOTALHEIGHT (QUOTE REPLACE)))
-		(PROGN                                     (* ; "draw horizontal lines")
-			 (BLTSHADE GRIDSHADE DS X0 Y0 (SETQ LINELENGTH (ITIMES WIDTH SQWIDTH))
-				     BORDER
-				     (QUOTE REPLACE))
-			 (for Y from (IDIFFERENCE (IPLUS Y0 SQHEIGHT)
-							BORDER)
-			    to (IDIFFERENCE (IPLUS Y0 (ITIMES (SUB1 HEIGHT)
-								      SQHEIGHT))
-						BORDER)
-			    by SQHEIGHT do (BLTSHADE GRIDSHADE DS X0 Y LINELENGTH TWICEBORDER
-							   (QUOTE REPLACE)))
-			 (BLTSHADE GRIDSHADE DS X0 (IDIFFERENCE (IPLUS Y0 TOTALHEIGHT)
-								    BORDER)
-				     LINELENGTH BORDER (QUOTE REPLACE]
-	      [(EQ BORDER (QUOTE POINT))                 (* ; 
-"put a point in the lower left corner of each box")
-		(if (WINDOWP DS)
-		    then (SETQ TEMPBM (WINDOWPROP DS (QUOTE TEMPBM)))
-			   (SETQ GRIDBM (WINDOWPROP DS (QUOTE GRIDBM)))
-			   (if (NOT GRIDBM)
-			       then (SETQ GRIDBM (BITMAPCREATE SQWIDTH SQHEIGHT))
-				      (WINDOWPROP DS (QUOTE GRIDBM)
-						    GRIDBM))
-			   (BLTSHADE WHITESHADE GRIDBM 0 0) 
-                                                             (* ; "Clear temporary bitmap.")
-			   (BLTSHADE BLACKSHADE GRIDBM 0 0 1 1 (QUOTE REPLACE)) 
-                                                             (* ; "Put spot down.")
-                                                             (* ; "Fill up temporary bitmap.")
-			   (BLTPATTERN GRIDBM 0 0 SQWIDTH SQHEIGHT DS X0 Y0 (ITIMES WIDTH SQWIDTH)
-					 (ITIMES HEIGHT SQHEIGHT)
-					 (QUOTE PAINT)
-					 TEMPBM)
-		  else [SETQ MAXIMUMCOLOR (SUB1 (EXPT 2 (BITSPERPIXEL (DSPDESTINATION
-										  NIL DS]
-                                                             (* ;; "Crufty slow original code.")
-			 (for X from X0 to (IPLUS X0 (ITIMES WIDTH SQWIDTH)) by SQWIDTH
-			    do (for Y from Y0 to (IPLUS Y0 TOTALHEIGHT) by SQHEIGHT
-				    do (BITMAPBIT DS X Y MAXIMUMCOLOR]
-	      (T (\ILLEGAL.ARG BORDER])
-)
-(DEFINEQ
-
-(EDITBM
-  [LAMBDA (BMSPEC)                                           (* N.H.Briggs " 4-Sep-87 15:39")
-                                                             (* ;;; "A simple bitmap editor.")
-                                                             (* ;; 
-							     
-"The edit part of the display is from 0 to MAXGRIDWIDTH in width and from 0 to MAXGRIDHEIGHT in height.  The commands and display area for the bitmap being edited are above the edit region."
-)
-    (DECLARE (GLOBALVARS SCREENWIDTH SCREENHEIGHT))
-    (PROG (BMW BMWINTERIOR BMWWIDTH BMWHEIGHT WIDTH HEIGHT BM CR ORIGBM GRIDSQUARE BPP ORIGBPP 
-		 ORIGWIDTH)                                  (* ; 
-							     
-"set ORIGBM to the input bitmap if any and BM to a copy of it for editting.")
-	    [COND
-	      ((OR (EQ BMSPEC CursorBitMap)
-		     (AND (EQ BMSPEC (QUOTE CursorBitMap))
-			    (SETQ BMSPEC CursorBitMap)))   (* ; 
-							     
-"editing cursor, save old value and make changes to the original.")
-		(SETQ ORIGBM (BITMAPCOPY CursorBitMap))
-		(SETQ BM CursorBitMap))
-	      [(BITMAPP BMSPEC)
-		(SETQ BM (BITMAPCOPY (SETQ ORIGBM BMSPEC]
-	      [(LITATOM BMSPEC)
-		(COND
-		  ([BITMAPP (SETQ ORIGBM (EVALV BMSPEC (QUOTE EDITBM]
-                                                             (* ; "use value.")
-		    (SETQ BM (BITMAPCOPY ORIGBM)))
-		  (T (SETQ ORIGBM NIL)
-		     (SETQ BM (\READBMDIMENSIONS]
-	      ((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]
-                                                             (* ; "note that bm has initial bits in it.")
-		(SETQ ORIGBM BMSPEC)
-		(BITBLT (SCREENBITMAP)
-			  (fetch (REGION LEFT) of BMSPEC)
-			  (fetch (REGION BOTTOM) of BMSPEC)
-			  BM 0 0 NIL NIL (QUOTE INPUT)
-			  (QUOTE REPLACE)))
-	      ((WINDOWP BMSPEC)
-		(SETQ ORIGBM BMSPEC)                       (* ;; 
-							     
-"FS: Seems too big below, why not ClipRegion's Width & Height?  That's all that's used...")
-		(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 (REGION LEFT) of CR)
-			  (fetch (REGION BOTTOM) of CR)
-			  BM 0 0 (fetch (REGION WIDTH) of CR)
-			  (fetch (REGION HEIGHT) of CR)))
-	      (T                                             (* ; "otherwise create a bitmap")
-		 (SETQ BM (\READBMDIMENSIONS]
-	    (if (OR (EQ (BITMAPHEIGHT BM)
-			      0)
-			(EQ (BITMAPWIDTH BM)
-			      0))
-		then (ERROR "Can't edit a bitmap with no bits in it." BMSPEC))
-	    (SETQ BPP (BITSPERPIXEL (SCREENBITMAP)))
-	    (SETQ ORIGBPP (fetch (BITMAP BITMAPBITSPERPIXEL) of BM))
-	    [COND
-	      ((NOT (EQ BPP ORIGBPP))                    (* ;; 
-							     
-"save the actual number of bits per pixel and set it to BPP in the bitmap being edited so that it can be BITBLT ed on the screen."
-)
-		(SETQ ORIGWIDTH (fetch (BITMAP BITMAPWIDTH) of BM))
-		(replace (BITMAP BITMAPBITSPERPIXEL) of BM with BPP)
-		(SETQ WIDTH (IQUOTIENT (ITIMES ORIGBPP ORIGWIDTH)
-					   BPP))
-		(replace (BITMAP BITMAPWIDTH) of BM with WIDTH))
-	      (T (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BM]
-	    (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM))
-                                                             (* ;; 
-							     
-"Calculate a default window size.  Start by calculating the grid size from the bitmap size.")
-	    (SETQ GRIDSQUARE (IMAX (IMIN (IQUOTIENT (IDIFFERENCE (IQUOTIENT (ITIMES
-											  SCREENWIDTH 
-											  2)
-											3)
-									   GRIDTHICKNESS)
-							    WIDTH)
-					       (IQUOTIENT (IDIFFERENCE (IQUOTIENT (ITIMES
-											  
-										     SCREENHEIGHT 2)
-											3)
-									   (ITIMES GRIDTHICKNESS 2))
-							    (ADD1 HEIGHT))
-					       NORMALGRIDSQUARE)
-				       MINGRIDSQUARE))
-	    (SETQ BMWWIDTH (IMIN (IPLUS (ITIMES GRIDSQUARE WIDTH)
-					      GRIDTHICKNESS)
-				     (IQUOTIENT (ITIMES SCREENWIDTH 2)
-						  3)))
-	    (SETQ BMWHEIGHT (IMIN (IPLUS (ITIMES HEIGHT (ADD1 GRIDSQUARE))
-					       (ITIMES GRIDTHICKNESS 2)
-					       1)
-				      (IQUOTIENT (ITIMES SCREENHEIGHT 2)
-						   3)))
-	    (SETQ BMW (CREATEW (GETBOXREGION (WIDTHIFWINDOW BMWWIDTH)
-						   (HEIGHTIFWINDOW BMWHEIGHT T)
-						   NIL NIL NIL 
-					      "Indicate the position for the Bitmap Edit window.")
-				   "Bitmap Editor"))
-	    (WINDOWPROP BMW (QUOTE BM)
-			  BM)
-	    (WINDOWPROP BMW (QUOTE SCROLLFN)
-			  (FUNCTION EDITBMSCROLLFN))
-	    (WINDOWPROP BMW (QUOTE RESHAPEFN)
-			  (FUNCTION EDITBMRESHAPEFN))
-	    (WINDOWPROP BMW (QUOTE REPAINTFN)
-			  (FUNCTION EDITBMREPAINTFN))
-	    (WINDOWPROP BMW (QUOTE BUTTONEVENTFN)
-			  (FUNCTION EDITBMBUTTONFN))
-	    (WINDOWPROP BMW (QUOTE CLOSEFN)
-			  (FUNCTION EDITBMCLOSEFN))
-	    (WINDOWPROP BMW (QUOTE XOFFSET)
-			  0)
-	    (WINDOWPROP BMW (QUOTE YOFFSET)
-			  0)
-	    (WINDOWPROP BMW (QUOTE DXOFFSET)
-			  0)
-	    (WINDOWPROP BMW (QUOTE DYOFFSET)
-			  0)
-	    (WINDOWPROP BMW (QUOTE ORIGINALBITMAP)
-			  ORIGBM)
-	    (WINDOWPROP BMW (QUOTE FINISHEDFLG)
-			  NIL)
-	    (WINDOWPROP BMW (QUOTE COLOR)
-			  (SUB1 (EXPT 2 BPP)))
-	    (WINDOWPROP BMW (QUOTE GRIDON)
-			  T)                                 (* ; 
-							     "call reshapefn to initialize the display and values")
-	    (EDITBMRESHAPEFN BMW NIL NIL NIL (NOT ORIGBM))
-                                                             (* ; 
-							     
-"start a mouse process in case this process is the mouse process.")
-	    (SPAWN.MOUSE)
-	    (while (NOT (WINDOWPROP BMW (QUOTE FINISHEDFLG))) do (DISMISS 500))
-                                                             (* ; "remove the closefn before closing the window.")
-	    (WINDOWPROP BMW (QUOTE CLOSEFN)
-			  NIL)
-	    (CLOSEW BMW)
-	    (COND
-	      ((NOT (EQ ORIGBPP BPP))
-		(replace (BITMAP BITMAPBITSPERPIXEL) of BM with ORIGBPP)
-		(replace (BITMAP BITMAPWIDTH) of BM with ORIGWIDTH)))
-	    (RETURN (COND
-			((EQ T (WINDOWPROP BMW (QUOTE FINISHEDFLG)))
-                                                             (* ; 
-							     
-"editor exited via ok, stuff contents into original bitmap.")
-			  (COND
-			    ((EQ BMSPEC CursorBitMap)      (* ; "editting happened in original, leave it alone.")
-			      CursorBitMap)
-			    ((REGIONP ORIGBM)              (* ; "put it back into the screen.")
-			      (BITBLT BM 0 0 (SCREENBITMAP)
-					(fetch (REGION LEFT) of ORIGBM)
-					(fetch (REGION BOTTOM) of ORIGBM)
-					(fetch (REGION WIDTH) of ORIGBM)
-					(fetch (REGION HEIGHT) of ORIGBM)
-					(QUOTE INPUT)
-					(QUOTE REPLACE))
-			      BM)
-			    ((WINDOWP ORIGBM)              (* ; "put it back into the window")
-			      (BITBLT BM 0 0 ORIGBM (fetch (REGION LEFT) of CR)
-					(fetch (REGION BOTTOM) of CR)
-					(fetch (REGION WIDTH) of CR)
-					(fetch (REGION HEIGHT) of CR)
-					(QUOTE INPUT)
-					(QUOTE REPLACE))
-			      BM)
-			    (ORIGBM (BITBLT BM 0 0 ORIGBM 0 0 WIDTH HEIGHT)
-				    [COND
-				      ((AND BMSPEC (LITATOM BMSPEC))
-                                                             (* ; 
-							     
-"if spec was an atom without a bm value, set it.  in the environment above EDITBM.")
-					(MARKASCHANGED BMSPEC (QUOTE VARS))
-					(STKEVAL (QUOTE EDITBM)
-						   (LIST (QUOTE SETQQ)
-							   BMSPEC BM]
-				    ORIGBM)
-			    (T BM)))
-			(T                                   (* ; 
-							     "error exit, if cursor return it to original value.")
-			   (COND
-			     ((EQ BMSPEC CursorBitMap)
-			       (BITBLT ORIGBM NIL NIL CursorBitMap)))
-			   (ERROR!])
-
-(EDITBMCLOSEFN
-  [LAMBDA (BMW)                                              (* ; "Edited 27-Aug-87 21:26 by FS")
-                                                             (* ;; 
-							     
-"the close function for a bitmap edit window.  For now do what a STOP would have done.")
-                                                             (* ;; 
-							     
-"FS:  Assuming this window won't be reused, flush the temporary bm.")
-    (WINDOWPROP BMW (QUOTE TEMPBM)
-		  NIL)
-    (WINDOWPROP BMW (QUOTE GRIDBM)
-		  NIL)
-    (WINDOWPROP BMW (QUOTE FINISHEDFLG)
-		  (QUOTE KILL])
-
-(TILEAREA
-  [LAMBDA (LFT BTM WDTH HGHT SRCBM WIN)                      (* ; "Edited 27-Aug-87 21:20 by FS")
-                                                             (* ;; 
-							     
-"lays tiles out in an area of a window.  This function only provided for backwards compatibility.")
-    (BLTPATTERN.REPLACEDISPLAY SRCBM 0 0 (BITMAPWIDTH SRCBM)
-				 (BITMAPHEIGHT SRCBM)
-				 WIN LFT BTM WDTH HGHT])
-
-(EDITBMBUTTONFN
-  [LAMBDA (W)                                                (* N.H.Briggs " 4-Sep-87 15:30")
-                                                             (* ;; "inner function of bitmap editor.")
-    (DECLARE (GLOBALVARS \CURRENTCURSOR))
-    (PROG (GRIDX0 GRIDY0 BITMAPWIDTH BITMAPHEIGHT NEWGRIDSIZE PAINTW ORIGBM GRIDSPEC GRIDINTERIOR 
-		    BM BITSWIDE BITSHIGH WREGION XOFFSET YOFFSET DXOFFSET DYOFFSET DISPLAYREGION 
-		    EXTENT BITSPERPIXEL CURSORBM)
-	    (SETQ GRIDSPEC (WINDOWPROP W (QUOTE GRIDSPEC)))
-	    (SETQ GRIDINTERIOR (WINDOWPROP W (QUOTE GRIDINTERIOR)))
-	    (SETQ BM (WINDOWPROP W (QUOTE BM)))
-	    (SETQ BITSWIDE (WINDOWPROP W (QUOTE BITSWIDE)))
-	    (SETQ BITSHIGH (WINDOWPROP W (QUOTE BITSHIGH)))
-	    (SETQ WREGION (WINDOWPROP W (QUOTE REGION)))
-	    (SETQ XOFFSET (WINDOWPROP W (QUOTE XOFFSET)))
-	    (SETQ YOFFSET (WINDOWPROP W (QUOTE YOFFSET)))
-	    (SETQ DXOFFSET (WINDOWPROP W (QUOTE DXOFFSET)))
-	    (SETQ DYOFFSET (WINDOWPROP W (QUOTE DYOFFSET)))
-	    (SETQ DISPLAYREGION (WINDOWPROP W (QUOTE DISPLAYREGION)))
-	    (SETQ EXTENT (WINDOWPROP W (QUOTE EXTENT)))
-	    (SETQ GRIDX0 (fetch (REGION LEFT) of GRIDSPEC))
-	    (SETQ GRIDY0 (fetch (REGION BOTTOM) of GRIDSPEC))
-	    (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BM))
-	    (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM))
-	    (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BM))
-	    (SETQ COLOR (WINDOWPROP W (QUOTE COLOR)))
-                                                             (* ;; 
-							     "mark the region of the bitmap that is being editted."
-)
-	    (COND
-	      ((INSIDE? GRIDINTERIOR (LASTMOUSEX W)
-			  (LASTMOUSEY W))                  (* ;; "if cursor is inside, shade it.")
-		(\SHADEBITS BM GRIDSPEC GRIDINTERIOR W BITSWIDE BITSHIGH COLOR))
-	      ((INSIDE? DISPLAYREGION (LASTMOUSEX W)
-			  (LASTMOUSEY W))                  (* ;; 
-							     "Run the menu foe re-windowing into the whole bitmap")
-		(SELECTQ
-		  [MENU (COND
-			    ((type? MENU EDITBMWINDOWMENU)
-			      EDITBMWINDOWMENU)
-			    ((SETQ EDITBMWINDOWMENU (create MENU
-								ITEMS _
-								(QUOTE ((Move (QUOTE Move)
-										
-						"Selects a different part of the bitmap to edit.")))
-								CENTERFLG _ T]
-		  (Move                                      (* ; 
-							     "move the editing window's location on the bitmap.")
-		    (PROG (POS)
-			    [SETQ POS (GETBOXPOSITION BITSWIDE BITSHIGH
-							  [IPLUS 4 (fetch (REGION LEFT)
-									of WREGION)
-								   (DIFFERENCE XOFFSET
-										 (WINDOWPROP
-										   W
-										   (QUOTE DXOFFSET]
-							  (IPLUS (WINDOWPROP W (QUOTE 
-										  BMDISPLAYBOTTOM))
-								   (DIFFERENCE YOFFSET
-										 (WINDOWPROP
-										   W
-										   (QUOTE DYOFFSET))
-										 )
-								   4
-								   (fetch (REGION BOTTOM)
-								      of WREGION]
-			    [WINDOWPROP W (QUOTE XOFFSET)
-					  (SETQ XOFFSET
-					    (IMIN (IDIFFERENCE BITMAPWIDTH BITSWIDE)
-						    (IMAX [IPLUS
-							      (WINDOWPROP W (QUOTE DXOFFSET))
-							      (DIFFERENCE
-								(fetch (POSITION XCOORD)
-								   of POS)
-								(IPLUS 4 (fetch (REGION LEFT)
-									      of WREGION]
-							    0]
-			    [WINDOWPROP
-			      W
-			      (QUOTE YOFFSET)
-			      (SETQ YOFFSET
-				(IMAX 0 (IMIN (DIFFERENCE BITMAPHEIGHT BITSHIGH)
-						  (DIFFERENCE
-						    (IPLUS (WINDOWPROP W (QUOTE DYOFFSET))
-							     (DIFFERENCE
-							       (fetch (POSITION YCOORD)
-								  of POS)
-							       (IPLUS (fetch (REGION BOTTOM)
-									   of WREGION)
-									4)))
-						    (WINDOWPROP W (QUOTE BMDISPLAYBOTTOM]
-			    (replace (REGION LEFT) of EXTENT
-			       with (IMINUS (QUOTIENT (TIMES XOFFSET (fetch (REGION WIDTH)
-										of EXTENT))
-							    BITMAPWIDTH)))
-			    (replace (REGION BOTTOM) of EXTENT
-			       with (IMINUS (QUOTIENT (TIMES YOFFSET (fetch (REGION HEIGHT)
-										of EXTENT))
-							    BITMAPHEIGHT)))
-			    [COND
-			      ([OR (ILESSP XOFFSET DXOFFSET)
-				     (ILESSP YOFFSET DYOFFSET)
-				     [IGREATERP (IPLUS XOFFSET BITSWIDE)
-						  (IPLUS DXOFFSET (WINDOWPROP W (QUOTE 
-										   BMDISPLAYWIDTH]
-				     (IGREATERP (IPLUS YOFFSET BITSHIGH)
-						  (IPLUS DYOFFSET (WINDOWPROP W (QUOTE 
-										  BMDISPLAYHEIGHT]
-                                                             (* ;; 
-							     
-"Adjust the display region left lower corner so the selected region is near the center.")
-				[WINDOWPROP W (QUOTE DXOFFSET)
-					      (SETQ DXOFFSET
-						(IMAX 0 (IMIN (DIFFERENCE (fetch
-										  (BITMAP BITMAPWIDTH)
-										   of BM)
-										(WINDOWPROP
-										  W
-										  (QUOTE 
-										   BMDISPLAYWIDTH)))
-								  (DIFFERENCE
-								    (IPLUS XOFFSET
-									     (LRSH BITSWIDE 1))
-								    (LRSH (WINDOWPROP
-									      W
-									      (QUOTE BMDISPLAYWIDTH)
-									      )
-									    1]
-				(WINDOWPROP W (QUOTE DYOFFSET)
-					      (SETQ DYOFFSET
-						(IMAX 0 (IMIN (DIFFERENCE (fetch
-										  (BITMAP 
-										     BITMAPHEIGHT)
-										   of BM)
-										(WINDOWPROP
-										  W
-										  (QUOTE 
-										  BMDISPLAYHEIGHT)))
-								  (DIFFERENCE
-								    (IPLUS YOFFSET
-									     (LRSH BITSHIGH 1))
-								    (LRSH (WINDOWPROP
-									      W
-									      (QUOTE 
-										  BMDISPLAYHEIGHT))
-									    1]
-                                                             (* DSPFILL GRIDINTERIOR WHITESHADE 
-							     (QUOTE REPLACE) W)
-			    (UPDATE/BM/DISPLAY BM W)         (* ;; 
-							     
-"FS: More useless code: (COND ((WINDOWPROP W 'GRIDON) (GRID GRIDSPEC BITSWIDE BITSHIGH 'POINT W)))")
-			    (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T)))
-		  NIL))
-	      ((LASTMOUSESTATE LEFT)
-		(UPDATE/BM/DISPLAY/SELECTED/REGION W)
-		(SETQ CURSORBM (BITMAPCREATE 16 16 (BITSPERPIXEL BM)))
-		(BITBLT BM NIL NIL CURSORBM)
-		[RESETFORM [CURSOR (CURSORCREATE CURSORBM (fetch (CURSOR CURSORHOTSPOTX)
-								   of (CURSOR))
-						       (fetch (CURSOR CURSORHOTSPOTY)
-							  of (CURSOR]
-			     (until (MOUSESTATE (NOT LEFT]
-		(UPDATE/BM/DISPLAY/SELECTED/REGION W))
-	      (T                                             (* ;; 
-							     
-"the region being editted is inverted while the menu is active.  Each command must make sure that it is recomplemented."
-)
-		 (UPDATE/BM/DISPLAY/SELECTED/REGION W)
-		 (SELECTQ [MENU (COND
-				      ((type? MENU EDITBMMENU)
-					EDITBMMENU)
-				      (T (SETQ EDITBMMENU
-					   (create MENU
-						     ITEMS _
-						     [APPEND (COND
-								 [(COLORDISPLAYP)
-								   (QUOTE ((Color (QUOTE Color)
-										    
-								  "Choose color to set bits with"]
-								 (T NIL))
-							       (QUOTE ((Paint (QUOTE Paint)
-										
-						  "Calls the window PAINT command on the bitmap.")
-									  (ShowAsTile (QUOTE 
-										       ShowAsTile)
-										      
-				       "tiles the upper part of the edit window with the bitmap.")
-									  (Grid% On/Off (QUOTE
-											  GridOnOff)
-											
-									     "Grid On/Off Switch")
-									  (GridSize_ (QUOTE 
-											GridSize_)
-										     
-					  "Allows setting of the size of a bit in the edit area.")
-									  (Reset (QUOTE Reset)
-										 
-			   "Sets the bitmap back to the state at the start of this edit session.")
-									  (Clear (QUOTE Clear)
-										 
-								    "Sets the entire bitmap to 0")
-									  (Cursor_ (QUOTE Cursor_)
-										   
-					  "Puts the bitmap into the cursor and exits the editor.")
-									  (OK (QUOTE OK)
-									      
-								       "Leaves the edit session.")
-									  (Abort (QUOTE Abort)
-										 
-			      "Restores the bitmap to its original values and leaves the editor."]
-						     CENTERFLG _ T]
-			    (OK (WINDOWPROP W (QUOTE FINISHEDFLG)
-					      T))
-			    (Abort (WINDOWPROP W (QUOTE FINISHEDFLG)
-						 (QUOTE KILL)))
-			    [Reset                           (* ;; 
-							     
-"allow the user to choose between everything or just visible part.  This also give the user a chance to change their mind."
-)
-				   (COND
-				     ((SELECTQ (\EDITBMHOWMUCH BM BITSWIDE BITSHIGH 
-								   "RESET how much?")
-						 (VISIBLE [COND
-							    [(SETQ ORIGBM (WINDOWPROP
-								  W
-								  (QUOTE ORIGINALBITMAP)))
-							      (COND
-								((REGIONP ORIGBM)
-								  (BITBLT
-								    (SCREENBITMAP)
-								    (IPLUS XOFFSET
-									     (fetch (REGION LEFT)
-										of ORIGBM))
-								    (IPLUS YOFFSET
-									     (fetch (REGION BOTTOM)
-										of ORIGBM))
-								    BM XOFFSET YOFFSET BITSWIDE 
-								    BITSHIGH (QUOTE INPUT)
-								    (QUOTE REPLACE)))
-								(T (BITBLT ORIGBM XOFFSET YOFFSET 
-									     BM XOFFSET YOFFSET 
-									     BITSWIDE BITSHIGH]
-							    (T (BLTSHADE WHITESHADE BM XOFFSET 
-									   YOFFSET BITSWIDE BITSHIGH
-									   (QUOTE REPLACE]
-							  T)
-						 (WHOLE [COND
-							  [(SETQ ORIGBM (WINDOWPROP W
-											(QUOTE
-											  
-										   ORIGINALBITMAP)))
-							    (COND
-							      ((REGIONP ORIGBM)
-								(BITBLT (SCREENBITMAP)
-									  (fetch (REGION LEFT)
-									     of ORIGBM)
-									  (fetch (REGION BOTTOM)
-									     of ORIGBM)
-									  BM))
-							      (T (BITBLT ORIGBM NIL NIL BM]
-							  (T (BLTSHADE WHITESHADE BM NIL NIL NIL 
-									 NIL (QUOTE REPLACE]
-							T)
-						 (PROGN (UPDATE/BM/DISPLAY/SELECTED/REGION W)
-							  NIL))
-				       (\EDITBM/PUTUP/DISPLAY W BM GRIDSPEC GRIDINTERIOR BITSWIDE 
-								BITSHIGH]
-			    [Clear                           (* ;; 
-							     
-"allow the user to choose between everything or just visible part.  This also give the user a chance to change their mind."
-)
-				   (COND
-				     ((SELECTQ (\EDITBMHOWMUCH BM BITSWIDE BITSHIGH 
-								   "CLEAR how much?")
-						 (VISIBLE (BLTSHADE WHITESHADE BM XOFFSET YOFFSET 
-								      BITSWIDE BITSHIGH (QUOTE
-									REPLACE))
-							  T)
-						 (WHOLE (\CLEARBM BM)
-							T)
-						 (PROGN (UPDATE/BM/DISPLAY/SELECTED/REGION W)
-							  NIL))
-				       (DSPFILL GRIDINTERIOR WHITESHADE (QUOTE REPLACE)
-						  W)
-				       (COND
-					 ((WINDOWPROP W (QUOTE GRIDON))
-					   (GRID GRIDSPEC BITSWIDE BITSHIGH (QUOTE POINT)
-						   W)))
-				       (UPDATE/BM/DISPLAY BM W]
-			    (GridOnOff (COND
-					 ((NOT (WINDOWPROP W (QUOTE GRIDON)))
-                                                             (* ; "Turn Grid On")
-					   (WINDOWPROP W (QUOTE GRIDON)
-							 T)
-					   (GRID GRIDSPEC BITSWIDE BITSHIGH (QUOTE POINT)
-						   W)        (* ;; 
-							     
-"FS:  The update here was unnecessary.  (UPDATE/BM/DISPLAY BM W)")
-					   NIL)
-					 (T                  (* ; "Turn off grid")
-					    (WINDOWPROP W (QUOTE GRIDON)
-							  NIL)
-
-          (* DSPFILL (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (ADD1 (fetch (REGION WIDTH) of GRIDINTERIOR)) HEIGHT _ 
-	  (ADD1 (fetch (REGION HEIGHT) of GRIDINTERIOR))) WHITESHADE (QUOTE REPLACE) W)
-
-
-					    (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T)
-                                                             (* ;; 
-							     
-"FS:  The update here was unnecessary.  (UPDATE/BM/DISPLAY BM W)")
-					    NIL)))
-			    [GridSize_                       (* ; 
-							     "sets the grid square size and calls the reshapefn.")
-				       (COND
-					 ([SETQ NEWGRIDSIZE
-					     (NUMBERP (MENU
-							  (COND
-							    ((TYPENAMEP GRIDSIZEMENU (QUOTE
-									    MENU))
-							      GRIDSIZEMENU)
-							    (T (SETQ GRIDSIZEMENU
-								 (create MENU
-									   ITEMS _
-									   (QUOTE (3 4 5 6 7 8 12 
-										       16 20 24 28 32)
-										    )
-									   MENUROWS _ 4]
-					   (WINDOWPROP W (QUOTE GRIDSQUARE)
-							 NEWGRIDSIZE)
-					   (EDITBMRESHAPEFN W]
-			    (ShowAsTile                      (* ; 
-							     
-"tiles the upper part of the window with the bitmap so the user can see what it would be as a shade.")
-					(UPDATE/SHADE/DISPLAY BM W))
-			    [Paint                           (* ; 
-							     
-"call the window paint command on the contents of the bitmap.")
-				   [SETQ PAINTW (CREATEW (create REGION
-								       LEFT _
-								       (IQUOTIENT (DIFFERENCE
-										      SCREENWIDTH 
-										      BITMAPWIDTH)
-										    2)
-								       BOTTOM _
-								       (IQUOTIENT (DIFFERENCE
-										      SCREENHEIGHT 
-										     BITMAPHEIGHT)
-										    2)
-								       WIDTH _ (WIDTHIFWINDOW
-									 BITMAPWIDTH)
-								       HEIGHT _ (HEIGHTIFWINDOW
-									 BITMAPHEIGHT NIL]
-				   (OPENW PAINTW)
-				   (BITBLT BM 0 0 PAINTW)
-				   (PAINTW PAINTW)
-				   (COND
-				     ((MENU (create MENU
-							ITEMS _ (QUOTE ((YES T 
-			      "Will put the newly painted bits back in the bitmap being editted.")
-									     (NO NIL 
-			  "Will discard the painted bits, not changing the bitmap being editted.")))
-							TITLE _ "Put change into bitmap?"
-							CENTERFLG _ T))
-				       (BITBLT PAINTW 0 0 BM)
-				       (CLOSEW PAINTW)     (* ; "set PAINTW so that space can be reclaimed")
-				       (SETQ PAINTW)
-				       (\EDITBM/PUTUP/DISPLAY W BM GRIDSPEC GRIDINTERIOR BITSWIDE 
-								BITSHIGH]
-			    (Cursor_                         (* ; 
-							     
-"Stuffs lower left part of image into the cursor and sets the hotspot.")
-				     (READHOTSPOT BM GRIDSPEC GRIDINTERIOR W)
-				     (WINDOWPROP W (QUOTE FINISHEDFLG)
-						   T))
-			    (Color (WINDOWPROP W (QUOTE COLOR)
-						 (OR (MENU (COLORMENU BITSPERPIXEL))
-						       COLOR)))
-			    (UPDATE/BM/DISPLAY/SELECTED/REGION W])
-
-(EDITBMSCROLLFN
-  [LAMBDA (W DX DY)                                          (* ; "Edited 31-Aug-87 13:29 by FS")
-                                                             (* ; "Do scrolling for the bitmap editor.")
-    (PROG (GRIDSPEC REG WHEIGHT WWIDTH (DXGRID 0)
-		      (DYGRID 0)
-		      EXTENT EXTENTWIDTH EXTENTHEIGHT GILEFT GIBOTTOM GIHEIGHT GWIDTH GHEIGHT 
-		      GRIDINTERIOR EBMXLIMIT EBMYLIMIT EBMXOFFSET EBMYOFFSET BM BITMAPWIDTH 
-		      BITMAPHEIGHT BITSWIDE BITSHIGH DXOFFSET DYOFFSET)
-	    (SETQ GRIDSPEC (WINDOWPROP W (QUOTE GRIDSPEC)))
-	    (SETQ REG (WINDOWPROP W (QUOTE REGION)))
-	    (SETQ WHEIGHT (WINDOWPROP W (QUOTE HEIGHT)))
-	    (SETQ WWIDTH (WINDOWPROP W (QUOTE WIDTH)))
-	    (SETQ GRIDINTERIOR (WINDOWPROP W (QUOTE GRIDINTERIOR)))
-	    (SETQ EBMXOFFSET (WINDOWPROP W (QUOTE XOFFSET)))
-	    (SETQ EBMYOFFSET (WINDOWPROP W (QUOTE YOFFSET)))
-	    (SETQ BM (WINDOWPROP W (QUOTE BM)))
-	    (SETQ BITMAPWIDTH (fetch BITMAPWIDTH of BM))
-	    (SETQ BITMAPHEIGHT (fetch BITMAPHEIGHT of BM))
-	    (SETQ BITSWIDE (WINDOWPROP W (QUOTE BITSWIDE)))
-	    (SETQ BITSHIGH (WINDOWPROP W (QUOTE BITSHIGH)))
-	    (SETQ DXOFFSET (WINDOWPROP W (QUOTE DXOFFSET)))
-	    (SETQ DYOFFSET (WINDOWPROP W (QUOTE DYOFFSET)))
-	    (SETQ EBMXLIMIT (IPLUS EBMXOFFSET BITSWIDE))
-	    (SETQ EBMYLIMIT (IPLUS EBMYOFFSET BITSHIGH))
-	    (COND
-	      (GRIDSPEC (SETQ GILEFT (fetch (REGION LEFT) of GRIDINTERIOR))
-			(SETQ GIBOTTOM (fetch (REGION BOTTOM) of GRIDINTERIOR))
-			(SETQ GIHEIGHT (fetch (REGION HEIGHT) of GRIDINTERIOR))
-			(SETQ GWIDTH (fetch (REGION WIDTH) of GRIDSPEC))
-			(SETQ GHEIGHT (fetch (REGION HEIGHT) of GRIDSPEC))
-			(SETQ EXTENT (WINDOWPROP W (QUOTE EXTENT)))
-			(SETQ EXTENTWIDTH (fetch (REGION WIDTH) of EXTENT))
-			(SETQ EXTENTHEIGHT (fetch (REGION HEIGHT) of EXTENT))
-                                                             (* ; "Make a horizontal adjustment")
-			(COND
-			  ((FLOATP DX)                     (* ; "Horizontal thumbing")
-			    [WINDOWPROP W (QUOTE XOFFSET)
-					  (SETQ EBMXOFFSET (FIX (TIMES (IDIFFERENCE 
-										      BITMAPWIDTH 
-											 BITSWIDE)
-									     DX]
-			    (replace (REGION LEFT) of EXTENT
-			       with (IMINUS (QUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH)
-							    BITMAPWIDTH)))
-                                                             (* BLTSHADE WHITESHADE W GILEFT GIBOTTOM SCREENWIDTH 
-							     SCREENHEIGHT (QUOTE REPLACE) GRIDINTERIOR)
-			    (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T))
-			  ((ILESSP DX 0)                   (* ; "moving to the left.")
-                                                             (* ; "determine how many grid points to move.")
-			    (SETQ DXGRID (IMIN (GRIDXCOORD (IMINUS DX)
-								 GRIDSPEC)
-						   (IDIFFERENCE BITMAPWIDTH EBMXLIMIT)))
-			    (COND
-			      ((NOT (IGREATERP DXGRID 0))
-                                                             (* ; "right edge is at the right margin")
-				(RETURN)))
-			    (WINDOWPROP W (QUOTE XOFFSET)
-					  (SETQ EBMXOFFSET (IPLUS EBMXOFFSET DXGRID)))
-                                                             (* ; "update EXTENT bar")
-			    (replace (REGION LEFT) of EXTENT
-			       with (IMAX (IMINUS (QUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH)
-								    BITMAPWIDTH))
-					      (IMINUS EXTENTWIDTH)))
-                                                             (* ; "move image to the left.")
-			    (BITBLT W (IPLUS GILEFT (TIMES DXGRID GWIDTH))
-				      GIBOTTOM W GILEFT GIBOTTOM SCREENWIDTH SCREENHEIGHT
-				      (QUOTE INPUT)
-				      (QUOTE REPLACE)
-				      NIL GRIDINTERIOR)      (* ; "clear the newly exposed area.")
-			    (BLTSHADE WHITESHADE W (IPLUS GILEFT (TIMES (IDIFFERENCE BITSWIDE 
-											   DXGRID)
-									      GWIDTH))
-					GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE REPLACE)
-					GRIDINTERIOR)
-			    (RESETGRID.NEW BM GRIDSPEC DXGRID BITSHIGH (IDIFFERENCE BITSWIDE 
-											DXGRID)
-					     0 W))
-			  ((ILESSP 0 DX)                   (* ; 
-							     "determine how many grid point to the left to move.")
-			    (SETQ DXGRID (IMIN EBMXOFFSET (GRIDXCOORD DX GRIDSPEC)))
-			    (COND
-			      ((NOT (IGREATERP DXGRID 0))
-                                                             (* ; "left edge is at the left margin")
-				(RETURN)))
-			    (WINDOWPROP W (QUOTE XOFFSET)
-					  (SETQ EBMXOFFSET (IDIFFERENCE EBMXOFFSET DXGRID)))
-                                                             (* ; "update REGION bar")
-			    (replace (REGION LEFT) of EXTENT
-			       with (IMIN (IMINUS (IQUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH)
-								     BITMAPWIDTH))
-					      0))            (* ; "move image to the right.")
-			    (BITBLT W GILEFT GIBOTTOM W (IPLUS GILEFT (TIMES DXGRID GWIDTH))
-				      GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE INPUT)
-				      (QUOTE REPLACE)
-				      NIL GRIDINTERIOR)      (* ; "clear the newly exposed area.")
-			    (BLTSHADE WHITESHADE W GILEFT GIBOTTOM (TIMES DXGRID GWIDTH)
-					GIHEIGHT
-					(QUOTE REPLACE))
-			    (RESETGRID.NEW BM GRIDSPEC DXGRID BITSHIGH 0 0 W)))
-                                                             (* ; "Make a vertical adjustment")
-			(COND
-			  ((FLOATP DY)                     (* ; "Vertical Thumbing")
-			    [WINDOWPROP W (QUOTE YOFFSET)
-					  (SETQ EBMYOFFSET (FIX (TIMES (IDIFFERENCE 
-										     BITMAPHEIGHT 
-											 BITSHIGH)
-									     (FDIFFERENCE 1.0 DY]
-                                                             (* ; "set EXTENT bar")
-			    (replace (REGION BOTTOM) of EXTENT
-			       with (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT)
-							    BITMAPHEIGHT)))
-                                                             (* ; "Clear Window")
-                                                             (* BLTSHADE WHITESHADE W GILEFT GIBOTTOM SCREENWIDTH 
-							     SCREENHEIGHT (QUOTE REPLACE) GRIDINTERIOR)
-                                                             (* ; "Repaint the image using grid function")
-			    (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T))
-			  ((ILESSP DY 0)                   (* ; "determine how many squares to move down.")
-			    (SETQ DYGRID (IMIN (IDIFFERENCE (fetch (BITMAP BITMAPHEIGHT)
-								     of BM)
-								  EBMYLIMIT)
-						   (GRIDYCOORD (IMIN GIHEIGHT (IMINUS DY))
-								 GRIDSPEC)))
-			    (COND
-			      ((NOT (IGREATERP DYGRID 0))
-                                                             (* ; "top edge is at the top margin")
-				(RETURN)))
-			    (WINDOWPROP W (QUOTE YOFFSET)
-					  (SETQ EBMYOFFSET (IPLUS EBMYOFFSET DYGRID)))
-			    (replace (REGION BOTTOM) of EXTENT
-			       with (IMAX (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT)
-								    BITMAPHEIGHT))
-					      (IMINUS EXTENTHEIGHT)))
-			    (BITBLT W GILEFT (IPLUS GIBOTTOM (ITIMES DYGRID GHEIGHT))
-				      W GILEFT GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE INPUT)
-				      (QUOTE REPLACE)
-				      NIL GRIDINTERIOR)      (* BLTSHADE WHITESHADE W GILEFT 
-							     (IPLUS GIBOTTOM (ITIMES (IDIFFERENCE BITSHIGH DYGRID) 
-							     GHEIGHT)) SCREENWIDTH SCREENHEIGHT 
-							     (QUOTE REPLACE) GRIDINTERIOR)
-			    (RESETGRID.NEW BM GRIDSPEC BITSWIDE DYGRID 0 (IDIFFERENCE BITSHIGH 
-											  DYGRID)
-					     W T))
-			  ((ILESSP 0 DY)                   (* ; 
-							     "moving up;  determine how may grid squares to move.")
-			    (SETQ DYGRID (IMIN EBMYOFFSET (GRIDYCOORD (IMIN GIHEIGHT DY)
-									    GRIDSPEC)))
-			    (COND
-			      ((NOT (IGREATERP DYGRID 0))
-                                                             (* ; "bottom edge is at the bottom margin")
-				(RETURN)))
-			    (WINDOWPROP W (QUOTE YOFFSET)
-					  (SETQ EBMYOFFSET (IDIFFERENCE EBMYOFFSET DYGRID)))
-			    (replace (REGION BOTTOM) of EXTENT
-			       with (IMIN (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT)
-								    BITMAPHEIGHT))
-					      0))
-			    (BITBLT W GILEFT GIBOTTOM W GILEFT (IPLUS GIBOTTOM (ITIMES DYGRID 
-											  GHEIGHT))
-				      SCREENWIDTH SCREENHEIGHT (QUOTE INPUT)
-				      (QUOTE REPLACE)
-				      NIL GRIDINTERIOR)      (* BLTSHADE WHITESHADE W GILEFT GIBOTTOM 
-							     (fetch (REGION WIDTH) of GRIDINTERIOR) 
-							     (ITIMES DYGRID GHEIGHT) (QUOTE REPLACE))
-			    (RESETGRID.NEW BM GRIDSPEC BITSWIDE DYGRID 0 0 W T)))
-                                                             (* ;; 
-							     
-"This call to GRID is unnecessary as the grid dots get filled in earlier.")
-                                                             (* ;; 
-							     
-"(COND ((WINDOWPROP W 'GRIDON) (GRID GRIDSPEC BITSWIDE BITSHIGH 'POINT W)))")
-			[COND
-			  ([OR (ILESSP EBMXOFFSET DXOFFSET)
-				 (ILESSP EBMYOFFSET DYOFFSET)
-				 [IGREATERP (IPLUS EBMXOFFSET BITSWIDE)
-					      (IPLUS DXOFFSET (WINDOWPROP W (QUOTE 
-										   BMDISPLAYWIDTH]
-				 (IGREATERP (IPLUS EBMYOFFSET BITSHIGH)
-					      (IPLUS DYOFFSET (WINDOWPROP W (QUOTE 
-										  BMDISPLAYHEIGHT]
-                                                             (* ; 
-							     
-"Adjust the display region left lower corner so the selected region is near the center.")
-			    [WINDOWPROP W (QUOTE DXOFFSET)
-					  (SETQ DXOFFSET
-					    (IMAX 0 (IMIN (IDIFFERENCE (fetch (BITMAP 
-										      BITMAPWIDTH)
-										of BM)
-									     (WINDOWPROP
-									       W
-									       (QUOTE 
-										   BMDISPLAYWIDTH)))
-							      (IDIFFERENCE
-								(IPLUS EBMXOFFSET (LRSH BITSWIDE 
-											    1))
-								(LRSH (WINDOWPROP W (QUOTE
-											
-										   BMDISPLAYWIDTH))
-									1]
-			    (WINDOWPROP W (QUOTE DYOFFSET)
-					  (SETQ DYOFFSET
-					    (IMAX 0 (IMIN (IDIFFERENCE (fetch (BITMAP 
-										     BITMAPHEIGHT)
-										of BM)
-									     (WINDOWPROP
-									       W
-									       (QUOTE 
-										  BMDISPLAYHEIGHT)))
-							      (IDIFFERENCE
-								(IPLUS EBMYOFFSET (LRSH BITSHIGH 
-											    1))
-								(LRSH (WINDOWPROP W (QUOTE
-											
-										  BMDISPLAYHEIGHT))
-									1]
-			(UPDATE/BM/DISPLAY BM W])
-
-(\EDITBM/PUTUP/DISPLAY
-  [LAMBDA (WINDOW BM GRIDSPEC GRIDINTERIOR BITSWIDE BITSHIGH)
-                                                             (* ; "Edited 31-Aug-87 13:05 by FS")
-                                                             (* initializes the display for the bitmap editor.)
-                                                             (* DSPFILL GRIDINTERIOR WHITESHADE 
-							     (QUOTE REPLACE) WINDOW)
-                                                             (* COND ((WINDOWPROP WINDOW 
-							     (QUOTE GRIDON)) (GRID GRIDSPEC BITSWIDE BITSHIGH 
-							     (QUOTE POINT) WINDOW)))
-    (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 WINDOW T)
-    (UPDATE/BM/DISPLAY BM WINDOW])
-
-(EDITBMRESHAPEFN
-  [LAMBDA (BMEDITWINDOW OLDIMAGE OLDREGION OLDSCREENREGION ZEROBMFLG)
-                                                             (* ; "Edited 31-Aug-87 12:41 by FS")
-                                                             (* ;; 
-							     
-"allows the bitmap edit window to be reshaped to enlarge the editting area.  This is also called to set up the image during initialization."
-)
-    (PROG (BMWINTERIORWIDTH BMWINTERIORHEIGHT EDITAREABITWIDTH EDITAREABITHEIGHT GRIDSQUARE 
-			      GRIDINTERIOR BITMAPWIDTH BMDISPLAYWIDTH BMDISPLAYBOTTOM BMDISPLAYHEIGHT 
-			      BITMAPHEIGHT (BM (WINDOWPROP BMEDITWINDOW (QUOTE BM)))
-			      MINCOMMANDAREAWIDTH EXTENTWIDTH EXTENTHEIGHT)
-	    (SETQ MINCOMMANDAREAWIDTH 30)
-	    (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BM))
-	    (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM))
-	    (SETQ BMWINTERIORWIDTH (WINDOWPROP BMEDITWINDOW (QUOTE WIDTH)))
-                                                             (* ;; 
-							     
-"leave room at the top for the full size display area.  But not more than half of the window.")
-	    (SETQ BMWINTERIORHEIGHT (IMAX (IDIFFERENCE (WINDOWPROP BMEDITWINDOW (QUOTE
-									     HEIGHT))
-							     (IPLUS BITMAPHEIGHT GRIDTHICKNESS))
-					      (IQUOTIENT (WINDOWPROP BMEDITWINDOW (QUOTE HEIGHT)
-									 )
-							   2)))
-                                                             (* ;; 
-							     
-"if the user hasn't set it, determine the grid size as the largest size which fits the interior but not larger than NORMALGRIDSQUARE nor smaller than MINGRIDSQUARE.  If GRIDSQUARE was specified, reset it to NIL so that if reshaped it will be recalculated."
-)
-	    (SETQ GRIDSQUARE (OR (WINDOWPROP BMEDITWINDOW (QUOTE GRIDSQUARE)
-						   NIL)
-				     (IMAX (IMIN (IQUOTIENT BMWINTERIORWIDTH BITMAPWIDTH)
-						     (IQUOTIENT BMWINTERIORHEIGHT BITMAPHEIGHT)
-						     NORMALGRIDSQUARE)
-					     MINGRIDSQUARE)))
-                                                             (* ; 
-							     "calculate how many bits will be displayed at once.")
-	    (SETQ EDITAREABITWIDTH (IMIN (IQUOTIENT BMWINTERIORWIDTH GRIDSQUARE)
-					     BITMAPWIDTH))
-	    (WINDOWPROP BMEDITWINDOW (QUOTE BITSWIDE)
-			  EDITAREABITWIDTH)
-	    (SETQ EDITAREABITHEIGHT (IMIN (IQUOTIENT BMWINTERIORHEIGHT GRIDSQUARE)
-					      BITMAPHEIGHT))
-                                                             (* ; 
-							     
-"calculate offset of display and command regions at the top of the window.")
-	    (WINDOWPROP BMEDITWINDOW (QUOTE BITSHIGH)
-			  EDITAREABITHEIGHT)
-	    (SETQ BMDISPLAYBOTTOM (IPLUS (ITIMES GRIDSQUARE EDITAREABITHEIGHT)
-					     GRIDTHICKNESS))
-	    (SETQ BMDISPLAYWIDTH (IMIN BITMAPWIDTH (IDIFFERENCE BMWINTERIORWIDTH 
-								      MINCOMMANDAREAWIDTH)))
-                                                             (* ;; 
-							     
-"put the offset --- the lower left coordinate --- in the same place unless the new shape allows more to be shown past the upper right corner."
-)
-	    (WINDOWPROP BMEDITWINDOW (QUOTE XOFFSET)
-			  (IMIN (WINDOWPROP BMEDITWINDOW (QUOTE XOFFSET))
-				  (IDIFFERENCE BITMAPWIDTH EDITAREABITWIDTH)))
-	    (WINDOWPROP BMEDITWINDOW (QUOTE YOFFSET)
-			  (IMIN (WINDOWPROP BMEDITWINDOW (QUOTE YOFFSET))
-				  (IDIFFERENCE BITMAPHEIGHT EDITAREABITHEIGHT)))
-                                                             (* ; "Center edit square")
-	    (SETQ GRIDINTERIOR (create REGION
-					   LEFT _ (IQUOTIENT (IDIFFERENCE BMWINTERIORWIDTH
-										(ITIMES 
-										 EDITAREABITWIDTH 
-										       GRIDSQUARE))
-								 2)
-					   BOTTOM _ (IQUOTIENT (IDIFFERENCE BMDISPLAYBOTTOM
-										  (ITIMES 
-										EDITAREABITHEIGHT 
-										       GRIDSQUARE))
-								   2)
-					   WIDTH _ (ITIMES EDITAREABITWIDTH GRIDSQUARE)
-					   HEIGHT _ (ITIMES EDITAREABITHEIGHT GRIDSQUARE)))
-	    (WINDOWPROP BMEDITWINDOW (QUOTE GRIDINTERIOR)
-			  GRIDINTERIOR)
-	    (WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYBOTTOM)
-			  BMDISPLAYBOTTOM)
-	    (WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYWIDTH)
-			  BMDISPLAYWIDTH)
-	    (WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYHEIGHT)
-			  (SETQ BMDISPLAYHEIGHT (IDIFFERENCE (WINDOWPROP BMEDITWINDOW
-									       (QUOTE HEIGHT))
-								 BMDISPLAYBOTTOM)))
-	    (WINDOWPROP BMEDITWINDOW (QUOTE DISPLAYREGION)
-			  (create REGION
-				    LEFT _ 0
-				    BOTTOM _ BMDISPLAYBOTTOM
-				    WIDTH _ BMDISPLAYWIDTH
-				    HEIGHT _ BMDISPLAYHEIGHT))
-	    (WINDOWPROP BMEDITWINDOW (QUOTE GRIDSPEC)
-			  (create REGION
-				    LEFT _ (fetch (REGION LEFT) of GRIDINTERIOR)
-				    BOTTOM _ (fetch (REGION BOTTOM) of GRIDINTERIOR)
-				    WIDTH _ GRIDSQUARE
-				    HEIGHT _ GRIDSQUARE))
-	    (SETQ EXTENTHEIGHT (QUOTIENT (TIMES BITMAPHEIGHT (WINDOWPROP BMEDITWINDOW
-										 (QUOTE HEIGHT)))
-					     EDITAREABITHEIGHT))
-	    [SETQ EXTENTWIDTH (IDIFFERENCE (QUOTIENT (TIMES BITMAPWIDTH BMWINTERIORWIDTH)
-							   EDITAREABITWIDTH)
-					       (WINDOWPROP BMEDITWINDOW (QUOTE BORDER]
-	    (WINDOWPROP BMEDITWINDOW (QUOTE EXTENT)
-			  (CREATEREGION (MINUS (QUOTIENT (TIMES (WINDOWPROP BMEDITWINDOW
-										      (QUOTE 
-											  XOFFSET))
-									EXTENTWIDTH)
-							       BITMAPWIDTH))
-					  (MINUS (QUOTIENT (TIMES (WINDOWPROP BMEDITWINDOW
-										      (QUOTE 
-											  YOFFSET))
-									EXTENTHEIGHT)
-							       BITMAPHEIGHT))
-					  EXTENTWIDTH EXTENTHEIGHT))
-	    (EDITBMREPAINTFN BMEDITWINDOW NIL ZEROBMFLG])
-
-(EDITBMREPAINTFN.NEW
-  [LAMBDA (WIN REGION ZEROBM)                              (* ; "Edited 27-Aug-87 22:02 by FS")
-                                                             (* ;; 
-							     
-"Stub in case I missed a call to this guy.  Take out later.")
-    (EDITBMREPAINTFN WIN REGION ZEROBM])
-
-(EDITBMREPAINTFN
-  [LAMBDA (WIN REGION ZEROBM)                              (* N.H.Briggs " 4-Sep-87 15:07")
-                                                             (* ;; 
-							     
-"redisplays a bitmap editting window If ZEROBM is non-NIL, it doesn't bother to display the bits.")
-    (PROG [(GRIDSPEC (WINDOWPROP WIN (QUOTE GRIDSPEC)))
-	     (EDITAREABITWIDTH (WINDOWPROP WIN (QUOTE BITSWIDE)))
-	     (EDITAREABITHEIGHT (WINDOWPROP WIN (QUOTE BITSHIGH)))
-	     (BM (WINDOWPROP WIN (QUOTE BM]
-	    (CLEARW WIN)                                   (* ; 
-							     
-"gray the area above the edit grid that is not bitmap display area.")
-	    (BLTSHADE NOTINUSEGRAY WIN (PLUS (WINDOWPROP WIN (QUOTE BMDISPLAYWIDTH))
-						 GRIDTHICKNESS)
-			(WINDOWPROP WIN (QUOTE BMDISPLAYBOTTOM)))
-                                                             (* ;; "put in the display of the full sized bitmap.")
-	    (UPDATE/BM/DISPLAY BM WIN)                       (* ;; 
-							     
-"FS: Now that RESETGRID displays the grid, don't need the call to GRID.")
-                                                             (* ;; 
-							     
-"(COND ((WINDOWPROP WIN 'GRIDON) (GRID GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT 'POINT WIN)))")
-	    (if ZEROBM
-		then (if (WINDOWPROP WIN (QUOTE GRIDON))
-			   then (GRID GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT (QUOTE POINT)
-					  WIN))
-	      else (RESETGRID.NEW BM GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT 0 0 WIN])
-
-(RESETGRID.NEW
-  [LAMBDA (BM GRIDSPEC WIDTH HEIGHT ORIGX ORIGY WINDOW DOCLEARFLG)
-                                                             (* N.H.Briggs " 4-Sep-87 15:08")
-                                                             (* ;; 
-							     
-"Copies the contents of a bitmap into the edit display grid of window.  ORIGX & Y are used to offest into both bitmap and destination window."
-)
-    (LET (XOFFSET YOFFSET MAXX MAXY SHADE XSCALE YSCALE TEMPBM)
-         (SETQ XSCALE (fetch (REGION WIDTH) of GRIDSPEC))
-         (SETQ YSCALE (fetch (REGION HEIGHT) of GRIDSPEC))
-         (if (NULL ORIGX)
-	     then (SETQ ORIGX 0))
-         (if (NULL ORIGY)
-	     then (SETQ ORIGY 0))
-         (SETQ XOFFSET (WINDOWPROP WINDOW (QUOTE XOFFSET)))
-         (SETQ YOFFSET (WINDOWPROP WINDOW (QUOTE YOFFSET)))
-         (SETQ MAXX (IPLUS ORIGX WIDTH -1))
-         (SETQ MAXY (IPLUS ORIGY HEIGHT -1))             (* ;; "Build & cache a temporary bitmap.")
-         (SETQ TEMPBM (WINDOWPROP WINDOW (QUOTE TEMPBM)))
-         (if (NOT TEMPBM)
-	     then (SETQ TEMPBM (BITMAPCREATE (BITMAPWIDTH WINDOW)
-						   (BITMAPHEIGHT BM)))
-		    (WINDOWPROP WINDOW (QUOTE TEMPBM)
-				  TEMPBM))                   (* ;; 
-							     
-"Use SCALEBM.  Bitmap destination must be empty (white).")
-         (if DOCLEARFLG
-	     then (BLTSHADE WHITESHADE WINDOW (LEFTOFGRIDCOORD ORIGX GRIDSPEC)
-				(BOTTOMOFGRIDCOORD ORIGY GRIDSPEC)
-				(TIMES WIDTH XSCALE)
-				(TIMES HEIGHT YSCALE)
-				(QUOTE REPLACE)))
-         (SCALEBM BM (PLUS ORIGX XOFFSET)
-		    (PLUS ORIGY YOFFSET)
-		    WINDOW
-		    (LEFTOFGRIDCOORD ORIGX GRIDSPEC)
-		    (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC)
-		    WIDTH HEIGHT XSCALE YSCALE TEMPBM)       (* ;; "Shade the pixels correctly.")
-         (BLTSHADE DARKBITSHADE WINDOW (LEFTOFGRIDCOORD ORIGX GRIDSPEC)
-		     (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC)
-		     (TIMES WIDTH XSCALE)
-		     (TIMES HEIGHT YSCALE)
-		     (QUOTE ERASE))                        (* ;; "Add grid")
-         (if (WINDOWPROP WINDOW (QUOTE GRIDON))
-	     then (if (OR (NEQ ORIGX (CAR GRIDSPEC))
-				(NEQ ORIGY (CADR GRIDSPEC)))
-			then (SETQ GRIDSPEC (COPYALL GRIDSPEC))
-			       (replace (REGION LEFT) of GRIDSPEC with (LEFTOFGRIDCOORD
-									       ORIGX GRIDSPEC))
-			       (replace (REGION BOTTOM) of GRIDSPEC with (BOTTOMOFGRIDCOORD
-										 ORIGY GRIDSPEC)))
-		    (GRID GRIDSPEC WIDTH HEIGHT (QUOTE POINT)
-			    WINDOW])
-)
-(DEFINEQ
-
-(SCALEBM
-  [LAMBDA (SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEWIDTH SRCEHEIGHT XSCALE YSCALE TEMPBM)
-                                                             (* N.H.Briggs " 4-Sep-87 15:48")
-                                                             (* ;; 
-							     
-"Magnify a bitmap as per EDITBM.  Use smearing algorithm.")
-    (LET ((DESTWIDTH (BITMAPWIDTH DESTBM))
-	  (DESTHEIGHT (if (WINDOWP DESTBM)
-			  then (WINDOWPROP DESTBM (QUOTE HEIGHT))
-			else (BITMAPHEIGHT DESTBM)))
-	  XSTEPS YSTEPS POWER)                               (* ;; "Check parameters, apply  defaults")
-         (if (NUMBERP SRCEWIDTH)
-	   else (SETQ SRCEWIDTH (BITMAPWIDTH SRCEBM)))
-         (if (NUMBERP SRCEHEIGHT)
-	   else (SETQ SRCEHEIGHT (BITMAPHEIGHT SRCEBM)))
-                                                             (* ;; 
-							     "Save effort by considering min of srce and dest.")
-         (SETQ DESTWIDTH (MIN DESTWIDTH (TIMES SRCEWIDTH XSCALE)))
-         (SETQ DESTHEIGHT (MIN DESTHEIGHT (TIMES SRCEHEIGHT YSCALE)))
-         (SETQ SRCEWIDTH (MIN SRCEWIDTH (IQUOTIENT DESTWIDTH XSCALE)))
-         (SETQ SRCEHEIGHT (MIN SRCEHEIGHT (IQUOTIENT DESTHEIGHT YSCALE)))
-         (if TEMPBM
-	     then (BLTSHADE WHITESHADE TEMPBM)
-	   else (SETQ TEMPBM (BITMAPCREATE DESTWIDTH SRCEHEIGHT)))
-                                                             (* ;; 
-							     
-"CALL EXPANDBM twice, once for each direction, because we have a spare bitmap which makes it run faster than a single call to EXPANDBM would (I think)."
-)                                                           (* ;; "")
-                                                             (* ;; "Do X Direction Smearing.")
-                                                             (* ;; "============")
-         (EXPANDBM SRCEBM SRCEX SRCEY SRCEWIDTH SRCEHEIGHT TEMPBM 0 0 DESTWIDTH SRCEHEIGHT XSCALE 1 
-		     XSCALE 1)                               (* ;; "")
-                                                             (* ;; "Do Y Direction Smearing.")
-                                                             (* ;; "============")
-         (EXPANDBM TEMPBM 0 0 DESTWIDTH SRCEHEIGHT DESTBM DESTX DESTY DESTWIDTH DESTHEIGHT 1 YSCALE 
-		     1 YSCALE)                               (* ;; "")
-                                                             (* ;; 
-							     "Return the temporary bitmap for recycling purposes.")
-     TEMPBM])
-
-(BLTPATTERN
-  [LAMBDA (SRCE SX SY SW SH DEST DX DY DW DH OPER TEMPBM)    (* N.H.Briggs " 4-Sep-87 15:10")
-                                                             (* ;; 
-							     
-"Fills region of Destination with tiles of Source region, using operation.  If Temporary bitmap is provided, use it for optimal performance."
-)
-    (PROG (W H RX RW)
-	    (if (NULL SW)
-		then (SETQ SW (BITMAPWIDTH SRCE)))
-	    (if (NULL SH)
-		then (SETQ SH (BITMAPHEIGHT SRCE)))    (* ;; "")
-                                                             (* ;; "Fill columns ")
-                                                             (* ;; "")
-	    [if TEMPBM
-		then                                       (* ;; 
-							     
-"Temporary bitmap is only useful if larger than source.")
-		       (if [AND (GREATERP (BITMAPWIDTH TEMPBM)
-						(MIN SW (BITMAPWIDTH SRCE)))
-				    (GREATERP (BITMAPHEIGHT TEMPBM)
-						(MIN SH (BITMAPHEIGHT SRCE]
-			   then (BLTPATTERN.REPLACEDISPLAY SRCE SX SY SW SH TEMPBM 0 0
-							       (BITMAPWIDTH TEMPBM)
-							       (BITMAPHEIGHT TEMPBM))
-                                                             (* ;; 
-							     
-"Allow code to fall through using TEMPBM as source area.")
-				  (SETQ SRCE TEMPBM)
-				  (SETQ SX 0)
-				  (SETQ SY 0)
-				  (SETQ SW (ITIMES SW (IQUOTIENT (BITMAPWIDTH TEMPBM)
-								       SW)))
-				  (SETQ SH (ITIMES SH (IQUOTIENT (BITMAPHEIGHT TEMPBM)
-								       SH]
-	    (if (AND (EQ OPER (QUOTE REPLACE))
-			 (OR (BITMAPP DEST)
-			       (WINDOWP DEST)))
-		then (BLTPATTERN.REPLACEDISPLAY SRCE SX SY SW SH DEST DX DY DW DH)
-		       (RETURN))                           (* ;; 
-							     
-"Even if operation is REPLACE, don't know if destination is inexpensively readable (e.g. Interpress stream.  SO, this is the general case here."
-)
-	    (while (GREATERP DH 0)
-	       do (SETQ H (MIN SH DH))                 (* ;; "")
-		    (SETQ RW DW)
-		    (SETQ RX DX)                           (* ;; "")
-                                                             (* ;; "Fill rows")
-                                                             (* ;; "")
-		    (while (GREATERP RW 0)
-		       do (SETQ W (MIN SW RW))
-			    (BITBLT SRCE SX SY DEST RX DY W H NIL OPER)
-			    (SETQ RW (DIFFERENCE RW W))
-			    (SETQ RX (PLUS RX W)))       (* ;; "")
-		    (SETQ DH (DIFFERENCE DH H))
-		    (SETQ DY (PLUS DY H])
-
-(BLTPATTERN.REPLACEDISPLAY
-  [LAMBDA (SRCE SX SY SW SH DEST DX DY DW DH)                (* N.H.Briggs " 4-Sep-87 15:11")
-                                                             (* ;; 
-							     
-"This routine only replaces the destination with the source, and assumes the destination itself can be easily read from and blt'ed to."
-)                                                           (* ;; 
-							     
-"Put initial bitmap into destination.  Source should not be within destination area, otherwise it will be overwritten."
-)
-    (LET (RX RY RW RH W H)                                   (* ; "R's are remaining area.")
-         (SETQ W (MIN SW DW))
-         (SETQ H (MIN SH DH))
-         (BLTSHADE WHITESHADE DEST DX DY W H (QUOTE REPLACE))
-         (BITBLT SRCE SX SY DEST DX DY W H NIL (QUOTE REPLACE))
-         (SETQ RX (PLUS DX W))
-         (SETQ RW (DIFFERENCE DW W))                     (* ;; "Now power up until width is full.")
-         (while (GREATERP RW 0)
-	    do (SETQ W (MIN SW RW))
-		 (BITBLT DEST DX DY DEST RX DY W H NIL (QUOTE REPLACE))
-		 (SETQ RW (DIFFERENCE RW W))             (* ; "Reduce remaining width")
-		 (SETQ RX (PLUS RX W))                   (* ; "Set next starting position")
-		 (SETQ SW (PLUS SW SW))                  (* ; "Can now use 2x area."))
-                                                             (* ;; "")
-         (SETQ RY (PLUS DY H))
-         (SETQ RH (DIFFERENCE DH H))
-         (SETQ SH H)
-         (SETQ W DW)                                       (* ;; "Now power up until height is full.")
-         (while (GREATERP RH 0)
-	    do (SETQ H (MIN SH RH))
-		 (BITBLT DEST DX DY DEST DX RY W H NIL (QUOTE REPLACE))
-		 (SETQ RH (DIFFERENCE RH H))             (* ; "Reduce remaining width")
-		 (SETQ RY (PLUS RY H))                   (* ; "Set next starting position")
-		 (SETQ SH (PLUS SH SH))                  (* ; "Can now use 2x area.")])
-)
-(DEFINEQ
-
-(EXPANDBITMAP
-  [LAMBDA (BITMAP WIDTHFACTOR HEIGHTFACTOR)                  (* N.H.Briggs "16-Nov-87 17:10")
-                                                             (* ;; 
-							     
-"Returns a new bitmap which is WidthFactor and HeightFactor bigger.")
-                                                             (* ;; 
-							     
-"FS:  This slow piece of code has been replaced with a much faster, general one, EXPAND.l ")
-    (LET (WIDTH HEIGHT BITSPERPIXEL NEWWIDTH NEWHEIGHT NEWX NEWY NEWBITMAP)
-         (OR WIDTHFACTOR (SETQ WIDTHFACTOR 1))
-         (OR HEIGHTFACTOR (SETQ HEIGHTFACTOR 1))
-         (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP))
-         (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP))
-         (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP))
-         (SETQ NEWWIDTH (ITIMES WIDTHFACTOR WIDTH))
-         (SETQ NEWHEIGHT (ITIMES HEIGHTFACTOR HEIGHT))
-         (SETQ NEWBITMAP (BITMAPCREATE NEWWIDTH NEWHEIGHT BITSPERPIXEL))
-                                                             (* ;; "OLD code commented out here.")
-
-          (* LET NIL (* Expand in x-direction. *) (SETQ NEWX 0) (for X from 0 to (SUB1 WIDTH) do (for I from 1 to WIDTHFACTOR
-	  do (BITBLT BITMAP X 0 NEWBITMAP NEWX 0 1 HEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (add NEWX 1))) 
-	  (* Expand in y-direction. *) (SETQ NEWY (SUB1 NEWHEIGHT)) (for Y from (SUB1 HEIGHT) to 0 by -1 do 
-	  (for I from 1 to HEIGHTFACTOR do (BITBLT NEWBITMAP 0 Y NEWBITMAP 0 NEWY NEWWIDTH 1 (QUOTE INPUT) 
-	  (QUOTE REPLACE)) (add NEWY -1))))
-
-
-         (EXPANDBM BITMAP 0 0 WIDTH HEIGHT NEWBITMAP 0 0 NEWWIDTH NEWHEIGHT WIDTHFACTOR 
-		     HEIGHTFACTOR WIDTHFACTOR HEIGHTFACTOR)
-     NEWBITMAP])
-
-(EXPANDBM
-  [LAMBDA (SRCEBM SRCEX SRCEY SRCEW SRCEH DESTBM DESTX DESTY DESTW DESTH XSCALE YSCALE XSPACE YSPACE)
-                                                             (* N.H.Briggs " 4-Sep-87 15:18")
-                                                             (* ;; 
-							     
-"Expands a region of SrceBM by X&Y scale into a region of DestBM, spaced Xspace by YSpace apart (space must be larger than scale).  SrceBM cannot be the same bitmap as DestBM.  The entire region inside DestBM is cleared."
-)
-    (PROG (XSTEPS YSTEPS POWER)                            (* ;; "Check parameters, apply  defaults")
-	    (if (NUMBERP SRCEX)
-	      else (SETQ SRCEX 0))
-	    (if (NUMBERP SRCEY)
-	      else (SETQ SRCEY 0))
-	    (if (NUMBERP SRCEW)
-	      else (SETQ SRCEW (BITMAPWIDTH SRCEBM)))
-	    (if (NUMBERP SRCEH)
-	      else (SETQ SRCEH (BITMAPHEIGHT SRCEBM)))
-	    (if (NUMBERP DESTX)
-	      else (SETQ SRCEX 0))
-	    (if (NUMBERP DESTY)
-	      else (SETQ SRCEY 0))                       (* ;; 
-							     "Save effort by considering min of srce and dest.")
-	    [SETQ DESTW (IMIN DESTW (TIMES SRCEW (IMAX XSCALE XSPACE]
-	    [SETQ DESTH (IMIN DESTH (TIMES SRCEH (IMAX YSCALE YSPACE]
-	    [SETQ SRCEW (IMIN SRCEW (PLUS 1 (IQUOTIENT DESTW (IMAX XSCALE XSPACE]
-	    [SETQ SRCEH (IMIN SRCEH (PLUS 1 (IQUOTIENT DESTH (IMAX YSCALE YSPACE]
-	    (BLTSHADE WHITESHADE DESTBM DESTX DESTY DESTW DESTH)
-	    (if (AND (EQP XSPACE 1)
-			 (EQP YSPACE 1))
-		then (BITBLT SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEW SRCEH)
-		       (RETURN DESTBM))                    (* ;; "")
-                                                             (* ;; "Do X Direction Smearing.")
-                                                             (* ;; "============")
-                                                             (* ;; 
-							     
-"Spread out bitmap by spacefactor.  Start from far side to avoid overwrite (if srce = dest)")
-	    (if (EQP XSPACE 1)
-		then                                       (* ;; 
-							     
-"Don't fill destination, instead use srce in YSmear loop.")
-                                                             (* ;; 
-							     
-"(BITBLT SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEW SRCEH)")
-		       
-	      else                                         (* ;; 
-							     
-"Spread out bitmap by spacefactor.  Start from far side to avoid overwrite (if srce = dest)")
-		     (for I from (SUB1 SRCEW) to 0 by -1
-			do (BITBLT SRCEBM (PLUS SRCEX I)
-				       SRCEY DESTBM (PLUS DESTX (TIMES I XSPACE))
-				       DESTY 1 SRCEH)))      (* ;; 
-							     
-"Now smear by scalefactor.  Each step smears out a power of two.  LSH is in ucode.")
-	    [if (EQP XSCALE 1)
-	      else (SETQ POWER 1)
-		     (while (ILEQ POWER (LSH XSCALE -1))
-			do                                 (* ;; 
-							     
-"In the X direction, only need to blt SRCEH bits high, and must shorten W to remain within DESTW")
-			     (BITBLT DESTBM DESTX DESTY DESTBM (PLUS DESTX POWER)
-				       DESTY
-				       (DIFFERENCE DESTW POWER)
-				       SRCEH NIL (QUOTE PAINT))
-			     (SETQ POWER (PLUS POWER POWER)))
-                                                             (* ;; "Clean up for non power of two.")
-		     (if (ZEROP (DIFFERENCE XSCALE POWER))
-		       else (BITBLT DESTBM DESTX DESTY DESTBM (PLUS DESTX (DIFFERENCE XSCALE 
-											    POWER))
-					DESTY
-					(DIFFERENCE DESTW (DIFFERENCE XSCALE POWER))
-					SRCEH NIL (QUOTE PAINT]
-                                                             (* ;; "")
-                                                             (* ;; "Do Y Direction Smearing.")
-                                                             (* ;; "============")
-                                                             (* ;; 
-							     
-"Spread out bitmap by spacefactor.  Start from far side to avoid overwrite (if srce = dest)")
-	    [if (EQP YSPACE 1)
-	      else (if (EQP XSPACE 1)
-			 then                              (* ;; 
-							     
-"Didn't need to paint in destination, so can avoid second loop by blting from SRCBM instead of DESTBM.")
-				(for J from (SUB1 SRCEH) to 0 by -1
-				   do (BITBLT SRCEBM SRCEX (PLUS SRCEY J)
-						  DESTBM DESTX (PLUS DESTY (TIMES J YSPACE))
-						  DESTW 1))
-		       else (for J from (SUB1 SRCEH) to 0 by -1
-				 do (BITBLT DESTBM DESTX (PLUS DESTY J)
-						DESTBM DESTX (PLUS DESTY (TIMES J YSPACE))
-						DESTW 1))    (* ;; 
-							     
-"Since we reused DESTBM, parts of the dest have bits in them but shouldn't.  So, clear them.")
-			      (for J from 0 to SRCEH by YSPACE
-				 do (BLTSHADE WHITESHADE DESTBM DESTX (PLUS DESTY J 1)
-						  DESTW
-						  (SUB1 YSPACE]
-                                                             (* ;; 
-							     
-"Now smear correctly.  Each step smears out a power of two.  LSH is in ucode.")
-	    [if (EQP YSCALE 1)
-	      else (SETQ POWER 1)
-		     (while (ILEQ POWER (LSH YSCALE -1))
-			do (BITBLT DESTBM DESTX DESTY DESTBM DESTX (PLUS DESTY POWER)
-				       DESTW
-				       (DIFFERENCE DESTH POWER)
-				       NIL
-				       (QUOTE PAINT))
-			     (SETQ POWER (PLUS POWER POWER)))
-                                                             (* ;; "Clean up for non power of two.")
-		     (if (ZEROP (DIFFERENCE YSCALE POWER))
-		       else (BITBLT DESTBM DESTX DESTY DESTBM DESTX (PLUS DESTY
-										(DIFFERENCE YSCALE 
-											    POWER))
-					DESTW DESTH NIL (QUOTE PAINT]
-                                                             (* ;; "")
-                                                             (* ;; 
-							     "Return the temporary bitmap for recycling purposes.")
-	DESTBM])
-)
-(PUTPROPS FASTEDITBM COPYRIGHT ("Xerox Corporation" 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (1041 4849 (GRID 1051 . 4847)) (4850 52348 (EDITBM 4860 . 13712) (EDITBMCLOSEFN 13714 . 
-14345) (TILEAREA 14347 . 14779) (EDITBMBUTTONFN 14781 . 29731) (EDITBMSCROLLFN 29733 . 40923) (
-\EDITBM/PUTUP/DISPLAY 40925 . 41674) (EDITBMRESHAPEFN 41676 . 47657) (EDITBMREPAINTFN.NEW 47659 . 
-47983) (EDITBMREPAINTFN 47985 . 49598) (RESETGRID.NEW 49600 . 52346)) (52349 59854 (SCALEBM 52359 . 
-54995) (BLTPATTERN 54997 . 57709) (BLTPATTERN.REPLACEDISPLAY 57711 . 59852)) (59855 68063 (
-EXPANDBITMAP 59865 . 61694) (EXPANDBM 61696 . 68061)))))
-STOP
diff --git a/obsolete/lispusers/FONTDECLS b/obsolete/lispusers/FONTDECLS
deleted file mode 100644
index eeaf3c9e..00000000
--- a/obsolete/lispusers/FONTDECLS
+++ /dev/null
@@ -1,207 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10)
-(FILECREATED "27-Sep-87 16:13:36" {DSK}<OST>FONTDECLS.;7 10151  
-
-      changes to%:  (VARS FONTDECLSCOMS)
-
-      previous date%: "25-Sep-87 22:24:36" {DSK}<OST>FONTDECLS.;6)
-
-
-(PRETTYCOMPRINT FONTDECLSCOMS)
-
-(RPAQQ FONTDECLSCOMS ((PROP MAKEFILE-ENVIRONMENT FONTDECLS)
-                      (RECORDS FONTDESCRIPTOR CHARSETINFO)
-                      (CONSTANTS WORDSPERCELL \MAXCHARSET \MAXTHINCHAR)
-                      (MACROS FOLDHI UNFOLD \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR 
-                             \FGETIMAGEWIDTH \FGETOFFSET \FGETWIDTH \FSETIMAGEWIDTH \FSETOFFSET 
-                             \FSETWIDTH \GETCHARSETINFO \SETCHARSETINFO)))
-
-(PUTPROPS FONTDECLS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10))
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER)
-                          (\SFObsolete1 POINTER)             (* WAS CHARACTERBITMAP)
-                                                             (* Bitmap containing the character 
-                                                             images, indexed by \SFOffsets)
-                          (FONTFAMILY POINTER)
-                          (FONTSIZE POINTER)
-                          (FONTFACE POINTER)
-                          (\SFObsolete2 POINTER)             (* Was \SFWidths)
-          
-          (* The advance-width of each character, an array indexed by charcode.
-          Usually the same as the imagewidth, but can differ for accents, kerns kerns.
-          This is what should be used for stringwidth calculations.)
-
-                          (\SFObsolete3 POINTER)             (* WAS \SFOffsets)
-          
-          (* Offset of each character into the image bitmap;
-          X value of left edge)
-
-                          (\SFObsolete4 POINTER)             (* Was \SFWidthsY)
-                          (\SFObsolete5 WORD)                (* WAS FIRSTCHAR)
-          
-          (* Charcode of the first character that exists in the font)
-
-                          (\SFObsolete6 WORD)                (* WAS LASTCHAR)
-          
-          (* Charcode of the last character that exists in the font)
-
-                          (\SFAscent WORD)
-                          (\SFDescent WORD)
-                          (\SFHeight WORD)
-                          (ROTATION WORD)
-                          (FBBOX SIGNEDWORD)
-                          (FBBOY SIGNEDWORD)
-                          (FBBDX SIGNEDWORD)
-                          (FBBDY SIGNEDWORD)
-                          (\SFFACECODE BITS 8)
-                          (\SFLKerns POINTER)
-                          (\SFRWidths POINTER)
-                          (FONTDEVICESPEC POINTER)
-          
-          (* Holds the spec by which the font is known to the printing device, if 
-          coercion has been done)
-
-                          (OTHERDEVICEFONTPROPS POINTER)     (* For individual devices to hang 
-                                                             special information)
-                          (FONTSCALE POINTER)
-                          (FONTAVGCHARWIDTH WORD)
-          
-          (* Set in FONTCREATE, used to fix up the linelength when DSPFONT is called)
-
-                          (FONTIMAGEWIDTHS POINTER)
-          
-          (* This is the image width, as opposed to the advanced width;
-          initial hack for accents, kerning. Fields is referenced by FONTCREATE.)
-
-                          (FONTCHARSETVECTOR POINTER)
-          
-          (* A 256-pointer block, with one pointer per "character set" --each group of 
-          256 character codes. Each pointer is either NIL if there's no info for that 
-          charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the 
-          characters in that charset.)
-
-                          (FONTEXTRAFIELD2 POINTER))
-                         FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR))
-
-(DATATYPE CHARSETINFO (WIDTHS 
-          
-          (* The advance-width of each character, an array indexed by charcode.
-          Usually the same as the imagewidth, but can differ for accents, kerns kerns.
-          This is what should be used for stringwidth calculations.)
-
-                             OFFSETS
-          
-          (* Offset of each character into the image bitmap;
-          X value of left edge)
-
-                             IMAGEWIDTHS
-          
-          (* imagewidths is not automagically allocated since it is not always needed)
-
-                             CHARSETBITMAP                   (* Bitmap containing the character 
-                                                             images, indexed by OFFSETS)
-                             YWIDTHS
-                             (CHARSETASCENT WORD)            (* Max ascent for all characters in 
-                                                             this CHARSET)
-                             (CHARSETDESCENT WORD)           (* Max descent for all characters in 
-                                                             this CHARSET)
-                             )
-                      WIDTHS _ (\CREATECSINFOELEMENT)
-                      OFFSETS _ (\CREATECSINFOELEMENT))
-)
-(/DECLAREDATATYPE 'FONTDESCRIPTOR
-       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD 
-               WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD (BITS 8)
-               POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER)
-       '((FONTDESCRIPTOR 0 POINTER)
-         (FONTDESCRIPTOR 2 POINTER)
-         (FONTDESCRIPTOR 4 POINTER)
-         (FONTDESCRIPTOR 6 POINTER)
-         (FONTDESCRIPTOR 8 POINTER)
-         (FONTDESCRIPTOR 10 POINTER)
-         (FONTDESCRIPTOR 12 POINTER)
-         (FONTDESCRIPTOR 14 POINTER)
-         (FONTDESCRIPTOR 16 (BITS . 15))
-         (FONTDESCRIPTOR 17 (BITS . 15))
-         (FONTDESCRIPTOR 18 (BITS . 15))
-         (FONTDESCRIPTOR 19 (BITS . 15))
-         (FONTDESCRIPTOR 20 (BITS . 15))
-         (FONTDESCRIPTOR 21 (BITS . 15))
-         (FONTDESCRIPTOR 22 (SIGNEDBITS . 15))
-         (FONTDESCRIPTOR 23 (SIGNEDBITS . 15))
-         (FONTDESCRIPTOR 24 (SIGNEDBITS . 15))
-         (FONTDESCRIPTOR 25 (SIGNEDBITS . 15))
-         (FONTDESCRIPTOR 14 (BITS . 7))
-         (FONTDESCRIPTOR 26 POINTER)
-         (FONTDESCRIPTOR 28 POINTER)
-         (FONTDESCRIPTOR 30 POINTER)
-         (FONTDESCRIPTOR 32 POINTER)
-         (FONTDESCRIPTOR 34 POINTER)
-         (FONTDESCRIPTOR 36 (BITS . 15))
-         (FONTDESCRIPTOR 38 POINTER)
-         (FONTDESCRIPTOR 40 POINTER)
-         (FONTDESCRIPTOR 42 POINTER))
-       '44)
-(/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD)
-       '((CHARSETINFO 0 POINTER)
-         (CHARSETINFO 2 POINTER)
-         (CHARSETINFO 4 POINTER)
-         (CHARSETINFO 6 POINTER)
-         (CHARSETINFO 8 POINTER)
-         (CHARSETINFO 10 (BITS . 15))
-         (CHARSETINFO 11 (BITS . 15)))
-       '12)
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ WORDSPERCELL 2)
-
-(RPAQQ \MAXCHARSET 255)
-
-(RPAQQ \MAXTHINCHAR 255)
-
-(CONSTANTS WORDSPERCELL \MAXCHARSET \MAXTHINCHAR)
-)
-(DECLARE%: EVAL@COMPILE 
-[PUTPROPS FOLDHI MACRO (X (PROG [(FORM (CAR X))
-                                 (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X]
-                                (OR (AND DIVISOR (POWEROFTWOP DIVISOR))
-                                    (\ILLEGAL.ARG (CADR X)))
-                                (RETURN (LIST 'LRSH (LIST 'IPLUS FORM (SUB1 DIVISOR))
-                                              (SUB1 (INTEGERLENGTH DIVISOR]
-[PUTPROPS UNFOLD MACRO (X (PROG [(FORM (CAR X))
-                                 (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X]
-                                (OR (AND DIVISOR (POWEROFTWOP DIVISOR))
-                                    (\ILLEGAL.ARG (CADR X)))
-                                (RETURN (LIST 'LLSH FORM (SUB1 (INTEGERLENGTH DIVISOR]
-[PUTPROPS \CREATECSINFOELEMENT MACRO (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3)
-                                                              WORDSPERCELL]
-(PUTPROPS \CREATEFONTCHARSETVECTOR MACRO (NIL (* Allocates a block for the character set records)
-                                              (\ALLOCBLOCK (ADD1 \MAXCHARSET)
-                                                     T)))
-(PUTPROPS \FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE)
-                                 (\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE)))
-(PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE)
-                              (\GETBASE OFFSETSBLOCK CHAR8CODE)))
-(PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE)
-                             (\GETBASE WIDTHSBLOCK CHAR8CODE)))
-(PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
-                                  (\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
-(PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET)
-                              (\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET)))
-(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH)
-                             (\PUTBASE WIDTHSBLOCK INDEX WIDTH)))
-[PUTPROPS \GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?)
-                                 (* * fetches the charsetinfo for charset CHARSET in fontdescriptor 
-                                    FONTDESC. If NIL, then creates the required charset.)
-                                 (* * NOSLUG? means don't create an empty (slug)
-                                    csinfo if the charset is not found, just return NIL)
-                                 (OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC)
-                                            (UNFOLD CHARSET 2))
-                                     (\CREATECHARSET CHARSET FONTDESC NOSLUG?]
-(PUTPROPS \SETCHARSETINFO MACRO ((CHARSETVECTOR CHARSET CSINFO)
-                                 (\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2)
-                                        CSINFO)))
-)
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
diff --git a/obsolete/lispusers/HGRAPH b/obsolete/lispusers/HGRAPH
deleted file mode 100644
index 31e16306..00000000
--- a/obsolete/lispusers/HGRAPH
+++ /dev/null
@@ -1,281 +0,0 @@
-(FILECREATED "24-Apr-87 19:08:21" {ERIS}<LISPUSERS>KOTO>HGRAPH.;2 12562  
-
-      changes to:  (FNS HARDCOPYWHOLEGRAPH)
-
-      previous date: "27-Jan-87 14:35:21" {PHYLUM}<LISPUSERS>KOTO>HGRAPH.;1)
-
-
-(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT HGRAPHCOMS)
-
-(RPAQQ HGRAPHCOMS ((FNS CEILING HARDCOPYDISPLAYGRAPH HARDCOPYWHOLEGRAPH)
-		     (P (MOVD (QUOTE HARDCOPYGRAPH)
-			      (QUOTE OLDHARDCOPYGRAPH))
-			(MOVD (QUOTE HARDCOPYWHOLEGRAPH)
-			      (QUOTE HARDCOPYGRAPH)))
-		     (* This is in order to fix the problem with borders on Interpress printers. I\t 
-			seems that you cannot bitblt anything thinner than 36 pixel onto an 
-			Interpress stream, why? Anyway, this fixes the problem by setting the border 
-			width to 36)))
-(DEFINEQ
-
-(CEILING
-  [LAMBDA (NUMBER)
-    (COND
-      ((EQP (FIX NUMBER)
-	      NUMBER)
-	NUMBER)
-      (T (ADD1 (FIX NUMBER])
-
-(HARDCOPYDISPLAYGRAPH
-  [LAMBDA (GRAPH STREAM CLIP/REG TRANS)                      (* bbb "27-Jan-87 11:52")
-
-          (* Displays GRAPH with coordinates system translated to TRANS on STREAM. POS=NIL is interpreted as 0\,0.
-	  Draws links first then labels so that lattices don't have lines through the labels.)
-
-                                                             (* This function is to be used together with 
-							     HARDCOPYWHOLEGRAPH\, it assumes that the scaling of 
-							     the graph is done already, for efficiency.)
-    (PROG (SCALE (LINEWIDTH 1))
-	    [OR (type? POSITION TRANS)
-		  (SETQ TRANS (CONSTANT (create POSITION
-						      XCOORD _ 0
-						      YCOORD _ 0]
-	    (SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT)))
-	    (COND
-	      ((DISPLAYSTREAMP STREAM)
-
-          (* This is because PRIN3 on displaystreams can sometimes cause CR's to be output. GRAPHER/CENTERPRINTINAREA doesn't
-	  have the rightmargin kludge that the CENTERPRINTINAREA in MENU has.)
-
-
-		(DSPRIGHTMARGIN 65000 STREAM))
-	      (T (SETQ SCALE (DSPSCALE NIL STREAM))
-		 [SETQ TRANS (create POSITION
-					 XCOORD _ (FIXR (FTIMES SCALE (fetch XCOORD
-									       of TRANS)))
-					 YCOORD _ (FIXR (FTIMES SCALE (fetch YCOORD
-									       of TRANS]
-		 (SETQ LINEWIDTH SCALE)))
-	    (for N in (fetch (GRAPH GRAPHNODES) of GRAPH)
-	       do (DISPLAYNODELINKS N TRANS STREAM GRAPH T LINEWIDTH))
-	    (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) do (PRINTDISPLAYNODE N TRANS 
-											   STREAM 
-											 CLIP/REG])
-
-(HARDCOPYWHOLEGRAPH
-  [LAMBDA (GraphOrWindow File ImageType Translation NoAlignmentDots DontCloseStream)
-                                                             (* N.H.Briggs "24-Apr-87 19:07")
-
-          (* * Hardcopy \a whole graph from \a window using as many pages as necessary)
-
-                                                             (* fix: moved SCALE/GRAPH outside the for loops for 
-							     effiency.)
-                                                             (* fix: moved SCALE.REGION inline, in order to avoid 
-							     the LOADFNS in the COMS list.)
-    (LET ((Stream (OR (AND File (OPENP File (QUOTE OUTPUT))
-			       File)
-			(OPENIMAGESTREAM File ImageType)))
-	  (Graph (COND
-		   ((WINDOWP GraphOrWindow)
-		     (WINDOWPROP GraphOrWindow (QUOTE GRAPH)))
-		   (T GraphOrWindow)))
-	  GraphUnitsPerPageUnit PageUnitsPerGraphUnit GraphRegionInGraphUnits GraphRegionInPageUnits 
-	  PageRegion PageWidthInGraphUnits PageHeightInGraphUnits GraphWidthInGraphUnits 
-	  GraphHeightInGraphUnits CornerXOffsetInGraphUnits CornerYOffsetInGraphUnits PageScale 
-	  LeftCenteringOffsetInGraphUnits BottomCenteringOffsetInGraphUnits PageNumberFont 
-	  NumberOfXPages NumberOfYPages XPageNumberPositionInPageUnits YPageNumberPositionInPageUnits 
-	  LeftXAlignmentInPageUnits RightXAlignmentInPageUnits LowerYAlignmentInPageUnits 
-	  UpperYAlignmentInPageUnits PageUnitsPerInch)
-         (SETQ PageScale (DSPSCALE NIL Stream))
-         (SETQ GraphUnitsPerPageUnit (FQUOTIENT 1.0 PageScale))
-         (SETQ PageUnitsPerGraphUnit PageScale)            (* 72 screen points per inch.)
-         (SETQ PageUnitsPerInch (TIMES PageScale 72))
-         (SETQ GraphRegionInGraphUnits (GRAPHREGION Graph))
-         (SETQ CornerXOffsetInGraphUnits (MINUS (fetch (REGION LEFT) of 
-									  GraphRegionInGraphUnits)))
-         (SETQ CornerYOffsetInGraphUnits (MINUS (fetch (REGION BOTTOM) of 
-									  GraphRegionInGraphUnits)))
-                                                             (* fix: moved SCALE.REGION inline, in order to avoid 
-							     the LOADFNS in the COMS list.)
-         [SETQ GraphRegionInPageUnits (CREATEREGION (FIXR (QUOTIENT (fetch (REGION LEFT)
-									       of 
-									  GraphRegionInGraphUnits)
-									    GraphUnitsPerPageUnit))
-							(FIXR (QUOTIENT (fetch (REGION BOTTOM)
-									       of 
-									  GraphRegionInGraphUnits)
-									    GraphUnitsPerPageUnit))
-							(FIXR (QUOTIENT (fetch (REGION WIDTH)
-									       of 
-									  GraphRegionInGraphUnits)
-									    GraphUnitsPerPageUnit))
-							(FIXR (QUOTIENT (fetch (REGION HEIGHT)
-									       of 
-									  GraphRegionInGraphUnits)
-									    GraphUnitsPerPageUnit]
-         (SELECTQ (IMAGESTREAMTYPE Stream)
-		    [INTERPRESS 
-
-          (* * Make the clipping region be the whole page on Interpress streams)
-
-
-				(DSPCLIPPINGREGION (CREATEREGION 0 0 (FIXR (TIMES 
-										 PageUnitsPerInch 8.5)
-										 )
-								     (FIXR (TIMES 
-										 PageUnitsPerInch 
-										      11.0)))
-						     Stream)
-
-          (* * Get rid of 1 inch margins except .5 inch at right and top)
-
-
-				(SETQ PageRegion (CREATEREGION 0 0 (FIXR (TIMES 
-										 PageUnitsPerInch 8.0)
-									       )
-								   (FIXR (TIMES PageUnitsPerInch 
-										    10.5]
-		    [PRESS 
-
-          (* * Make the clipping region be the whole page on Press streams)
-
-
-			   (DSPCLIPPINGREGION (CREATEREGION 0 0 (FIXR (TIMES PageUnitsPerInch 
-										     8.5))
-								(FIXR (TIMES PageUnitsPerInch 
-										 11.0)))
-						Stream)
-
-          (* * Get rid of 1 inch margins except 1 inch at right and top)
-
-
-			   (SETQ PageRegion (CREATEREGION 0 0 (FIXR (TIMES PageUnitsPerInch 
-										   7.5))
-							      (FIXR (TIMES PageUnitsPerInch 10.0]
-		    (SETQ PageRegion (DSPCLIPPINGREGION NIL Stream)))
-         (SETQ PageWidthInGraphUnits (TIMES (fetch (REGION WIDTH) of PageRegion)
-						GraphUnitsPerPageUnit))
-         (SETQ PageHeightInGraphUnits (TIMES (fetch (REGION HEIGHT) of PageRegion)
-						 GraphUnitsPerPageUnit))
-         (SETQ GraphWidthInGraphUnits (fetch (REGION WIDTH) of GraphRegionInGraphUnits))
-         (SETQ GraphHeightInGraphUnits (fetch (REGION HEIGHT) of GraphRegionInGraphUnits))
-         (SETQ BottomCenteringOffsetInGraphUnits (QUOTIENT (DIFFERENCE PageHeightInGraphUnits
-									     (REMAINDER 
-									  GraphHeightInGraphUnits 
-									   PageHeightInGraphUnits))
-							       1.75))
-         (SETQ LeftCenteringOffsetInGraphUnits (QUOTIENT (DIFFERENCE PageWidthInGraphUnits
-									   (REMAINDER 
-									   GraphWidthInGraphUnits 
-									    PageWidthInGraphUnits))
-							     1.75))
-         (SETQ NumberOfYPages (CEILING (QUOTIENT GraphHeightInGraphUnits PageHeightInGraphUnits)
-					   ))
-         (SETQ NumberOfXPages (CEILING (QUOTIENT GraphWidthInGraphUnits PageWidthInGraphUnits)))
-         (SETQ PageNumberFont (FONTCREATE (QUOTE MODERN)
-					      6))
-
-          (* * The page numbers are \a quarter of in after the edge of the printing edge and are in the upper right hand 
-	  corner of the page. The pages are printed row-wise and no page numbers are printed on the last page.
-	  The page numbers are positioned .25 inch to the right of the right edge of the page region and .35 inch up from the
-	  top of the page region. The alignment dots are .25 inch to the right of the right edge of the page region and .25 
-	  inch up from the page region.)
-
-
-         (SETQ XPageNumberPositionInPageUnits (PLUS (fetch (REGION RIGHT) of PageRegion)
-							(TIMES PageUnitsPerInch .25)))
-         (SETQ YPageNumberPositionInPageUnits (PLUS (fetch (REGION TOP) of PageRegion)
-							(TIMES PageUnitsPerInch .35)))
-         (SETQ LeftXAlignmentInPageUnits (TIMES PageUnitsPerInch .25))
-         (SETQ RightXAlignmentInPageUnits (PLUS (fetch (REGION RIGHT) of PageRegion)
-						    (TIMES PageUnitsPerInch .25)))
-         (SETQ LowerYAlignmentInPageUnits (TIMES PageUnitsPerInch .25))
-         (SETQ UpperYAlignmentInPageUnits (PLUS (fetch (REGION TOP) of PageRegion)
-						    (TIMES PageUnitsPerInch .25)))
-                                                             (* Latest fix: moved SCALE/GRAPH outside the for loops
-							     for effiency.)
-         (SETQ Graph (SCALE/GRAPH Graph Stream PageScale))
-         [for BottomOfPageInGraphUnits from 0 to GraphHeightInGraphUnits by 
-									   PageHeightInGraphUnits
-	    as YPageNumber from 1
-	    do (for LeftOfPageInGraphUnits from 0 to GraphWidthInGraphUnits by 
-									    PageWidthInGraphUnits
-		    as XPageNumber from 1
-		    do [HARDCOPYDISPLAYGRAPH Graph Stream (DSPCLIPPINGREGION NIL Stream)
-						 (create POSITION
-							   XCOORD _ (FIXR (PLUS 
-									CornerXOffsetInGraphUnits 
-								  LeftCenteringOffsetInGraphUnits
-										      (MINUS 
-									   LeftOfPageInGraphUnits)))
-							   YCOORD _ (FIXR (PLUS 
-								BottomCenteringOffsetInGraphUnits 
-									CornerYOffsetInGraphUnits
-										      (MINUS 
-									 BottomOfPageInGraphUnits]
-
-          (* * Print the alignment points)
-
-
-			 [COND
-			   ((NOT NoAlignmentDots)
-
-          (* * The lower left page should not have \a dot in the lower left corner. Similarly for other corner pages.)
-
-
-			     (COND
-			       ((NOT (AND (EQ XPageNumber 1)
-					      (EQ YPageNumber 1)))
-				 (MOVETO LeftXAlignmentInPageUnits LowerYAlignmentInPageUnits 
-					   Stream)
-				 (printout Stream ".")))
-			     (COND
-			       ((NOT (AND (EQ XPageNumber NumberOfXPages)
-					      (EQ YPageNumber 1)))
-				 (MOVETO RightXAlignmentInPageUnits LowerYAlignmentInPageUnits 
-					   Stream)
-				 (printout Stream ".")))
-			     (COND
-			       ((NOT (AND (EQ YPageNumber NumberOfYPages)
-					      (EQ XPageNumber 1)))
-				 (MOVETO LeftXAlignmentInPageUnits UpperYAlignmentInPageUnits 
-					   Stream)
-				 (printout Stream ".")))
-			     (COND
-			       ((NOT (AND (EQ XPageNumber NumberOfXPages)
-					      (EQ YPageNumber NumberOfYPages)))
-				 (MOVETO RightXAlignmentInPageUnits UpperYAlignmentInPageUnits 
-					   Stream)
-				 (printout Stream "."]
-			 (COND
-			   ((NOT (AND (EQ XPageNumber NumberOfXPages)
-					  (EQ YPageNumber NumberOfYPages)))
-                                                             (* Not on the very last page)
-			     (DSPFONT PageNumberFont Stream)
-			     (MOVETO XPageNumberPositionInPageUnits YPageNumberPositionInPageUnits 
-				       Stream)
-			     (printout Stream XPageNumber "," YPageNumber)
-                                                             (* Print the page number)
-			     (DSPNEWPAGE Stream]
-         (COND
-	   ((NOT DontCloseStream)
-	     (CLOSEF Stream])
-)
-(MOVD (QUOTE HARDCOPYGRAPH)
-      (QUOTE OLDHARDCOPYGRAPH))
-(MOVD (QUOTE HARDCOPYWHOLEGRAPH)
-      (QUOTE HARDCOPYGRAPH))
-
-
-
-(* This is in order to fix the problem with borders on Interpress printers. I\t seems that you
- cannot bitblt anything thinner than 36 pixel onto an Interpress stream, why? Anyway, this 
-fixes the problem by setting the border width to 36)
-
-(PUTPROPS HGRAPH COPYRIGHT ("Xerox Corporation" 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (779 12115 (CEILING 789 . 928) (HARDCOPYDISPLAYGRAPH 930 . 2653) (HARDCOPYWHOLEGRAPH 
-2655 . 12113)))))
-STOP
diff --git a/obsolete/lispusers/HGRAPH.LCOM b/obsolete/lispusers/HGRAPH.LCOM
deleted file mode 100644
index e4620f4e..00000000
Binary files a/obsolete/lispusers/HGRAPH.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/HOSTUP b/obsolete/lispusers/HOSTUP
deleted file mode 100644
index 2327173c..00000000
--- a/obsolete/lispusers/HOSTUP
+++ /dev/null
@@ -1,185 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "19-Oct-89 17:18:44" {ICE}<KOOMEN>LISPUSERS>MEDLEY>HOSTUP.;1 9510   
-
-      changes to%:  (VARS HOSTUPCOMS)
-
-      previous date%: "19-Oct-89 16:52:50" {ICE}<KOOMEN>LISPUSERS>MEDLEY>HOSTUP.;1)
-
-
-(* "
-Copyright (c) 1988, 1989 by Johannes A. G. M. Koomen.  All rights reserved.
-")
-
-(PRETTYCOMPRINT HOSTUPCOMS)
-
-(RPAQQ HOSTUPCOMS 
-       ((FNS HOSTUP?)
-        (INITVARS (HOSTUP.TIMEOUT 15000)
-               (HOSTUP.RETRYCNT 5))
-        (GLOBALVARS HOSTUP.TIMEOUT HOSTUP.RETRYCNT)
-        (DECLARE%: DONTEVAL@LOAD DONTCOPY EVAL@COMPILE
-               (FILES SYSEDIT [FROM VALUEOF (for D in LISPUSERSDIRECTORIES until
-                                                 (INFILEP (PACKFILENAME 'NAME 'LLNSDECLS 'BODY
-                                                                 (SETQ $$VAL
-                                                                       (PACKFILENAME
-                                                                        'HOST
-                                                                        (FILENAMEFIELD D 'HOST)
-                                                                        'DIRECTORY
-                                                                        (CONCAT "LISP>" MAKESYSNAME 
-                                                                               ">SOURCES"]
-                      LLNSDECLS
-                      (LOADCOMP)
-                      LLNS))))
-(DEFINEQ
-
-(HOSTUP?
-  [LAMBDA (name)                                        (* ; "Edited 19-Oct-89 16:51 by koomen")
-
-    (* ;; "Adapted from FILECACHE function \FCACHE.HOSTUP?")
-
-    (* ;; "Uses the globalvar HOSTUP.TIMEOUT (default: 15,000 msecs) to limit total wait time, and the globalvar HOSTUP.RETRYCNT (default: 5 times) to limit the number of retries")
-                                                         (* smL " 3-Sep-86 16:04")
-
-(* ;;; "Try to determine if the host if able to respond")
-
-    (LET* [(DEV (\GETDEVICEFROMNAME name T NIL))
-           (retryCount (MAX 1 (FIX HOSTUP.RETRYCNT)))
-           (initialInterval (FIX (QUOTIENT (MAX 1000 HOSTUP.TIMEOUT)
-                                        (SUB1 (LSH 1 retryCount]
-          (SELECTQ (if DEV
-                       then 
-
-                             (* ;; "use real DEV to determine the DEV type")
-
-                             (SELECTQ (fetch OPENFILE of DEV)
-                                 ((\LEAF.OPENFILE \FTP.OPENFILE) 
-                                      'LEAF)
-                                 (\NSFILING.OPENFILE 
-                                      'NSFILING)
-                                 (fetch DEVICENAME of DEV))
-                     else 
-
-                           (* ;; 
-                       "the FDEV doesn't exist, and we can't create one for it, so it must be down")
-
-                           'NOFDEV)
-              (LEAF 
-                    (* ;; "We think its a LEAF server, so try PUP.ECHOUSER")
-
-                    (RESETLST
-                        (PROG ((i 1)
-                               (interval initialInterval)
-                               (PORT (BESTPUPADDRESS name PROMPTWINDOW))
-                               (SOC (OPENPUPSOCKET))
-                               echo OPUP IPUP ECHOPUPLENGTH)
-                              (RESETSAVE NIL (LIST 'CLOSEPUPSOCKET SOC))
-                              (OR PORT (RETURN NIL))
-                          TryAgain
-                              (if (IGREATERP i retryCount)
-                                  then (RETURN NIL))
-                              (SETQ OPUP (ALLOCATE.PUP))
-                              (SETUPPUP OPUP PORT \PUPSOCKET.ECHO \PT.ECHOME NIL SOC T)
-                              (PUTPUPWORD OPUP 0 1)
-                              (add (fetch PUPLENGTH of OPUP)
-                                     BYTESPERWORD)
-                              (SETQ ECHOPUPLENGTH (fetch PUPLENGTH of OPUP))
-                              (SENDPUP SOC OPUP)
-                              [COND
-                                 ((SETQ IPUP (GETPUP SOC interval))
-                                  (COND
-                                     ((PROG1 (AND (EQ (fetch PUPTYPE of IPUP)
-                                                      \PT.IAMECHO)
-                                                  (EQ (fetch PUPIDHI of IPUP)
-                                                      (fetch PUPIDHI of OPUP))
-                                                  (EQ (fetch PUPIDLO of IPUP)
-                                                      (fetch PUPIDLO of OPUP))
-                                                  (EQ (fetch PUPLENGTH of IPUP)
-                                                      ECHOPUPLENGTH)
-                                                  (IEQP (GETPUPWORD IPUP 0)
-                                                        1))
-                                             (RELEASE.PUP IPUP))
-                                      (RETURN T]
-                              (SETQ i (ADD1 i))
-                              (SETQ interval (ITIMES interval 2))
-                              (GO TryAgain))))
-              (NSFILING                                      (* ; 
-                                              "We think its an NSFILING server, so try NS.ECHOUSER")
-                        (RESETLST
-                            (PROG ((i 1)
-                                   (interval initialInterval)
-                                   (ECHOADDRESS (OR (COERCE-TO-NSADDRESS name \NS.WKS.Echo)
-                                                    (\ILLEGAL.ARG name)))
-                                   NSOC OXIP ECHOXIPLENGTH IXIP)
-                                  (OR ECHOADDRESS (RETURN NIL))
-                                  [RESETSAVE NIL (LIST 'CLOSENSOCKET (SETQ NSOC (OPENNSOCKET]
-                                  (if (IGREATERP i retryCount)
-                                      then (RETURN NIL))
-                                  (SETQ OXIP (\FILLINXIP \XIPT.ECHO NSOC ECHOADDRESS))
-                                  (XIPAPPEND.WORD OXIP \XECHO.OP.REQUEST)
-                                  (XIPAPPEND.WORD OXIP 1)
-                                  (SETQ ECHOXIPLENGTH (fetch XIPLENGTH of OXIP))
-                              TryAgain
-                                  (if (IGREATERP i retryCount)
-                                      then (RETURN NIL))
-                                  (SENDXIP NSOC OXIP)
-                                  [COND
-                                     ((SETQ IXIP (GETXIP NSOC interval))
-                                      (COND
-                                         ((PROG1 (AND (EQ (fetch XIPTYPE of IXIP)
-                                                          \XIPT.ECHO)
-                                                      (EQ (fetch XIPLENGTH of IXIP)
-                                                          ECHOXIPLENGTH)
-                                                      (EQ (\GETBASE (fetch XIPCONTENTS
-                                                                       of IXIP)
-                                                                 0)
-                                                          \XECHO.OP.REPLY))
-                                                 (RELEASE.XIP IXIP))
-                                          (RETURN T]
-                                  (SETQ i (ADD1 i))
-                                  (SETQ interval (LLSH interval 1))
-                                  (GO TryAgain))))
-              (FLOPPY 
-                      (* ;; "the FLOPPY disk")
-
-                      (* ;; 
-                    "Should be (FLOPPY.CAN.READP) but this triggers a bug in the Floppy handler")
-
-                      T)
-              (TCP 
-                   (* ;; "A TCP device.  Punt on them")
-
-                   T)
-              (NOFDEV 
-                      (* ;; "we can't create an FDEV for the device, so it can't be up")
-
-                      NIL)
-              T])
-)
-
-(RPAQ? HOSTUP.TIMEOUT 15000)
-
-(RPAQ? HOSTUP.RETRYCNT 5)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS HOSTUP.TIMEOUT HOSTUP.RETRYCNT)
-)
-(DECLARE%: DONTEVAL@LOAD DONTCOPY EVAL@COMPILE 
-
-(FILESLOAD SYSEDIT [FROM VALUEOF (for D in LISPUSERSDIRECTORIES
-                                        until (INFILEP (PACKFILENAME 'NAME 'LLNSDECLS
-                                                                  'BODY
-                                                                  (SETQ $$VAL
-                                                                   (PACKFILENAME 'HOST
-                                                                          (FILENAMEFIELD D
-                                                                                 'HOST)
-                                                                          'DIRECTORY
-                                                                          (CONCAT "LISP>" MAKESYSNAME
-                                                                                 ">SOURCES"]
-       LLNSDECLS
-       (LOADCOMP)
-       LLNS)
-)
-(PUTPROPS HOSTUP COPYRIGHT ("Johannes A. G. M. Koomen" 1988 1989))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1512 8312 (HOSTUP? 1522 . 8310)))))
-STOP
diff --git a/obsolete/lispusers/HOSTUP.TEDIT b/obsolete/lispusers/HOSTUP.TEDIT
deleted file mode 100644
index 5f8fb3db..00000000
Binary files a/obsolete/lispusers/HOSTUP.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/INDEX b/obsolete/lispusers/INDEX
deleted file mode 100644
index fdfbeab1..00000000
--- a/obsolete/lispusers/INDEX
+++ /dev/null
@@ -1,588 +0,0 @@
-(FILECREATED "18-Feb-87 15:44:37" {SUMEX-AIM}PS:<TMAX.SOURCES>INDEX.;4 23471  
-
-      changes to:  (FNS INSERT.KNOWN.INDEX)
-
-      previous date: "17-Feb-87 14:27:45" {SUMEX-AIM}PS:<GILMURRAY.LISP>INDEX.;5)
-
-
-(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.)
-
-(PRETTYCOMPRINT INDEXCOMS)
-
-(RPAQQ INDEXCOMS ((* Developed under support from NIH grant RR-00785.)
-		    (* Written by Frank Gilmurray and Sami Shaio.)
-		    (FNS INDEXOBJ INDEXOBJP INDEX.DISPLAYFN INDEX.IMAGEBOXFN INDEX.PUTFN INDEX.GETFN 
-			 INDEX.BUTTONEVENTINFN CHANGE.INDEX CHANGE.INDEXENTRY INDEX.WHENDELETEDFN)
-		    (FNS ADD.NEW.INDEX INDEX.STRING INSERT.INDEX INSERT.INDEXENTRY 
-			 GET.INDEXENTRY.NUMBER INSERT.KNOWN.INDEX INDEX.LIST.REFS 
-			 LIST.OF.INDEXENTRIES CREATE.INDEX.FILE VIEW.INDEX.FILE GET.INDEX.FILE 
-			 WRITE.INDEX.FILE WRITE.INDEX.PAGENUMBERS)
-		    (RECORDS INDEX.ENTRY.RECORD)))
-
-
-
-(* Developed under support from NIH grant RR-00785.)
-
-
-
-
-(* Written by Frank Gilmurray and Sami Shaio.)
-
-(DEFINEQ
-
-(INDEXOBJ
-  (LAMBDA (KEY INDEXENTRY.PARMS)                             (* fsg "15-Jan-87 09:53")
-
-          (* * Create an instance of an Index or IndexEntry imageobject. The difference between the two is the OBJECTDATUM.
-	  For a simple Index, OBJECTDATUM is NIL. For an IndexEntry, OBJECTDATUM is a record containing the Entry, Entry's 
-	  font, and Number option. In either case, the INDEX.KEY property is the hash key and is also the text to index for a
-	  simple Index.)
-
-
-    (LET ((NEWOBJ (IMAGEOBJCREATE INDEXENTRY.PARMS (IMAGEFNSCREATE (FUNCTION INDEX.DISPLAYFN)
-								       (FUNCTION INDEX.IMAGEBOXFN)
-								       (FUNCTION INDEX.PUTFN)
-								       (FUNCTION INDEX.GETFN)
-								       (FUNCTION NILL)
-								       (FUNCTION 
-									 INDEX.BUTTONEVENTINFN)
-								       (FUNCTION NILL)
-								       (FUNCTION NILL)
-								       (FUNCTION NILL)
-								       (FUNCTION 
-									 INDEX.WHENDELETEDFN)
-								       (FUNCTION NILL)
-								       (FUNCTION NILL)
-								       (FUNCTION NILL)))))
-         (IMAGEOBJPROP NEWOBJ 'INDEX.KEY
-			 KEY)
-         (IMAGEOBJPROP NEWOBJ 'TYPE
-			 'INDEXOBJ)
-     NEWOBJ)))
-
-(INDEXOBJP
-  (LAMBDA (OBJ)                                              (* fsg "15-Jan-87 09:55")
-
-          (* * Tests an imageobject to see if it an Index or IndexEntry imageobject. By convention, testing functions for an 
-	  imageobject are named <CONCAT type-of-imageobj "P" >.)
-
-
-    (AND OBJ (EQ (IMAGEOBJPROP OBJ 'TYPE)
-		     'INDEXOBJ))))
-
-(INDEX.DISPLAYFN
-  (LAMBDA (OBJ STREAM)                                       (* fsg "17-Feb-87 10:18")
-
-          (* * Display an Index or IndexEntry imageobject. If the output is to the display imagestream, then just type Index 
-	  or IndexEntry followed by their args. Otherwise the output is to a hardcopy imagestream. In this case type nothing 
-	  and replace the CAR of the hash array entry with a list of page numbers in which this index entry appears.
-	  <CAR FORMATTINGSTATE> is the current TEdit page number iff doing a hardcopy.)
-
-
-    (LET ((WINDOW (CAR (fetch \WINDOW of TEXTOBJ)))
-	  PGS/IMOBJS CURRENT.PAGE)
-         (SELECTQ (IMAGESTREAMTYPE STREAM)
-		    (DISPLAY (PROGN (DSPFONT GP.DefaultFont STREAM)
-				      (PRIN3 (INDEX.STRING OBJ)
-					       STREAM)))
-		    (PROGN (SETQ PGS/IMOBJS (GETHASH (MKATOM (IMAGEOBJPROP OBJ
-										     'INDEX.KEY))
-							   (WINDOWPROP WINDOW
-									 'TSP.INDEX.ARRAY)))
-			     (SETQ CURRENT.PAGE (CAR FORMATTINGSTATE))
-			     (COND
-			       (PGS/IMOBJS (COND
-					     ((LISTP (CAR PGS/IMOBJS))
-					       (OR (MEMBER CURRENT.PAGE (CAR PGS/IMOBJS))
-						     (RPLACA PGS/IMOBJS
-							       (SORT (APPEND (CAR PGS/IMOBJS)
-										 (LIST CURRENT.PAGE)
-										 )
-								       'ILESSP))))
-					     (T (RPLACA PGS/IMOBJS (LIST CURRENT.PAGE)))))
-			       (T (SHOULDNT "No array entry for this INDEX"))))))))
-
-(INDEX.IMAGEBOXFN
-  (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN)                  (* fsg "15-Feb-87 14:37")
-
-          (* * Return the ImageBox for an Index or IndexEntry request.)
-
-
-    (SELECTQ (IMAGESTREAMTYPE STREAM)
-	       (DISPLAY (create IMAGEBOX
-				  XSIZE _(STRINGWIDTH (INDEX.STRING OBJ)
-							GP.DefaultFont)
-				  YSIZE _(FONTPROP GP.DefaultFont 'HEIGHT)
-				  YDESC _(FONTPROP GP.DefaultFont 'DESCENT)
-				  XKERN _ 0))
-	       (create IMAGEBOX
-			 XSIZE _ 0
-			 YSIZE _ 0
-			 YDESC _ 0
-			 XKERN _ 0))))
-
-(INDEX.PUTFN
-  (LAMBDA (OBJ STREAM)                                       (* fsg "11-Feb-87 11:07")
-
-          (* * Puts the Index or IndexEntry imageobject in a file.)
-
-
-    (LET ((DATUM (fetch OBJECTDATUM of OBJ)))
-         (PRIN2 (COND
-		    (DATUM (LIST 'IndexEntry
-				   (IMAGEOBJPROP OBJ 'INDEX.KEY)
-				   DATUM))
-		    (T (LIST 'Index
-			       (IMAGEOBJPROP OBJ 'INDEX.KEY))))
-		  STREAM))))
-
-(INDEX.GETFN
-  (LAMBDA (STREAM)                                           (* fsg "11-Feb-87 10:42")
-
-          (* * Create the Index or IndexEntry imageobject when it is read from file.)
-
-
-    (LET* ((INDEX.ARGS (CDR (READ STREAM)))
-	   (NEWOBJ (APPLY 'INDEXOBJ
-			    INDEX.ARGS))
-	   (WINDOW (PROCESSPROP (THIS.PROCESS)
-				  'WINDOW)))
-          (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW)
-		(TSP.FMMENU (TEXTSTREAM WINDOW)))
-          (ADD.NEW.INDEX WINDOW (CAR INDEX.ARGS)
-			   NEWOBJ)
-      NEWOBJ)))
-
-(INDEX.BUTTONEVENTINFN
-  (LAMBDA (OBJ STREAM SEL RELX RELY WINDOW HOSTSTREAM BUTTON)
-                                                             (* fsg "15-Jan-87 11:26")
-
-          (* * Process the MIDDLE button pressed inside an Index or IndexEntry imageobject. This means the user wants to 
-	  Change this index.)
-
-
-    (AND (MOUSESTATE MIDDLE)
-	   (MENU (create MENU
-			     ITEMS _ '((Change 'CHANGE
-					       "Change this Index or IndexEntry"))
-			     CENTERFLG _ T))
-	   (LET* ((OBJDATUM (fetch OBJECTDATUM of OBJ))
-		  (NEW.INDEX (COND
-			       (OBJDATUM (CHANGE.INDEXENTRY OBJ STREAM OBJDATUM))
-			       (T (CHANGE.INDEX OBJ STREAM)))))
-	         (AND (CAR NEW.INDEX)
-			(PROGN (INDEX.WHENDELETEDFN OBJ STREAM)
-				 (IMAGEOBJPROP OBJ 'INDEX.KEY
-						 (CAR NEW.INDEX))
-				 (AND OBJDATUM (replace OBJECTDATUM of OBJ
-						    with (CADR NEW.INDEX)))
-				 (ADD.NEW.INDEX WINDOW (CAR NEW.INDEX)
-						  OBJ)
-				 'CHANGED))))))
-
-(CHANGE.INDEX
-  (LAMBDA (OBJ STREAM)                                       (* fsg "15-Jan-87 10:54")
-
-          (* * Here when CHANGE buttoned inside an Index ImageObject.)
-
-
-    (LIST (MKATOM (TEDIT.GETINPUT STREAM (CONCAT "Change Index name %""
-							 (IMAGEOBJPROP OBJ 'INDEX.KEY)
-							 "%" to: "))))))
-
-(CHANGE.INDEXENTRY
-  (LAMBDA (OBJ STREAM OBJDATUM)                              (* fsg "15-Jan-87 11:17")
-
-          (* * Here when CHANGE buttoned inside an IndexEntry ImageObject.)
-
-
-    (LET ((WINDOW (\TEDIT.MAINW STREAM))
-	  NEWINDEX.KEY NEWINDEX.ENTRY NEWINDEX.FONT NEWINDEX.NUMBER)
-         (COND
-	   ((SETQ NEWINDEX.KEY (MKATOM (TEDIT.GETINPUT STREAM (CONCAT 
-								       "Change IndexEntry Key %""
-									      (IMAGEOBJPROP
-										OBJ
-										'INDEX.KEY)
-									      "%" to: "))))
-	     (SETQ NEWINDEX.ENTRY (OR (MKATOM (TEDIT.GETINPUT STREAM
-								      (CONCAT 
-								     "Change IndexEntry Entry %""
-										(fetch INDEX.ENTRY
-										   of OBJDATUM)
-										"%" to: ")))
-					  (fetch INDEX.ENTRY of OBJDATUM)))
-	     (TEDIT.PROMPTPRINT STREAM (CONCAT "Change IndexEntry Entry font %""
-						   (ABBREVIATE.FONT (fetch INDEX.ENTRYFONT
-									 of OBJDATUM))
-						   "%" to...")
-				  T)
-	     (until (SETQ NEWINDEX.FONT (GET.TSP.FONT WINDOW (OR (fetch INDEX.ENTRYFONT
-									    of OBJDATUM)
-									 GP.DefaultFont)))
-		do (TEDIT.PROMPTPRINT STREAM "Invalid font specification...try again." T))
-	     (TEDIT.PROMPTPRINT STREAM (CONCAT "Change IndexEntry Number option %""
-						   (fetch INDEX.NUMBER of OBJDATUM)
-						   "%" to...")
-				  T)
-	     (SETQ NEWINDEX.NUMBER (GET.INDEXENTRY.NUMBER WINDOW (fetch INDEX.NUMBER
-									of OBJDATUM)))
-	     (TEDIT.PROMPTPRINT STREAM "" T)
-	     (LIST NEWINDEX.KEY (create INDEX.ENTRY.RECORD
-					    INDEX.ENTRY _ NEWINDEX.ENTRY
-					    INDEX.ENTRYFONT _ NEWINDEX.FONT
-					    INDEX.NUMBER _ NEWINDEX.NUMBER)))
-	   (T (LIST NEWINDEX.KEY))))))
-
-(INDEX.WHENDELETEDFN
-  (LAMBDA (OBJ WINDOW)                                       (* fsg "15-Jan-87 11:30")
-
-          (* * Delete the selected Index or IndexEntry imageobject.)
-
-
-    (LET* ((INDEXKEY (IMAGEOBJPROP OBJ 'INDEX.KEY))
-	   (INDEX.ARRAY (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY))
-	   (HASH.VALUE (GETHASH INDEXKEY INDEX.ARRAY)))
-          (COND
-	    ((DREMOVE OBJ (COND
-			  ((fetch OBJECTDATUM of OBJ)
-			    (CADDR HASH.VALUE))
-			  (T (CADR HASH.VALUE))))
-	      NIL)
-	    (T (DSUBST NIL (LIST OBJ)
-			 HASH.VALUE)
-	       (PUTHASH INDEXKEY (COND
-			    ((OR (CADR HASH.VALUE)
-				   (CADDR HASH.VALUE))
-			      HASH.VALUE)
-			    (T NIL))
-			  INDEX.ARRAY)))
-      NIL)))
-)
-(DEFINEQ
-
-(ADD.NEW.INDEX
-  (LAMBDA (WINDOW INDEXKEY OBJ)                              (* fsg "28-Jan-87 11:37")
-
-          (* * Add an Index or IndexEntry imageobject to our index array. If at least one already exists for this index key, 
-	  then just append this imageobject to the list. Otherwise create a new array entry for this imageobject.
-	  The list contains three elements; a string, a list of Index imageobjects, and a list of IndexEntry imageobjects.)
-
-
-    (LET* ((CODE.ARRAY (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY))
-	   (HASH.VALUE (GETHASH INDEXKEY CODE.ARRAY))
-	   (INDEX.OBJS (CADR HASH.VALUE))
-	   (ENTRY.OBJS (CADDR HASH.VALUE)))
-          (COND
-	    ((fetch OBJECTDATUM of OBJ)
-	      (SETQ ENTRY.OBJS (APPEND ENTRY.OBJS (LIST OBJ))))
-	    (T (SETQ INDEX.OBJS (APPEND INDEX.OBJS (LIST OBJ)))))
-          (PUTHASH INDEXKEY (LIST '"[Pages (?)]"
-				      INDEX.OBJS ENTRY.OBJS)
-		     CODE.ARRAY))))
-
-(INDEX.STRING
-  (LAMBDA (OBJ)                                              (* fsg "15-Feb-87 14:40")
-
-          (* * Returns the display imagestream text for an Index or IndexEntry ImageObject.)
-
-
-    (LET ((OBJDATUM (fetch OBJECTDATUM of OBJ))
-	  INDEXNUMBER)
-         (COND
-	   (OBJDATUM (CONCAT "[Index Key=" (MKATOM (IMAGEOBJPROP OBJ 'INDEX.KEY))
-			       ",Entry="
-			       (fetch INDEX.ENTRY of OBJDATUM)
-			       (COND
-				 ((EQ (SETQ INDEXNUMBER (fetch INDEX.NUMBER of OBJDATUM))
-					'YES)
-				   ",Number]")
-				 ((NUMBERP INDEXNUMBER)
-				   (CONCAT ",Number=" INDEXNUMBER "]"))
-				 (T "]"))))
-	   (T (CONCAT "[Index " (MKATOM (IMAGEOBJPROP OBJ 'INDEX.KEY))
-			"]"))))))
-
-(INSERT.INDEX
-  (LAMBDA (STREAM WINDOW)                                    (* fsg "15-Jan-87 11:37")
-
-          (* * Process the "Index" function in the ImageObjects menu.)
-
-
-    (LET ((NEWINDEX.KEY (MKATOM (TEDIT.GETINPUT STREAM "Index Key: "))))
-         (TEDIT.PROMPTPRINT STREAM "" T)
-         (AND NEWINDEX.KEY (LET ((NEW.INDEX.OBJ (INDEXOBJ NEWINDEX.KEY)))
-			          (ADD.NEW.INDEX WINDOW NEWINDEX.KEY NEW.INDEX.OBJ)
-			          (TEDIT.INSERT.OBJECT NEW.INDEX.OBJ STREAM))))))
-
-(INSERT.INDEXENTRY
-  (LAMBDA (STREAM WINDOW)                                    (* fsg "15-Jan-87 11:39")
-
-          (* * Process the "IndexEntry" function in the ImageObjects menu.)
-
-
-    (LET ((NEWINDEX.KEY (MKATOM (TEDIT.GETINPUT STREAM "IndexEntry Key: ")))
-	  NEWINDEX.ENTRY NEWINDEX.FONT NEWINDEX.NUMBER)
-         (COND
-	   (NEWINDEX.KEY (SETQ NEWINDEX.ENTRY (OR (MKATOM (TEDIT.GETINPUT STREAM 
-									     "IndexEntry Entry: "
-										  (MKSTRING 
-										     NEWINDEX.KEY)))
-						      NEWINDEX.KEY))
-			 (TEDIT.PROMPTPRINT STREAM "IndexEntry Entry font..." T)
-			 (until (SETQ NEWINDEX.FONT (GET.TSP.FONT WINDOW GP.DefaultFont))
-			    do (TEDIT.PROMPTPRINT STREAM 
-						      "Invalid font specification...try again."
-						      T))
-			 (TEDIT.PROMPTPRINT STREAM "IndexEntry Number option..." T)
-			 (SETQ NEWINDEX.NUMBER (GET.INDEXENTRY.NUMBER WINDOW))
-			 (TEDIT.PROMPTPRINT STREAM "" T)
-			 (LET ((NEW.INDEX.OBJ (INDEXOBJ NEWINDEX.KEY
-							  (create INDEX.ENTRY.RECORD
-								    INDEX.ENTRY _ NEWINDEX.ENTRY
-								    INDEX.ENTRYFONT _ NEWINDEX.FONT
-								    INDEX.NUMBER _ NEWINDEX.NUMBER))))
-			      (ADD.NEW.INDEX WINDOW NEWINDEX.KEY NEW.INDEX.OBJ)
-			      (TEDIT.INSERT.OBJECT NEW.INDEX.OBJ STREAM)))
-	   (T (TEDIT.PROMPTPRINT STREAM "" T))))))
-
-(GET.INDEXENTRY.NUMBER
-  (LAMBDA (WINDOW DEFAULTNUMBER)                             (* fsg "15-Jan-87 11:43")
-
-          (* * Get the NUMBER argument for an IndexEntry ImageObject. The NUMBER can be "YES", "NO", or an integer.)
-
-
-    (OR (MENU (create MENU
-			    TITLE _ "NUMBER?"
-			    CENTERFLG _ T
-			    ITEMS _ '(YES NO VALUE)
-			    WHENSELECTEDFN _(FUNCTION (LAMBDA (ITEM)
-				(COND
-				  ((EQ ITEM 'VALUE)
-				    (NUMBERPAD.READ (CREATE.NUMBERPAD.READER "NUMBER value?" NIL 
-										 NIL NIL T)))
-				  (T ITEM))))))
-	  DEFAULTNUMBER
-	  'YES)))
-
-(INSERT.KNOWN.INDEX
-  (LAMBDA (STREAM WINDOW)                                    (* fsg "18-Feb-87 14:48")
-
-          (* * Process the "Known Indices" function in the ImageObjects menu. A menu of all the known Indices and 
-	  IndexEntries pops up and the user may button one of these to insert the corrsponding Index or IndexEntry.
-	  Any buttoning outside of this menu will make it disappear.)
-
-
-    (LET* ((PREVINDICES (INDEX.LIST.REFS WINDOW))
-	   (NEWINDEX.KEY (COND
-			   (PREVINDICES (LET ((NMENU (create MENU
-							       TITLE _ "Index Keys"
-							       ITEMS _ PREVINDICES))
-					      MENU.SELECTION)
-					     (SETQ MENU.SELECTION (MENU NMENU))
-					     (AND MENU.SELECTION (OR (LISTP MENU.SELECTION)
-									 (LIST MENU.SELECTION)))))
-			   (T (TEDIT.PROMPTPRINT STREAM 
-					   "There are no Indicies/IndexEntries in this document."
-						   T)
-			      NIL))))
-          (AND NEWINDEX.KEY (LET ((NEWINDEX.OBJ (APPLY 'INDEXOBJ
-							   NEWINDEX.KEY)))
-			           (ADD.NEW.INDEX WINDOW (CAR NEWINDEX.KEY)
-						    NEWINDEX.OBJ)
-			           (TEDIT.INSERT.OBJECT NEWINDEX.OBJ STREAM)
-			           (TEDIT.PROMPTPRINT STREAM "" T))))))
-
-(INDEX.LIST.REFS
-  (LAMBDA (WINDOW)                                           (* fsg "15-Jan-87 11:46")
-
-          (* * Return a sorted list of the Index and IndexEntry keys. Simple Index keys are just added to the list.
-	  For an IndexEntry key, there are SUBITEMS for each IndexEntry for this key. This list can be used as the ITEMS 
-	  field in the Known Indices menu or for creating the index file.)
-
-
-    (LET ((INDEX.ARRAY (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY))
-	  (INDEX.KEYLIST NIL)
-	  (INDEX.ITEMS (CONS))
-	  INDEX.VALUE)
-         (MAPHASH INDEX.ARRAY (FUNCTION (LAMBDA (VAL KY)
-			(SETQ INDEX.KEYLIST (CONS KY INDEX.KEYLIST)))))
-         (for KEY in (SORT INDEX.KEYLIST 'UALPHORDER)
-	    do (SETQ INDEX.VALUE (GETHASH KEY INDEX.ARRAY))
-		 (AND (CADR INDEX.VALUE)
-			(NCONC INDEX.ITEMS (LIST KEY)))
-		 (AND (CADDR INDEX.VALUE)
-			(NCONC INDEX.ITEMS (LIST (LIST KEY NIL "Select an IndexEntry subitem."
-							     (CONS 'SUBITEMS
-								     (LIST.OF.INDEXENTRIES
-								       KEY
-								       (CADDR INDEX.VALUE))))))))
-         (CDR INDEX.ITEMS))))
-
-(LIST.OF.INDEXENTRIES
-  (LAMBDA (KEY OBJLIST)                                      (* fsg "15-Jan-87 11:48")
-
-          (* * Returns a list of the IndexEntries sorted by Entry)
-
-
-    (LET ((ENTRY.LIST (CONS))
-	  OBJDATUM)
-         (for OBJ in OBJLIST
-	    do (SETQ OBJDATUM (fetch OBJECTDATUM of OBJ))
-		 (NCONC ENTRY.LIST (LIST (LIST (CONCAT (fetch INDEX.ENTRY of OBJDATUM)
-							       ", "
-							       (ABBREVIATE.FONT (fetch 
-										  INDEX.ENTRYFONT
-										     of OBJDATUM))
-							       ", "
-							       (fetch INDEX.NUMBER of OBJDATUM))
-						     (KWOTE (LIST KEY OBJDATUM))))))
-         (SORT (INTERSECTION (CDR ENTRY.LIST)
-				 (CDR ENTRY.LIST))
-		 (FUNCTION (LAMBDA (A B)
-		     (UALPHORDER (CAADR (CADADR A))
-				   (CAADR (CADADR B)))))))))
-
-(CREATE.INDEX.FILE
-  (LAMBDA (STREAM WINDOW)                                    (* fsg "15-Dec-86 13:22")
-
-          (* * Writes the indices and their corresponding page numbers or strings to the index file. The indices are sorted 
-	  alphabetically regardless of case.)
-
-
-    (LET* ((INDEX.ARRAY (WINDOWPROP WINDOW 'TSP.INDEX.ARRAY))
-	   (INDEX.LIST (INDEX.LIST.REFS WINDOW))
-	   (INDEX.FILE (GET.INDEX.FILE (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW)))
-	   (INDEX.STREAM (AND INDEX.FILE (OPENTEXTSTREAM))))
-          (COND
-	    ((AND INDEX.LIST INDEX.FILE)
-	      (TEDIT.PROMPTPRINT STREAM (CONCAT "Putting indices in: " INDEX.FILE "...")
-				   T)
-	      (WRITE.INDEX.FILE INDEX.STREAM INDEX.LIST INDEX.ARRAY)
-	      (TEDIT.PROMPTPRINT STREAM "done")
-	      (TEDIT.PUT INDEX.STREAM INDEX.FILE)
-	      INDEX.FILE)
-	    (INDEX.LIST (TEDIT.PROMPTPRINT STREAM "Specify a file name for the indices first." T)
-			NIL)
-	    (T (TEDIT.PROMPTPRINT STREAM "There are no indices in this document." T)
-	       NIL)))))
-
-(VIEW.INDEX.FILE
-  (LAMBDA (STREAM WINDOW)                                    (* fsg "15-Dec-86 15:22")
-
-          (* * Writes out the index file via CREATE.INDEX.FILE and then opens another TEdit window where this new file is 
-	  displayed.)
-
-
-    (LET ((INDEX.FILE (CREATE.INDEX.FILE STREAM WINDOW))
-	  (INDEX.FILEW (WINDOWPROP WINDOW 'INDEX.WINDOW)))
-         (AND INDEX.FILE (COND
-		  ((WINDOWP INDEX.FILEW)
-		    (COND
-		      ((OPENWP INDEX.FILEW)
-			(TEDIT.GET (TEXTOBJ INDEX.FILEW)
-				     INDEX.FILE))
-		      ((OPENW INDEX.FILEW)
-			(TEDIT INDEX.FILE INDEX.FILEW))))
-		  (T (WINDOWPROP WINDOW 'INDEX.WINDOW
-				   (SETQ INDEX.FILEW (CREATEW NIL (CONCAT 
-									   "Viewing index file: "
-										INDEX.FILE))))
-		     (TEDIT INDEX.FILE INDEX.FILEW)))))))
-
-(GET.INDEX.FILE
-  (LAMBDA (MENUW)                                            (* fsg "19-Aug-86 09:09")
-
-          (* * Return the user specified index file name.)
-
-
-    (LET* ((ITEM (FM.ITEMFROMID MENUW 'INDEX.FILE))
-	   (FILENAME (FM.ITEMPROP ITEM 'LABEL)))
-          (COND
-	    ((NOT (STREQUAL FILENAME ""))
-	      (MKATOM FILENAME))))))
-
-(WRITE.INDEX.FILE
-  (LAMBDA (INDEX.STREAM INDEX.LIST INDEX.ARRAY)              (* fsg "28-Jan-87 13:31")
-
-          (* * Do the output to the index file. For each Index, the Key is printed followed by the list of page numbers in 
-	  which this Index Key appears. Each IndexEntry is printed on a separate line and the page number depends on the 
-	  IndexEntry Number option. After all indices/indexentries are printed, the array page number list is converted back 
-	  to a string. This insures that the next DISPLAYFN call will reconvert the string back to a page number list.)
-
-
-    (DSPFONT (FONTCREATE '(HELVETICA 14 BRR))
-	       INDEX.STREAM)
-    (PRINTOUT INDEX.STREAM "Index" T T)
-    (for INDEX.ITEM in INDEX.LIST
-       do (COND
-	      ((LISTP INDEX.ITEM)
-		(LET ((PGS.AND.IMOBJS (GETHASH (CAR INDEX.ITEM)
-						 INDEX.ARRAY)))
-		     (for INDEX.SUBITEM in (CDR (CADDDR INDEX.ITEM))
-			do (for (INDEX.ENTRYARGS INDEX.FONT) in (CDR (CADADR INDEX.SUBITEM))
-				do (DSPFONT (SETQ INDEX.FONT (FONTCREATE (CADR 
-										  INDEX.ENTRYARGS)))
-						INDEX.STREAM)
-				     (PRINTOUT INDEX.STREAM (MKSTRING (CAR INDEX.ENTRYARGS)))
-				     (WRITE.INDEX.PAGENUMBERS INDEX.STREAM PGS.AND.IMOBJS
-								(CADDR INDEX.ENTRYARGS))
-				     (DSPFONT INDEX.FONT INDEX.STREAM)
-				     (PRINTOUT INDEX.STREAM T)))))
-	      (T (DSPFONT GP.DefaultFont INDEX.STREAM)
-		 (LET ((PGS.AND.IMOBJS (GETHASH INDEX.ITEM INDEX.ARRAY)))
-		      (COND
-			((CAR PGS.AND.IMOBJS)
-			  (PRINTOUT INDEX.STREAM (MKSTRING INDEX.ITEM))
-			  (WRITE.INDEX.PAGENUMBERS INDEX.STREAM PGS.AND.IMOBJS NIL)
-			  (PRINTOUT INDEX.STREAM T))
-			(T NIL))))))
-    (for (INDEX.ITEM PAGES/IMOBJS) in INDEX.LIST
-       do (SETQ PAGES/IMOBJS (GETHASH (COND
-					      ((LISTP INDEX.ITEM)
-						(CAR INDEX.ITEM))
-					      (T INDEX.ITEM))
-					    INDEX.ARRAY))
-	    (RPLACA PAGES/IMOBJS (COND
-			((STRINGP (CAR PAGES/IMOBJS))
-			  (CAR PAGES/IMOBJS))
-			(T (CONCAT "[Pages " (MKSTRING (CAR PAGES/IMOBJS))
-				     "]")))))))
-
-(WRITE.INDEX.PAGENUMBERS
-  (LAMBDA (STREAM PAGES.AND.IMOBJS NUMBER.OPTION)            (* fsg "15-Jan-87 11:53")
-
-          (* * Here to write the actual page or pages nubers that this Index or IndexEntry appears in.
-	  NUMBER.OPTION is the Number field of an IndexEntry.)
-
-
-    (DSPFONT GP.DefaultFont STREAM)
-    (LET ((PAGE.NBRS (COND
-		       (NUMBER.OPTION (SELECTQ NUMBER.OPTION
-						 (NO "")
-						 (YES (CAR PAGES.AND.IMOBJS))
-						 (MKSTRING NUMBER.OPTION)))
-		       (T (CAR PAGES.AND.IMOBJS))))
-	  (PAGE#.STRING "    "))
-         (COND
-	   ((LISTP PAGE.NBRS)
-	     (for PAGE in PAGE.NBRS do (SETQ PAGE#.STRING (CONCAT PAGE#.STRING " "
-									    (MKSTRING PAGE)))
-		finally (PRINTOUT STREAM PAGE#.STRING)))
-	   (T (PRINTOUT STREAM (CONCAT PAGE#.STRING PAGE.NBRS)))))))
-)
-[DECLARE: EVAL@COMPILE 
-
-(RECORD INDEX.ENTRY.RECORD (INDEX.ENTRY INDEX.ENTRYFONT INDEX.NUMBER))
-]
-(PUTPROPS INDEX COPYRIGHT ("Leland Stanford Junior University" 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (1056 9971 (INDEXOBJ 1068 . 2331) (INDEXOBJP 2335 . 2718) (INDEX.DISPLAYFN 2722 . 4281) 
-(INDEX.IMAGEBOXFN 4285 . 4863) (INDEX.PUTFN 4867 . 5325) (INDEX.GETFN 5329 . 5903) (
-INDEX.BUTTONEVENTINFN 5907 . 6972) (CHANGE.INDEX 6976 . 7324) (CHANGE.INDEXENTRY 7328 . 9178) (
-INDEX.WHENDELETEDFN 9182 . 9968)) (9973 23270 (ADD.NEW.INDEX 9985 . 10986) (INDEX.STRING 10990 . 11779
-) (INSERT.INDEX 11783 . 12319) (INSERT.INDEXENTRY 12323 . 13738) (GET.INDEXENTRY.NUMBER 13742 . 14360)
- (INSERT.KNOWN.INDEX 14364 . 15630) (INDEX.LIST.REFS 15634 . 16840) (LIST.OF.INDEXENTRIES 16844 . 
-17764) (CREATE.INDEX.FILE 17768 . 18867) (VIEW.INDEX.FILE 18871 . 19740) (GET.INDEX.FILE 19744 . 20129
-) (WRITE.INDEX.FILE 20133 . 22381) (WRITE.INDEX.PAGENUMBERS 22385 . 23267)))))
-STOP
diff --git a/obsolete/lispusers/IRIS.TEdit b/obsolete/lispusers/IRIS.TEdit
deleted file mode 100644
index 69ac05ec..00000000
Binary files a/obsolete/lispusers/IRIS.TEdit and /dev/null differ
diff --git a/obsolete/lispusers/IRISCONSTANTS b/obsolete/lispusers/IRISCONSTANTS
deleted file mode 100644
index b5af99bc..00000000
--- a/obsolete/lispusers/IRISCONSTANTS
+++ /dev/null
@@ -1,1708 +0,0 @@
-(FILECREATED "24-Oct-85 18:17:51" {ERIS}<IRIS>KOTO>IRISCONSTANTS.;2 48027  
-
-      changes to:  (VARS IRISCONSTANTSCOMS)
-
-      previous date: " 5-Sep-85 23:28:08" {ERIS}<IRIS>KOTO>IRISCONSTANTS.;1)
-
-
-(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT IRISCONSTANTSCOMS)
-
-(RPAQQ IRISCONSTANTSCOMS [(COMS (* * gl.h)
-				  (* Maximum X and Y screen coordinates)
-				  (CONSTANTS (IRIS.XMAXSCREEN 1023)
-					     (IRIS.YMAXSCREEN 767))
-				  (* Various hardware/software limits)
-				  (CONSTANTS (IRIS.ATTRIBSTACKDEPTH 10)
-					     (IRIS.VPSTACKDEPTH 8)
-					     (IRIS.MATRIXSTACKDEPTH 32)
-					     (IRIS.STARTTAG -2)
-					     (IRIS.ENDTAG -3))
-				  (* Name for colors in color map loaded by IRIS.GINIT)
-				  (CONSTANTS (IRIS.BACKGROUND 0)
-					     (IRIS.BLACK 0)
-					     (IRIS.RED 1)
-					     (IRIS.GREEN 2)
-					     (IRIS.YELLOW 3)
-					     (IRIS.BLUE 4)
-					     (IRIS.MAGENTA 5)
-					     (IRIS.CYAN 6)
-					     (IRIS.WHITE 7)))
-			    (COMS (* * device.h)
-				  (* Macros to test valuator and button numbers)
-				  (MACROS IRIS.ISBUTTON IRIS.ISSCRBUTTON IRIS.ISVALUATOR IRIS.ISTIMER 
-					  IRIS.ISDIAL IRIS.ISLPEN IRIS.ISLPENBUT)
-				  (* Include file with device definitions)
-				  (CONSTANTS (IRIS.NULLDEV 0)
-					     (IRIS.BUTOFFSET 1)
-					     (IRIS.SBTOFFSET 200)
-					     (IRIS.VALOFFSET 256)
-					     (IRIS.KEYOFFSET 512)
-					     (IRIS.TIMOFFSET 515)
-					     (IRIS.BUTCOUNT 144)
-					     (IRIS.SBTCOUNT 16)
-					     (IRIS.VALCOUNT 14)
-					     (IRIS.TIMCOUNT 8))
-				  (* Buttons)
-				  (CONSTANTS (IRIS.BUT0 (IPLUS 0 IRIS.BUTOFFSET))
-					     (IRIS.BUT1 (IPLUS 1 IRIS.BUTOFFSET))
-					     (IRIS.BUT2 (IPLUS 2 IRIS.BUTOFFSET))
-					     (IRIS.BUT3 (IPLUS 3 IRIS.BUTOFFSET))
-					     (IRIS.BUT4 (IPLUS 4 IRIS.BUTOFFSET))
-					     (IRIS.BUT5 (IPLUS 5 IRIS.BUTOFFSET))
-					     (IRIS.BUT6 (IPLUS 6 IRIS.BUTOFFSET))
-					     (IRIS.BUT7 (IPLUS 7 IRIS.BUTOFFSET))
-					     (IRIS.BUT8 (IPLUS 8 IRIS.BUTOFFSET))
-					     (IRIS.BUT9 (IPLUS 9 IRIS.BUTOFFSET))
-					     (IRIS.BUT10 (IPLUS 10 IRIS.BUTOFFSET))
-					     (IRIS.BUT11 (IPLUS 11 IRIS.BUTOFFSET))
-					     (IRIS.BUT12 (IPLUS 12 IRIS.BUTOFFSET))
-					     (IRIS.BUT13 (IPLUS 13 IRIS.BUTOFFSET))
-					     (IRIS.BUT14 (IPLUS 14 IRIS.BUTOFFSET))
-					     (IRIS.BUT15 (IPLUS 15 IRIS.BUTOFFSET))
-					     (IRIS.BUT16 (IPLUS 16 IRIS.BUTOFFSET))
-					     (IRIS.BUT17 (IPLUS 17 IRIS.BUTOFFSET))
-					     (IRIS.BUT18 (IPLUS 18 IRIS.BUTOFFSET))
-					     (IRIS.BUT19 (IPLUS 19 IRIS.BUTOFFSET))
-					     (IRIS.BUT20 (IPLUS 20 IRIS.BUTOFFSET))
-					     (IRIS.BUT21 (IPLUS 21 IRIS.BUTOFFSET))
-					     (IRIS.BUT22 (IPLUS 22 IRIS.BUTOFFSET))
-					     (IRIS.BUT23 (IPLUS 23 IRIS.BUTOFFSET))
-					     (IRIS.BUT24 (IPLUS 24 IRIS.BUTOFFSET))
-					     (IRIS.BUT25 (IPLUS 25 IRIS.BUTOFFSET))
-					     (IRIS.BUT26 (IPLUS 26 IRIS.BUTOFFSET))
-					     (IRIS.BUT27 (IPLUS 27 IRIS.BUTOFFSET))
-					     (IRIS.BUT28 (IPLUS 28 IRIS.BUTOFFSET))
-					     (IRIS.BUT29 (IPLUS 29 IRIS.BUTOFFSET))
-					     (IRIS.BUT30 (IPLUS 30 IRIS.BUTOFFSET))
-					     (IRIS.BUT31 (IPLUS 31 IRIS.BUTOFFSET))
-					     (IRIS.BUT32 (IPLUS 32 IRIS.BUTOFFSET))
-					     (IRIS.BUT33 (IPLUS 33 IRIS.BUTOFFSET))
-					     (IRIS.BUT34 (IPLUS 34 IRIS.BUTOFFSET))
-					     (IRIS.BUT35 (IPLUS 35 IRIS.BUTOFFSET))
-					     (IRIS.BUT36 (IPLUS 36 IRIS.BUTOFFSET))
-					     (IRIS.BUT37 (IPLUS 37 IRIS.BUTOFFSET))
-					     (IRIS.BUT38 (IPLUS 38 IRIS.BUTOFFSET))
-					     (IRIS.BUT39 (IPLUS 39 IRIS.BUTOFFSET))
-					     (IRIS.BUT40 (IPLUS 40 IRIS.BUTOFFSET))
-					     (IRIS.BUT41 (IPLUS 41 IRIS.BUTOFFSET))
-					     (IRIS.BUT42 (IPLUS 42 IRIS.BUTOFFSET))
-					     (IRIS.BUT43 (IPLUS 43 IRIS.BUTOFFSET))
-					     (IRIS.BUT44 (IPLUS 44 IRIS.BUTOFFSET))
-					     (IRIS.BUT45 (IPLUS 45 IRIS.BUTOFFSET))
-					     (IRIS.BUT46 (IPLUS 46 IRIS.BUTOFFSET))
-					     (IRIS.BUT47 (IPLUS 47 IRIS.BUTOFFSET))
-					     (IRIS.BUT48 (IPLUS 48 IRIS.BUTOFFSET))
-					     (IRIS.BUT49 (IPLUS 49 IRIS.BUTOFFSET))
-					     (IRIS.BUT50 (IPLUS 50 IRIS.BUTOFFSET))
-					     (IRIS.BUT51 (IPLUS 51 IRIS.BUTOFFSET))
-					     (IRIS.BUT52 (IPLUS 52 IRIS.BUTOFFSET))
-					     (IRIS.BUT53 (IPLUS 53 IRIS.BUTOFFSET))
-					     (IRIS.BUT54 (IPLUS 54 IRIS.BUTOFFSET))
-					     (IRIS.BUT55 (IPLUS 55 IRIS.BUTOFFSET))
-					     (IRIS.BUT56 (IPLUS 56 IRIS.BUTOFFSET))
-					     (IRIS.BUT57 (IPLUS 57 IRIS.BUTOFFSET))
-					     (IRIS.BUT58 (IPLUS 58 IRIS.BUTOFFSET))
-					     (IRIS.BUT59 (IPLUS 59 IRIS.BUTOFFSET))
-					     (IRIS.BUT60 (IPLUS 60 IRIS.BUTOFFSET))
-					     (IRIS.BUT61 (IPLUS 61 IRIS.BUTOFFSET))
-					     (IRIS.BUT62 (IPLUS 62 IRIS.BUTOFFSET))
-					     (IRIS.BUT63 (IPLUS 63 IRIS.BUTOFFSET))
-					     (IRIS.BUT64 (IPLUS 64 IRIS.BUTOFFSET))
-					     (IRIS.BUT65 (IPLUS 65 IRIS.BUTOFFSET))
-					     (IRIS.BUT66 (IPLUS 66 IRIS.BUTOFFSET))
-					     (IRIS.BUT67 (IPLUS 67 IRIS.BUTOFFSET))
-					     (IRIS.BUT68 (IPLUS 68 IRIS.BUTOFFSET))
-					     (IRIS.BUT69 (IPLUS 69 IRIS.BUTOFFSET))
-					     (IRIS.BUT70 (IPLUS 70 IRIS.BUTOFFSET))
-					     (IRIS.BUT71 (IPLUS 71 IRIS.BUTOFFSET))
-					     (IRIS.BUT72 (IPLUS 72 IRIS.BUTOFFSET))
-					     (IRIS.BUT73 (IPLUS 73 IRIS.BUTOFFSET))
-					     (IRIS.BUT74 (IPLUS 74 IRIS.BUTOFFSET))
-					     (IRIS.BUT75 (IPLUS 75 IRIS.BUTOFFSET))
-					     (IRIS.BUT76 (IPLUS 76 IRIS.BUTOFFSET))
-					     (IRIS.BUT77 (IPLUS 77 IRIS.BUTOFFSET))
-					     (IRIS.BUT78 (IPLUS 78 IRIS.BUTOFFSET))
-					     (IRIS.BUT79 (IPLUS 79 IRIS.BUTOFFSET))
-					     (IRIS.BUT80 (IPLUS 80 IRIS.BUTOFFSET))
-					     (IRIS.BUT81 (IPLUS 81 IRIS.BUTOFFSET))
-					     (IRIS.BUT82 (IPLUS 82 IRIS.BUTOFFSET))
-					     (IRIS.MAXKBDBUT IRIS.BUT82)
-					     (IRIS.BUT100 (IPLUS 100 IRIS.BUTOFFSET))
-					     (IRIS.BUT101 (IPLUS 101 IRIS.BUTOFFSET))
-					     (IRIS.BUT102 (IPLUS 102 IRIS.BUTOFFSET))
-					     (IRIS.BUT103 (IPLUS 103 IRIS.BUTOFFSET))
-					     (IRIS.BUT104 (IPLUS 104 IRIS.BUTOFFSET))
-					     (IRIS.BUT105 (IPLUS 105 IRIS.BUTOFFSET))
-					     (IRIS.BUT106 (IPLUS 106 IRIS.BUTOFFSET))
-					     (IRIS.BUT107 (IPLUS 107 IRIS.BUTOFFSET))
-					     (IRIS.BUT108 (IPLUS 108 IRIS.BUTOFFSET))
-					     (IRIS.BUT109 (IPLUS 109 IRIS.BUTOFFSET))
-					     (IRIS.BUT110 (IPLUS 110 IRIS.BUTOFFSET))
-					     (IRIS.BUT111 (IPLUS 111 IRIS.BUTOFFSET))
-					     (IRIS.BUT112 (IPLUS 112 IRIS.BUTOFFSET))
-					     (IRIS.BUT113 (IPLUS 113 IRIS.BUTOFFSET))
-					     (IRIS.BUT114 (IPLUS 114 IRIS.BUTOFFSET))
-					     (IRIS.BUT115 (IPLUS 115 IRIS.BUTOFFSET))
-					     (IRIS.BUT116 (IPLUS 116 IRIS.BUTOFFSET))
-					     (IRIS.BUT117 (IPLUS 117 IRIS.BUTOFFSET))
-					     (IRIS.BUT118 (IPLUS 118 IRIS.BUTOFFSET))
-					     (IRIS.BUT119 (IPLUS 119 IRIS.BUTOFFSET))
-					     (IRIS.BUT120 (IPLUS 120 IRIS.BUTOFFSET))
-					     (IRIS.BUT121 (IPLUS 121 IRIS.BUTOFFSET))
-					     (IRIS.BUT122 (IPLUS 122 IRIS.BUTOFFSET))
-					     (IRIS.BUT123 (IPLUS 123 IRIS.BUTOFFSET))
-					     (IRIS.BUT124 (IPLUS 124 IRIS.BUTOFFSET))
-					     (IRIS.BUT125 (IPLUS 125 IRIS.BUTOFFSET))
-					     (IRIS.BUT126 (IPLUS 126 IRIS.BUTOFFSET))
-					     (IRIS.BUT127 (IPLUS 127 IRIS.BUTOFFSET))
-					     (IRIS.BUT128 (IPLUS 128 IRIS.BUTOFFSET))
-					     (IRIS.BUT129 (IPLUS 129 IRIS.BUTOFFSET))
-					     (IRIS.BUT130 (IPLUS 130 IRIS.BUTOFFSET))
-					     (IRIS.BUT131 (IPLUS 131 IRIS.BUTOFFSET))
-					     (IRIS.BUT132 (IPLUS 132 IRIS.BUTOFFSET))
-					     (IRIS.BUT133 (IPLUS 133 IRIS.BUTOFFSET))
-					     (IRIS.BUT134 (IPLUS 134 IRIS.BUTOFFSET))
-					     (IRIS.BUT135 (IPLUS 135 IRIS.BUTOFFSET))
-					     (IRIS.BUT136 (IPLUS 136 IRIS.BUTOFFSET))
-					     (IRIS.BUT137 (IPLUS 137 IRIS.BUTOFFSET))
-					     (IRIS.BUT138 (IPLUS 138 IRIS.BUTOFFSET))
-					     (IRIS.BUT139 (IPLUS 139 IRIS.BUTOFFSET))
-					     (IRIS.BUT140 (IPLUS 140 IRIS.BUTOFFSET))
-					     (IRIS.BUT141 (IPLUS 141 IRIS.BUTOFFSET))
-					     (IRIS.MOUSEBUTTON1 IRIS.BUT100)
-					     (IRIS.MOUSEBUTTON2 IRIS.BUT101)
-					     (IRIS.MOUSEBUTTON3 IRIS.BUT102)
-					     (IRIS.MOUSE1 IRIS.BUT100)
-					     (IRIS.MOUSE2 IRIS.BUT101)
-					     (IRIS.MOUSE3 IRIS.BUT102)
-					     (IRIS.LEFTMOUSEBUTTON IRIS.BUT102)
-					     (IRIS.MIDDLEMOUSEBUTTON IRIS.BUT101)
-					     (IRIS.RIGHTMOUSEBUTTON IRIS.BUT100)
-					     (IRIS.LEFTMOUSE IRIS.BUT102)
-					     (IRIS.MIDDLEMOUSE IRIS.BUT101)
-					     (IRIS.RIGHTMOUSE IRIS.BUT100)
-					     (IRIS.LPENBUT 104))
-				  (* Switches)
-				  (CONSTANTS (IRIS.SWBASE IRIS.BUT110)
-					     (IRIS.SW0 (IPLUS IRIS.SWBASE 0))
-					     (IRIS.SW1 (IPLUS IRIS.SWBASE 1))
-					     (IRIS.SW2 (IPLUS IRIS.SWBASE 2))
-					     (IRIS.SW3 (IPLUS IRIS.SWBASE 3))
-					     (IRIS.SW4 (IPLUS IRIS.SWBASE 4))
-					     (IRIS.SW5 (IPLUS IRIS.SWBASE 5))
-					     (IRIS.SW6 (IPLUS IRIS.SWBASE 6))
-					     (IRIS.SW7 (IPLUS IRIS.SWBASE 7))
-					     (IRIS.SW8 (IPLUS IRIS.SWBASE 8))
-					     (IRIS.SW9 (IPLUS IRIS.SWBASE 9))
-					     (IRIS.SW10 (IPLUS IRIS.SWBASE 10))
-					     (IRIS.SW11 (IPLUS IRIS.SWBASE 11))
-					     (IRIS.SW12 (IPLUS IRIS.SWBASE 12))
-					     (IRIS.SW13 (IPLUS IRIS.SWBASE 13))
-					     (IRIS.SW14 (IPLUS IRIS.SWBASE 14))
-					     (IRIS.SW15 (IPLUS IRIS.SWBASE 15))
-					     (IRIS.SW16 (IPLUS IRIS.SWBASE 16))
-					     (IRIS.SW17 (IPLUS IRIS.SWBASE 17))
-					     (IRIS.SW18 (IPLUS IRIS.SWBASE 18))
-					     (IRIS.SW19 (IPLUS IRIS.SWBASE 19))
-					     (IRIS.SW20 (IPLUS IRIS.SWBASE 20))
-					     (IRIS.SW21 (IPLUS IRIS.SWBASE 21))
-					     (IRIS.SW22 (IPLUS IRIS.SWBASE 22))
-					     (IRIS.SW23 (IPLUS IRIS.SWBASE 23))
-					     (IRIS.SW24 (IPLUS IRIS.SWBASE 24))
-					     (IRIS.SW25 (IPLUS IRIS.SWBASE 25))
-					     (IRIS.SW26 (IPLUS IRIS.SWBASE 26))
-					     (IRIS.SW27 (IPLUS IRIS.SWBASE 27))
-					     (IRIS.SW28 (IPLUS IRIS.SWBASE 28))
-					     (IRIS.SW29 (IPLUS IRIS.SWBASE 29))
-					     (IRIS.SW30 (IPLUS IRIS.SWBASE 30))
-					     (IRIS.SW31 (IPLUS IRIS.SWBASE 31)))
-				  (* Keys)
-				  (CONSTANTS (IRIS.AKEY IRIS.BUT10)
-					     (IRIS.BKEY IRIS.BUT35)
-					     (IRIS.CKEY IRIS.BUT27)
-					     (IRIS.DKEY IRIS.BUT17)
-					     (IRIS.EKEY IRIS.BUT16)
-					     (IRIS.FKEY IRIS.BUT18)
-					     (IRIS.GKEY IRIS.BUT25)
-					     (IRIS.HKEY IRIS.BUT26)
-					     (IRIS.IKEY IRIS.BUT39)
-					     (IRIS.JKEY IRIS.BUT33)
-					     (IRIS.KKEY IRIS.BUT34)
-					     (IRIS.LKEY IRIS.BUT41)
-					     (IRIS.MKEY IRIS.BUT43)
-					     (IRIS.NKEY IRIS.BUT36)
-					     (IRIS.OKEY IRIS.BUT40)
-					     (IRIS.PKEY IRIS.BUT47)
-					     (IRIS.QKEY IRIS.BUT9)
-					     (IRIS.RKEY IRIS.BUT23)
-					     (IRIS.SKEY IRIS.BUT11)
-					     (IRIS.TKEY IRIS.BUT24)
-					     (IRIS.UKEY IRIS.BUT32)
-					     (IRIS.VKEY IRIS.BUT28)
-					     (IRIS.WKEY IRIS.BUT15)
-					     (IRIS.XKEY IRIS.BUT20)
-					     (IRIS.YKEY IRIS.BUT32)
-					     (IRIS.ZKEY IRIS.BUT19)
-					     (IRIS.ZEROKEY IRIS.BUT45)
-					     (IRIS.ONEKEY IRIS.BUT7)
-					     (IRIS.TWOKEY IRIS.BUT13)
-					     (IRIS.THREEKEY IRIS.BUT14)
-					     (IRIS.FOURKEY IRIS.BUT21)
-					     (IRIS.FIVCEKEY IRIS.BUT22)
-					     (IRIS.SIXKEY IRIS.BUT29)
-					     (IRIS.SEVENKEY IRIS.BUT30)
-					     (IRIS.EIGHTKEY IRIS.BUT37)
-					     (IRIS.NINIKEY IRIS.BUT38)
-					     (IRIS.BREAKKEY IRIS.BUT0)
-					     (IRIS.SETUPKEY IRIS.BUT1)
-					     (IRIS.CNTRLKEY IRIS.BUT2)
-					     (IRIS.CAPSLOCKKEY IRIS.BUT3)
-					     (IRIS.RIGHTSHIFTKEY IRIS.BUT4)
-					     (IRIS.LEFTSHIFTKEY IRIS.BUT5)
-					     (IRIS.NOSCRLKEY IRIS.BUT12)
-					     (IRIS.ESCKEY IRIS.BUT6)
-					     (IRIS.TABKEY IRIS.BUT8)
-					     (IRIS.RETURNKEY IRIS.BUT50)
-					     (IRIS.SPACEKKEY IRIS.BUT82)
-					     (IRIS.LINEFEEDKEY IRIS.BUT59)
-					     (IRIS.BACKSPACEKEY IRIS.BUT60)
-					     (IRIS.DELETEKEY IRIS.BUT61)
-					     (IRIS.SEMICOLONKEY IRIS.BUT42)
-					     (IRIS.PERIODKEY IRIS.BUT51)
-					     (IRIS.COMMAKEY IRIS.BUT44)
-					     (IRIS.QUOTEKEY IRIS.BUT49)
-					     (IRIS.ACCENTGRAVEKEY IRIS.BUT54)
-					     (IRIS.MINUSKEY IRIS.BUT46)
-					     (IRIS.VIRGULEKEY IRIS.BUT52)
-					     (IRIS.BACKSLASHKEY IRIS.BUT56)
-					     (IRIS.EQUALKEY IRIS.BUT53)
-					     (IRIS.LEFTBRACKETKEY IRIS.BUT48)
-					     (IRIS.RIGHTBRACKETKEY IRIS.BUT55)
-					     (IRIS.LEFTARROWKEY IRIS.BUT72)
-					     (IRIS.DOWNARROWKEY IRIS.BUT73)
-					     (IRIS.UPARROWKEY IRIS.BUT80)
-					     (IRIS.PAD0 IRIS.BUT58)
-					     (IRIS.PAD1 IRIS.BUT57)
-					     (IRIS.PAD2 IRIS.BUT63)
-					     (IRIS.PAD3 IRIS.BUT64)
-					     (IRIS.PAD4 IRIS.BUT62)
-					     (IRIS.PAD5 IRIS.BUT68)
-					     (IRIS.PAD6 IRIS.BUT69)
-					     (IRIS.PAD8 IRIS.BUT67)
-					     (IRIS.PAD9 IRIS.BUT74)
-					     (IRIS.PADPF1 IRIS.BUT71)
-					     (IRIS.PADPF2 IRIS.BUT70)
-					     (IRIS.PADPF3 IRIS.BUT78)
-					     (IRIS.PADPF4 IRIS.BUT77)
-					     (IRIS.PADPERIOD IRIS.BUT65)
-					     (IRIS.PADMINUS IRIS.BUT75)
-					     (IRIS.PADCOMMA IRIS.BUT76)
-					     (IRIS.PADENTER IRIS.BUT81))
-				  (* Screen buttons)
-				  (CONSTANTS (IRIS.SCRBUT0 (IPLUS IRIS.SBTOFFSET 0))
-					     (IRIS.SCRBUT1 (IPLUS IRIS.SBTOFFSET 1))
-					     (IRIS.SCRBUT2 (IPLUS IRIS.SBTOFFSET 2))
-					     (IRIS.SCRBUT3 (IPLUS IRIS.SBTOFFSET 3))
-					     (IRIS.SCRBUT4 (IPLUS IRIS.SBTOFFSET 4))
-					     (IRIS.SCRBUT5 (IPLUS IRIS.SBTOFFSET 5))
-					     (IRIS.SCRBUT6 (IPLUS IRIS.SBTOFFSET 6))
-					     (IRIS.SCRBUT7 (IPLUS IRIS.SBTOFFSET 7))
-					     (IRIS.SCRBUT8 (IPLUS IRIS.SBTOFFSET 8))
-					     (IRIS.SCRBUT9 (IPLUS IRIS.SBTOFFSET 9))
-					     (IRIS.SCRBUT10 (IPLUS IRIS.SBTOFFSET 10))
-					     (IRIS.SCRBUT11 (IPLUS IRIS.SBTOFFSET 11))
-					     (IRIS.SCRBUT12 (IPLUS IRIS.SBTOFFSET 12))
-					     (IRIS.SCRBUT13 (IPLUS IRIS.SBTOFFSET 13))
-					     (IRIS.SCRBUT14 (IPLUS IRIS.SBTOFFSET 14))
-					     (IRIS.SCRBUT15 (IPLUS IRIS.SBTOFFSET 15))
-					     (IRIS.SCRBUT16 (IPLUS IRIS.SBTOFFSET 16)))
-				  (* Valuators)
-				  (CONSTANTS (IRIS.SGIRESERVED (IPLUS 0 IRIS.VALOFFSET))
-					     (IRIS.DIAL0 (PLUS 1 IRIS.VALOFFSET))
-					     (IRIS.DIAL1 (PLUS 2 IRIS.VALOFFSET))
-					     (IRIS.DIAL2 (PLUS 3 IRIS.VALOFFSET))
-					     (IRIS.DIAL3 (PLUS 4 IRIS.VALOFFSET))
-					     (IRIS.DIAL4 (PLUS 5 IRIS.VALOFFSET))
-					     (IRIS.DIAL5 (PLUS 6 IRIS.VALOFFSET))
-					     (IRIS.DIAL6 (PLUS 7 IRIS.VALOFFSET))
-					     (IRIS.DIAL7 (PLUS 8 IRIS.VALOFFSET))
-					     (IRIS.DIAL8 (PLUS 9 IRIS.VALOFFSET))
-					     (IRIS.MOUSEX (PLUS 10 IRIS.VALOFFSET))
-					     (IRIS.MOUSEY (PLUS 11 IRIS.VALOFFSET))
-					     (IRIS.LPENX (PLUS 12 IRIS.VALOFFSET))
-					     (IRIS.PLENY (PLUS 13 IRIS.VALOFFSET))
-					     (IRIS.NULLX (PLUS 14 IRIS.VALOFFSET))
-					     (IRIS.NULLY (PLUS 15 IRIS.VALOFFSET)))
-				  (* Timers)
-				  (CONSTANTS (IRIS.TIMER0 (IPLUS IRIS.TIMOFFSET 0))
-					     (IRIS.TIMER1 (IPLUS IRIS.TIMOFFSET 1))
-					     (IRIS.TIMER2 (IPLUS IRIS.TIMOFFSET 2))
-					     (IRIS.TIMER3 (IPLUS IRIS.TIMOFFSET 3))
-					     (IRIS.TIMER4 (IPLUS IRIS.TIMOFFSET 4))
-					     (IRIS.TIMER5 (IPLUS IRIS.TIMOFFSET 5))
-					     (IRIS.TIMER6 (IPLUS IRIS.TIMOFFSET 6))
-					     (IRIS.TIMER7 (IPLUS IRIS.TIMOFFSET 7)))
-				  (* Misc devices)
-				  (CONSTANTS (IRIS.KEYBD (IPLUS 1 IRIS.KEYOFFSET))
-					     (IRIS.CURSORX 526)
-					     (* cursor x pseudo valuator)
-					     (IRIS.CURSORY 527)
-					     (* cursor y pseudo valuator)
-					     (IRIS.VALMARK 523)
-					     (* valuator mark)
-					     (IRIS.GERROR 524)
-					     (* errors device)
-					     (IRIS.REDRAW 528)
-					     (* used by port manager to signal redraws)
-					     (IRIS.WMSEND 529)
-					     (* data in proc's shmem)
-					     (IRIS.WMREPLY 530)
-					     (* reply from port manager)
-					     (IRIS.WMGFCLOSE 531)
-					     (* gf # is no longer being used)
-					     (IRIS.WMTXCLOSE 532)
-					     (* tx # is no longer being used)
-					     (IRIS.MODECHANGE 533)
-					     (* the display mode has changed)
-					     (IRIS.INPUTCHANGE 534)
-					     (* input connected or disconnected)
-					     (IRIS.QFULL 535)
-					     (* queue was filled))
-				  (* * get.h)
-				  (* Values returned by IRIS.GETBUFFER)
-				  (CONSTANTS (IRIS.NEITHERBUFFER 0)
-					     (IRIS.BACKBUFFER 1)
-					     (IRIS.FRONTBUFFER 2)
-					     (IRIS.BOTHBUFFERS 3)
-					     (IRIS.NOBUFFER 0)
-					     (IRIS.BCKBUFFER 1)
-					     (IRIS.FRNTBUFFER 2))
-				  (* Values returned by IRIS.GETCMMODE)
-				  (CONSTANTS (IRIS.MULTIMAP 0)
-					     (IRIS.ONEMAP 1)
-					     (IRIS.CMAPMULTI 0)
-					     (IRIS.CMAPONE 1))
-				  (* Values returned by IRIS.GETDISPLAYMODE)
-				  (CONSTANTS (IRIS.RGBMODE 0)
-					     (IRIS.SINGLEBUFFER 1)
-					     (IRIS.DOUBLEBUFFER 2)
-					     (IRIS.DMRGB 0)
-					     (IRIS.DMSINGLE 1)
-					     (IRIS.DMDOUBLE 2))
-				  (* Values returned by IRIS.GETDISPLAYMODE)
-				  (CONSTANTS (IRIS.HZ30 0)
-					     (IRIS.HZ60 1)
-					     (IRIS.NTSC 2)
-					     (IRIS.PAL 2)
-					     (IRIS.HZ50 3)
-					     (IRIS.MONA 5)
-					     (IRIS.MONB 6)
-					     (IRIS.MONC 7)
-					     (IRIS.MOND 8)
-					     (IRIS.MONSPECIAL 16))
-				  (* Individual hit bits returned by IRIS.HITCODE)
-				  (CONSTANTS (IRIS.LEFTPLANE 1)
-					     (IRIS.RIGHTPLANE 2)
-					     (IRIS.BOTTOMPLANE 4)
-					     (IRIS.TOPPLANE 8)
-					     (IRIS.NEARPLANE 16)
-					     (IRIS.FARPLANE 32))
-				  (* * constants for rotation)
-				  (CONSTANTS (IRIS.XAXIS (CHARCODE X))
-					     (IRIS.YAXIS (CHARCODE Y))
-					     (IRIS.ZAXIS (CHARCODE Z)))
-				  (* * Other stuff)
-				  (* Approximate interval between retraces in milliseconds)
-				  (CONSTANTS (IRIS.RETRACEINTERVAL 33.33333])
-(* * gl.h)
-
-
-
-
-(* Maximum X and Y screen coordinates)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ IRIS.XMAXSCREEN 1023)
-
-(RPAQQ IRIS.YMAXSCREEN 767)
-
-(CONSTANTS (IRIS.XMAXSCREEN 1023)
-	   (IRIS.YMAXSCREEN 767))
-)
-
-
-
-(* Various hardware/software limits)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ IRIS.ATTRIBSTACKDEPTH 10)
-
-(RPAQQ IRIS.VPSTACKDEPTH 8)
-
-(RPAQQ IRIS.MATRIXSTACKDEPTH 32)
-
-(RPAQQ IRIS.STARTTAG -2)
-
-(RPAQQ IRIS.ENDTAG -3)
-
-(CONSTANTS (IRIS.ATTRIBSTACKDEPTH 10)
-	   (IRIS.VPSTACKDEPTH 8)
-	   (IRIS.MATRIXSTACKDEPTH 32)
-	   (IRIS.STARTTAG -2)
-	   (IRIS.ENDTAG -3))
-)
-
-
-
-(* Name for colors in color map loaded by IRIS.GINIT)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ IRIS.BACKGROUND 0)
-
-(RPAQQ IRIS.BLACK 0)
-
-(RPAQQ IRIS.RED 1)
-
-(RPAQQ IRIS.GREEN 2)
-
-(RPAQQ IRIS.YELLOW 3)
-
-(RPAQQ IRIS.BLUE 4)
-
-(RPAQQ IRIS.MAGENTA 5)
-
-(RPAQQ IRIS.CYAN 6)
-
-(RPAQQ IRIS.WHITE 7)
-
-(CONSTANTS (IRIS.BACKGROUND 0)
-	   (IRIS.BLACK 0)
-	   (IRIS.RED 1)
-	   (IRIS.GREEN 2)
-	   (IRIS.YELLOW 3)
-	   (IRIS.BLUE 4)
-	   (IRIS.MAGENTA 5)
-	   (IRIS.CYAN 6)
-	   (IRIS.WHITE 7))
-)
-(* * device.h)
-
-
-
-
-(* Macros to test valuator and button numbers)
-
-(DECLARE: EVAL@COMPILE 
-[PUTPROPS IRIS.ISBUTTON MACRO ((b)
-	   (AND (GEQ b IRIS.BUTOFFSET)
-		(LESSP b (PLUS IRIS.BUTCOUNT IRIS.BUTOFFSET]
-[PUTPROPS IRIS.ISSCRBUTTON MACRO ((b)
-	   (AND (GEQ b IRIS.SBTOFFSET)
-		(LESSP b (IPLUS IRIS.SBTCOUNT IRIS.SBTOFFSET]
-[PUTPROPS IRIS.ISVALUATOR MACRO ((v)
-	   (AND (GEQ v IRIS.VALOFFSET)
-		(LESSP v (IPLUS IRIS.VALCOUNT IRIS.VALOFFSET]
-[PUTPROPS IRIS.ISTIMER MACRO ((t)
-	   (AND (GEQ t IRIS.TIMOFFSET)
-		(LESSP t (IPLUS IRIS.TIMCOUNT IRIS.TIMOFFSET]
-[PUTPROPS IRIS.ISDIAL MACRO ((t)
-	   (AND (GEQ t IRIS.DIAL0)
-		(LEQ t IRIS.DIAL8]
-[PUTPROPS IRIS.ISLPEN MACRO ((t)
-	   (OR (EQP t IRIS.LPENX)
-	       (EQP t IRIS.LPENY]
-(PUTPROPS IRIS.ISLPENBUT MACRO ((t)
-	   (EQP t IRIS.LPENBUT)))
-)
-
-
-
-(* Include file with device definitions)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ IRIS.NULLDEV 0)
-
-(RPAQQ IRIS.BUTOFFSET 1)
-
-(RPAQQ IRIS.SBTOFFSET 200)
-
-(RPAQQ IRIS.VALOFFSET 256)
-
-(RPAQQ IRIS.KEYOFFSET 512)
-
-(RPAQQ IRIS.TIMOFFSET 515)
-
-(RPAQQ IRIS.BUTCOUNT 144)
-
-(RPAQQ IRIS.SBTCOUNT 16)
-
-(RPAQQ IRIS.VALCOUNT 14)
-
-(RPAQQ IRIS.TIMCOUNT 8)
-
-(CONSTANTS (IRIS.NULLDEV 0)
-	   (IRIS.BUTOFFSET 1)
-	   (IRIS.SBTOFFSET 200)
-	   (IRIS.VALOFFSET 256)
-	   (IRIS.KEYOFFSET 512)
-	   (IRIS.TIMOFFSET 515)
-	   (IRIS.BUTCOUNT 144)
-	   (IRIS.SBTCOUNT 16)
-	   (IRIS.VALCOUNT 14)
-	   (IRIS.TIMCOUNT 8))
-)
-
-
-
-(* Buttons)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQ IRIS.BUT0 (IPLUS 0 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT1 (IPLUS 1 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT2 (IPLUS 2 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT3 (IPLUS 3 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT4 (IPLUS 4 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT5 (IPLUS 5 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT6 (IPLUS 6 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT7 (IPLUS 7 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT8 (IPLUS 8 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT9 (IPLUS 9 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT10 (IPLUS 10 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT11 (IPLUS 11 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT12 (IPLUS 12 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT13 (IPLUS 13 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT14 (IPLUS 14 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT15 (IPLUS 15 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT16 (IPLUS 16 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT17 (IPLUS 17 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT18 (IPLUS 18 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT19 (IPLUS 19 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT20 (IPLUS 20 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT21 (IPLUS 21 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT22 (IPLUS 22 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT23 (IPLUS 23 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT24 (IPLUS 24 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT25 (IPLUS 25 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT26 (IPLUS 26 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT27 (IPLUS 27 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT28 (IPLUS 28 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT29 (IPLUS 29 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT30 (IPLUS 30 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT31 (IPLUS 31 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT32 (IPLUS 32 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT33 (IPLUS 33 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT34 (IPLUS 34 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT35 (IPLUS 35 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT36 (IPLUS 36 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT37 (IPLUS 37 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT38 (IPLUS 38 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT39 (IPLUS 39 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT40 (IPLUS 40 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT41 (IPLUS 41 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT42 (IPLUS 42 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT43 (IPLUS 43 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT44 (IPLUS 44 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT45 (IPLUS 45 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT46 (IPLUS 46 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT47 (IPLUS 47 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT48 (IPLUS 48 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT49 (IPLUS 49 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT50 (IPLUS 50 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT51 (IPLUS 51 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT52 (IPLUS 52 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT53 (IPLUS 53 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT54 (IPLUS 54 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT55 (IPLUS 55 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT56 (IPLUS 56 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT57 (IPLUS 57 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT58 (IPLUS 58 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT59 (IPLUS 59 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT60 (IPLUS 60 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT61 (IPLUS 61 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT62 (IPLUS 62 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT63 (IPLUS 63 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT64 (IPLUS 64 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT65 (IPLUS 65 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT66 (IPLUS 66 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT67 (IPLUS 67 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT68 (IPLUS 68 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT69 (IPLUS 69 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT70 (IPLUS 70 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT71 (IPLUS 71 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT72 (IPLUS 72 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT73 (IPLUS 73 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT74 (IPLUS 74 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT75 (IPLUS 75 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT76 (IPLUS 76 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT77 (IPLUS 77 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT78 (IPLUS 78 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT79 (IPLUS 79 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT80 (IPLUS 80 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT81 (IPLUS 81 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT82 (IPLUS 82 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.MAXKBDBUT IRIS.BUT82)
-
-(RPAQ IRIS.BUT100 (IPLUS 100 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT101 (IPLUS 101 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT102 (IPLUS 102 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT103 (IPLUS 103 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT104 (IPLUS 104 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT105 (IPLUS 105 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT106 (IPLUS 106 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT107 (IPLUS 107 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT108 (IPLUS 108 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT109 (IPLUS 109 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT110 (IPLUS 110 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT111 (IPLUS 111 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT112 (IPLUS 112 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT113 (IPLUS 113 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT114 (IPLUS 114 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT115 (IPLUS 115 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT116 (IPLUS 116 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT117 (IPLUS 117 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT118 (IPLUS 118 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT119 (IPLUS 119 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT120 (IPLUS 120 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT121 (IPLUS 121 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT122 (IPLUS 122 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT123 (IPLUS 123 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT124 (IPLUS 124 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT125 (IPLUS 125 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT126 (IPLUS 126 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT127 (IPLUS 127 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT128 (IPLUS 128 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT129 (IPLUS 129 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT130 (IPLUS 130 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT131 (IPLUS 131 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT132 (IPLUS 132 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT133 (IPLUS 133 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT134 (IPLUS 134 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT135 (IPLUS 135 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT136 (IPLUS 136 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT137 (IPLUS 137 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT138 (IPLUS 138 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT139 (IPLUS 139 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT140 (IPLUS 140 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.BUT141 (IPLUS 141 IRIS.BUTOFFSET))
-
-(RPAQ IRIS.MOUSEBUTTON1 IRIS.BUT100)
-
-(RPAQ IRIS.MOUSEBUTTON2 IRIS.BUT101)
-
-(RPAQ IRIS.MOUSEBUTTON3 IRIS.BUT102)
-
-(RPAQ IRIS.MOUSE1 IRIS.BUT100)
-
-(RPAQ IRIS.MOUSE2 IRIS.BUT101)
-
-(RPAQ IRIS.MOUSE3 IRIS.BUT102)
-
-(RPAQ IRIS.LEFTMOUSEBUTTON IRIS.BUT102)
-
-(RPAQ IRIS.MIDDLEMOUSEBUTTON IRIS.BUT101)
-
-(RPAQ IRIS.RIGHTMOUSEBUTTON IRIS.BUT100)
-
-(RPAQ IRIS.LEFTMOUSE IRIS.BUT102)
-
-(RPAQ IRIS.MIDDLEMOUSE IRIS.BUT101)
-
-(RPAQ IRIS.RIGHTMOUSE IRIS.BUT100)
-
-(RPAQQ IRIS.LPENBUT 104)
-
-(CONSTANTS (IRIS.BUT0 (IPLUS 0 IRIS.BUTOFFSET))
-	   (IRIS.BUT1 (IPLUS 1 IRIS.BUTOFFSET))
-	   (IRIS.BUT2 (IPLUS 2 IRIS.BUTOFFSET))
-	   (IRIS.BUT3 (IPLUS 3 IRIS.BUTOFFSET))
-	   (IRIS.BUT4 (IPLUS 4 IRIS.BUTOFFSET))
-	   (IRIS.BUT5 (IPLUS 5 IRIS.BUTOFFSET))
-	   (IRIS.BUT6 (IPLUS 6 IRIS.BUTOFFSET))
-	   (IRIS.BUT7 (IPLUS 7 IRIS.BUTOFFSET))
-	   (IRIS.BUT8 (IPLUS 8 IRIS.BUTOFFSET))
-	   (IRIS.BUT9 (IPLUS 9 IRIS.BUTOFFSET))
-	   (IRIS.BUT10 (IPLUS 10 IRIS.BUTOFFSET))
-	   (IRIS.BUT11 (IPLUS 11 IRIS.BUTOFFSET))
-	   (IRIS.BUT12 (IPLUS 12 IRIS.BUTOFFSET))
-	   (IRIS.BUT13 (IPLUS 13 IRIS.BUTOFFSET))
-	   (IRIS.BUT14 (IPLUS 14 IRIS.BUTOFFSET))
-	   (IRIS.BUT15 (IPLUS 15 IRIS.BUTOFFSET))
-	   (IRIS.BUT16 (IPLUS 16 IRIS.BUTOFFSET))
-	   (IRIS.BUT17 (IPLUS 17 IRIS.BUTOFFSET))
-	   (IRIS.BUT18 (IPLUS 18 IRIS.BUTOFFSET))
-	   (IRIS.BUT19 (IPLUS 19 IRIS.BUTOFFSET))
-	   (IRIS.BUT20 (IPLUS 20 IRIS.BUTOFFSET))
-	   (IRIS.BUT21 (IPLUS 21 IRIS.BUTOFFSET))
-	   (IRIS.BUT22 (IPLUS 22 IRIS.BUTOFFSET))
-	   (IRIS.BUT23 (IPLUS 23 IRIS.BUTOFFSET))
-	   (IRIS.BUT24 (IPLUS 24 IRIS.BUTOFFSET))
-	   (IRIS.BUT25 (IPLUS 25 IRIS.BUTOFFSET))
-	   (IRIS.BUT26 (IPLUS 26 IRIS.BUTOFFSET))
-	   (IRIS.BUT27 (IPLUS 27 IRIS.BUTOFFSET))
-	   (IRIS.BUT28 (IPLUS 28 IRIS.BUTOFFSET))
-	   (IRIS.BUT29 (IPLUS 29 IRIS.BUTOFFSET))
-	   (IRIS.BUT30 (IPLUS 30 IRIS.BUTOFFSET))
-	   (IRIS.BUT31 (IPLUS 31 IRIS.BUTOFFSET))
-	   (IRIS.BUT32 (IPLUS 32 IRIS.BUTOFFSET))
-	   (IRIS.BUT33 (IPLUS 33 IRIS.BUTOFFSET))
-	   (IRIS.BUT34 (IPLUS 34 IRIS.BUTOFFSET))
-	   (IRIS.BUT35 (IPLUS 35 IRIS.BUTOFFSET))
-	   (IRIS.BUT36 (IPLUS 36 IRIS.BUTOFFSET))
-	   (IRIS.BUT37 (IPLUS 37 IRIS.BUTOFFSET))
-	   (IRIS.BUT38 (IPLUS 38 IRIS.BUTOFFSET))
-	   (IRIS.BUT39 (IPLUS 39 IRIS.BUTOFFSET))
-	   (IRIS.BUT40 (IPLUS 40 IRIS.BUTOFFSET))
-	   (IRIS.BUT41 (IPLUS 41 IRIS.BUTOFFSET))
-	   (IRIS.BUT42 (IPLUS 42 IRIS.BUTOFFSET))
-	   (IRIS.BUT43 (IPLUS 43 IRIS.BUTOFFSET))
-	   (IRIS.BUT44 (IPLUS 44 IRIS.BUTOFFSET))
-	   (IRIS.BUT45 (IPLUS 45 IRIS.BUTOFFSET))
-	   (IRIS.BUT46 (IPLUS 46 IRIS.BUTOFFSET))
-	   (IRIS.BUT47 (IPLUS 47 IRIS.BUTOFFSET))
-	   (IRIS.BUT48 (IPLUS 48 IRIS.BUTOFFSET))
-	   (IRIS.BUT49 (IPLUS 49 IRIS.BUTOFFSET))
-	   (IRIS.BUT50 (IPLUS 50 IRIS.BUTOFFSET))
-	   (IRIS.BUT51 (IPLUS 51 IRIS.BUTOFFSET))
-	   (IRIS.BUT52 (IPLUS 52 IRIS.BUTOFFSET))
-	   (IRIS.BUT53 (IPLUS 53 IRIS.BUTOFFSET))
-	   (IRIS.BUT54 (IPLUS 54 IRIS.BUTOFFSET))
-	   (IRIS.BUT55 (IPLUS 55 IRIS.BUTOFFSET))
-	   (IRIS.BUT56 (IPLUS 56 IRIS.BUTOFFSET))
-	   (IRIS.BUT57 (IPLUS 57 IRIS.BUTOFFSET))
-	   (IRIS.BUT58 (IPLUS 58 IRIS.BUTOFFSET))
-	   (IRIS.BUT59 (IPLUS 59 IRIS.BUTOFFSET))
-	   (IRIS.BUT60 (IPLUS 60 IRIS.BUTOFFSET))
-	   (IRIS.BUT61 (IPLUS 61 IRIS.BUTOFFSET))
-	   (IRIS.BUT62 (IPLUS 62 IRIS.BUTOFFSET))
-	   (IRIS.BUT63 (IPLUS 63 IRIS.BUTOFFSET))
-	   (IRIS.BUT64 (IPLUS 64 IRIS.BUTOFFSET))
-	   (IRIS.BUT65 (IPLUS 65 IRIS.BUTOFFSET))
-	   (IRIS.BUT66 (IPLUS 66 IRIS.BUTOFFSET))
-	   (IRIS.BUT67 (IPLUS 67 IRIS.BUTOFFSET))
-	   (IRIS.BUT68 (IPLUS 68 IRIS.BUTOFFSET))
-	   (IRIS.BUT69 (IPLUS 69 IRIS.BUTOFFSET))
-	   (IRIS.BUT70 (IPLUS 70 IRIS.BUTOFFSET))
-	   (IRIS.BUT71 (IPLUS 71 IRIS.BUTOFFSET))
-	   (IRIS.BUT72 (IPLUS 72 IRIS.BUTOFFSET))
-	   (IRIS.BUT73 (IPLUS 73 IRIS.BUTOFFSET))
-	   (IRIS.BUT74 (IPLUS 74 IRIS.BUTOFFSET))
-	   (IRIS.BUT75 (IPLUS 75 IRIS.BUTOFFSET))
-	   (IRIS.BUT76 (IPLUS 76 IRIS.BUTOFFSET))
-	   (IRIS.BUT77 (IPLUS 77 IRIS.BUTOFFSET))
-	   (IRIS.BUT78 (IPLUS 78 IRIS.BUTOFFSET))
-	   (IRIS.BUT79 (IPLUS 79 IRIS.BUTOFFSET))
-	   (IRIS.BUT80 (IPLUS 80 IRIS.BUTOFFSET))
-	   (IRIS.BUT81 (IPLUS 81 IRIS.BUTOFFSET))
-	   (IRIS.BUT82 (IPLUS 82 IRIS.BUTOFFSET))
-	   (IRIS.MAXKBDBUT IRIS.BUT82)
-	   (IRIS.BUT100 (IPLUS 100 IRIS.BUTOFFSET))
-	   (IRIS.BUT101 (IPLUS 101 IRIS.BUTOFFSET))
-	   (IRIS.BUT102 (IPLUS 102 IRIS.BUTOFFSET))
-	   (IRIS.BUT103 (IPLUS 103 IRIS.BUTOFFSET))
-	   (IRIS.BUT104 (IPLUS 104 IRIS.BUTOFFSET))
-	   (IRIS.BUT105 (IPLUS 105 IRIS.BUTOFFSET))
-	   (IRIS.BUT106 (IPLUS 106 IRIS.BUTOFFSET))
-	   (IRIS.BUT107 (IPLUS 107 IRIS.BUTOFFSET))
-	   (IRIS.BUT108 (IPLUS 108 IRIS.BUTOFFSET))
-	   (IRIS.BUT109 (IPLUS 109 IRIS.BUTOFFSET))
-	   (IRIS.BUT110 (IPLUS 110 IRIS.BUTOFFSET))
-	   (IRIS.BUT111 (IPLUS 111 IRIS.BUTOFFSET))
-	   (IRIS.BUT112 (IPLUS 112 IRIS.BUTOFFSET))
-	   (IRIS.BUT113 (IPLUS 113 IRIS.BUTOFFSET))
-	   (IRIS.BUT114 (IPLUS 114 IRIS.BUTOFFSET))
-	   (IRIS.BUT115 (IPLUS 115 IRIS.BUTOFFSET))
-	   (IRIS.BUT116 (IPLUS 116 IRIS.BUTOFFSET))
-	   (IRIS.BUT117 (IPLUS 117 IRIS.BUTOFFSET))
-	   (IRIS.BUT118 (IPLUS 118 IRIS.BUTOFFSET))
-	   (IRIS.BUT119 (IPLUS 119 IRIS.BUTOFFSET))
-	   (IRIS.BUT120 (IPLUS 120 IRIS.BUTOFFSET))
-	   (IRIS.BUT121 (IPLUS 121 IRIS.BUTOFFSET))
-	   (IRIS.BUT122 (IPLUS 122 IRIS.BUTOFFSET))
-	   (IRIS.BUT123 (IPLUS 123 IRIS.BUTOFFSET))
-	   (IRIS.BUT124 (IPLUS 124 IRIS.BUTOFFSET))
-	   (IRIS.BUT125 (IPLUS 125 IRIS.BUTOFFSET))
-	   (IRIS.BUT126 (IPLUS 126 IRIS.BUTOFFSET))
-	   (IRIS.BUT127 (IPLUS 127 IRIS.BUTOFFSET))
-	   (IRIS.BUT128 (IPLUS 128 IRIS.BUTOFFSET))
-	   (IRIS.BUT129 (IPLUS 129 IRIS.BUTOFFSET))
-	   (IRIS.BUT130 (IPLUS 130 IRIS.BUTOFFSET))
-	   (IRIS.BUT131 (IPLUS 131 IRIS.BUTOFFSET))
-	   (IRIS.BUT132 (IPLUS 132 IRIS.BUTOFFSET))
-	   (IRIS.BUT133 (IPLUS 133 IRIS.BUTOFFSET))
-	   (IRIS.BUT134 (IPLUS 134 IRIS.BUTOFFSET))
-	   (IRIS.BUT135 (IPLUS 135 IRIS.BUTOFFSET))
-	   (IRIS.BUT136 (IPLUS 136 IRIS.BUTOFFSET))
-	   (IRIS.BUT137 (IPLUS 137 IRIS.BUTOFFSET))
-	   (IRIS.BUT138 (IPLUS 138 IRIS.BUTOFFSET))
-	   (IRIS.BUT139 (IPLUS 139 IRIS.BUTOFFSET))
-	   (IRIS.BUT140 (IPLUS 140 IRIS.BUTOFFSET))
-	   (IRIS.BUT141 (IPLUS 141 IRIS.BUTOFFSET))
-	   (IRIS.MOUSEBUTTON1 IRIS.BUT100)
-	   (IRIS.MOUSEBUTTON2 IRIS.BUT101)
-	   (IRIS.MOUSEBUTTON3 IRIS.BUT102)
-	   (IRIS.MOUSE1 IRIS.BUT100)
-	   (IRIS.MOUSE2 IRIS.BUT101)
-	   (IRIS.MOUSE3 IRIS.BUT102)
-	   (IRIS.LEFTMOUSEBUTTON IRIS.BUT102)
-	   (IRIS.MIDDLEMOUSEBUTTON IRIS.BUT101)
-	   (IRIS.RIGHTMOUSEBUTTON IRIS.BUT100)
-	   (IRIS.LEFTMOUSE IRIS.BUT102)
-	   (IRIS.MIDDLEMOUSE IRIS.BUT101)
-	   (IRIS.RIGHTMOUSE IRIS.BUT100)
-	   (IRIS.LPENBUT 104))
-)
-
-
-
-(* Switches)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQ IRIS.SWBASE IRIS.BUT110)
-
-(RPAQ IRIS.SW0 (IPLUS IRIS.SWBASE 0))
-
-(RPAQ IRIS.SW1 (IPLUS IRIS.SWBASE 1))
-
-(RPAQ IRIS.SW2 (IPLUS IRIS.SWBASE 2))
-
-(RPAQ IRIS.SW3 (IPLUS IRIS.SWBASE 3))
-
-(RPAQ IRIS.SW4 (IPLUS IRIS.SWBASE 4))
-
-(RPAQ IRIS.SW5 (IPLUS IRIS.SWBASE 5))
-
-(RPAQ IRIS.SW6 (IPLUS IRIS.SWBASE 6))
-
-(RPAQ IRIS.SW7 (IPLUS IRIS.SWBASE 7))
-
-(RPAQ IRIS.SW8 (IPLUS IRIS.SWBASE 8))
-
-(RPAQ IRIS.SW9 (IPLUS IRIS.SWBASE 9))
-
-(RPAQ IRIS.SW10 (IPLUS IRIS.SWBASE 10))
-
-(RPAQ IRIS.SW11 (IPLUS IRIS.SWBASE 11))
-
-(RPAQ IRIS.SW12 (IPLUS IRIS.SWBASE 12))
-
-(RPAQ IRIS.SW13 (IPLUS IRIS.SWBASE 13))
-
-(RPAQ IRIS.SW14 (IPLUS IRIS.SWBASE 14))
-
-(RPAQ IRIS.SW15 (IPLUS IRIS.SWBASE 15))
-
-(RPAQ IRIS.SW16 (IPLUS IRIS.SWBASE 16))
-
-(RPAQ IRIS.SW17 (IPLUS IRIS.SWBASE 17))
-
-(RPAQ IRIS.SW18 (IPLUS IRIS.SWBASE 18))
-
-(RPAQ IRIS.SW19 (IPLUS IRIS.SWBASE 19))
-
-(RPAQ IRIS.SW20 (IPLUS IRIS.SWBASE 20))
-
-(RPAQ IRIS.SW21 (IPLUS IRIS.SWBASE 21))
-
-(RPAQ IRIS.SW22 (IPLUS IRIS.SWBASE 22))
-
-(RPAQ IRIS.SW23 (IPLUS IRIS.SWBASE 23))
-
-(RPAQ IRIS.SW24 (IPLUS IRIS.SWBASE 24))
-
-(RPAQ IRIS.SW25 (IPLUS IRIS.SWBASE 25))
-
-(RPAQ IRIS.SW26 (IPLUS IRIS.SWBASE 26))
-
-(RPAQ IRIS.SW27 (IPLUS IRIS.SWBASE 27))
-
-(RPAQ IRIS.SW28 (IPLUS IRIS.SWBASE 28))
-
-(RPAQ IRIS.SW29 (IPLUS IRIS.SWBASE 29))
-
-(RPAQ IRIS.SW30 (IPLUS IRIS.SWBASE 30))
-
-(RPAQ IRIS.SW31 (IPLUS IRIS.SWBASE 31))
-
-(CONSTANTS (IRIS.SWBASE IRIS.BUT110)
-	   (IRIS.SW0 (IPLUS IRIS.SWBASE 0))
-	   (IRIS.SW1 (IPLUS IRIS.SWBASE 1))
-	   (IRIS.SW2 (IPLUS IRIS.SWBASE 2))
-	   (IRIS.SW3 (IPLUS IRIS.SWBASE 3))
-	   (IRIS.SW4 (IPLUS IRIS.SWBASE 4))
-	   (IRIS.SW5 (IPLUS IRIS.SWBASE 5))
-	   (IRIS.SW6 (IPLUS IRIS.SWBASE 6))
-	   (IRIS.SW7 (IPLUS IRIS.SWBASE 7))
-	   (IRIS.SW8 (IPLUS IRIS.SWBASE 8))
-	   (IRIS.SW9 (IPLUS IRIS.SWBASE 9))
-	   (IRIS.SW10 (IPLUS IRIS.SWBASE 10))
-	   (IRIS.SW11 (IPLUS IRIS.SWBASE 11))
-	   (IRIS.SW12 (IPLUS IRIS.SWBASE 12))
-	   (IRIS.SW13 (IPLUS IRIS.SWBASE 13))
-	   (IRIS.SW14 (IPLUS IRIS.SWBASE 14))
-	   (IRIS.SW15 (IPLUS IRIS.SWBASE 15))
-	   (IRIS.SW16 (IPLUS IRIS.SWBASE 16))
-	   (IRIS.SW17 (IPLUS IRIS.SWBASE 17))
-	   (IRIS.SW18 (IPLUS IRIS.SWBASE 18))
-	   (IRIS.SW19 (IPLUS IRIS.SWBASE 19))
-	   (IRIS.SW20 (IPLUS IRIS.SWBASE 20))
-	   (IRIS.SW21 (IPLUS IRIS.SWBASE 21))
-	   (IRIS.SW22 (IPLUS IRIS.SWBASE 22))
-	   (IRIS.SW23 (IPLUS IRIS.SWBASE 23))
-	   (IRIS.SW24 (IPLUS IRIS.SWBASE 24))
-	   (IRIS.SW25 (IPLUS IRIS.SWBASE 25))
-	   (IRIS.SW26 (IPLUS IRIS.SWBASE 26))
-	   (IRIS.SW27 (IPLUS IRIS.SWBASE 27))
-	   (IRIS.SW28 (IPLUS IRIS.SWBASE 28))
-	   (IRIS.SW29 (IPLUS IRIS.SWBASE 29))
-	   (IRIS.SW30 (IPLUS IRIS.SWBASE 30))
-	   (IRIS.SW31 (IPLUS IRIS.SWBASE 31)))
-)
-
-
-
-(* Keys)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQ IRIS.AKEY IRIS.BUT10)
-
-(RPAQ IRIS.BKEY IRIS.BUT35)
-
-(RPAQ IRIS.CKEY IRIS.BUT27)
-
-(RPAQ IRIS.DKEY IRIS.BUT17)
-
-(RPAQ IRIS.EKEY IRIS.BUT16)
-
-(RPAQ IRIS.FKEY IRIS.BUT18)
-
-(RPAQ IRIS.GKEY IRIS.BUT25)
-
-(RPAQ IRIS.HKEY IRIS.BUT26)
-
-(RPAQ IRIS.IKEY IRIS.BUT39)
-
-(RPAQ IRIS.JKEY IRIS.BUT33)
-
-(RPAQ IRIS.KKEY IRIS.BUT34)
-
-(RPAQ IRIS.LKEY IRIS.BUT41)
-
-(RPAQ IRIS.MKEY IRIS.BUT43)
-
-(RPAQ IRIS.NKEY IRIS.BUT36)
-
-(RPAQ IRIS.OKEY IRIS.BUT40)
-
-(RPAQ IRIS.PKEY IRIS.BUT47)
-
-(RPAQ IRIS.QKEY IRIS.BUT9)
-
-(RPAQ IRIS.RKEY IRIS.BUT23)
-
-(RPAQ IRIS.SKEY IRIS.BUT11)
-
-(RPAQ IRIS.TKEY IRIS.BUT24)
-
-(RPAQ IRIS.UKEY IRIS.BUT32)
-
-(RPAQ IRIS.VKEY IRIS.BUT28)
-
-(RPAQ IRIS.WKEY IRIS.BUT15)
-
-(RPAQ IRIS.XKEY IRIS.BUT20)
-
-(RPAQ IRIS.YKEY IRIS.BUT32)
-
-(RPAQ IRIS.ZKEY IRIS.BUT19)
-
-(RPAQ IRIS.ZEROKEY IRIS.BUT45)
-
-(RPAQ IRIS.ONEKEY IRIS.BUT7)
-
-(RPAQ IRIS.TWOKEY IRIS.BUT13)
-
-(RPAQ IRIS.THREEKEY IRIS.BUT14)
-
-(RPAQ IRIS.FOURKEY IRIS.BUT21)
-
-(RPAQ IRIS.FIVCEKEY IRIS.BUT22)
-
-(RPAQ IRIS.SIXKEY IRIS.BUT29)
-
-(RPAQ IRIS.SEVENKEY IRIS.BUT30)
-
-(RPAQ IRIS.EIGHTKEY IRIS.BUT37)
-
-(RPAQ IRIS.NINIKEY IRIS.BUT38)
-
-(RPAQ IRIS.BREAKKEY IRIS.BUT0)
-
-(RPAQ IRIS.SETUPKEY IRIS.BUT1)
-
-(RPAQ IRIS.CNTRLKEY IRIS.BUT2)
-
-(RPAQ IRIS.CAPSLOCKKEY IRIS.BUT3)
-
-(RPAQ IRIS.RIGHTSHIFTKEY IRIS.BUT4)
-
-(RPAQ IRIS.LEFTSHIFTKEY IRIS.BUT5)
-
-(RPAQ IRIS.NOSCRLKEY IRIS.BUT12)
-
-(RPAQ IRIS.ESCKEY IRIS.BUT6)
-
-(RPAQ IRIS.TABKEY IRIS.BUT8)
-
-(RPAQ IRIS.RETURNKEY IRIS.BUT50)
-
-(RPAQ IRIS.SPACEKKEY IRIS.BUT82)
-
-(RPAQ IRIS.LINEFEEDKEY IRIS.BUT59)
-
-(RPAQ IRIS.BACKSPACEKEY IRIS.BUT60)
-
-(RPAQ IRIS.DELETEKEY IRIS.BUT61)
-
-(RPAQ IRIS.SEMICOLONKEY IRIS.BUT42)
-
-(RPAQ IRIS.PERIODKEY IRIS.BUT51)
-
-(RPAQ IRIS.COMMAKEY IRIS.BUT44)
-
-(RPAQ IRIS.QUOTEKEY IRIS.BUT49)
-
-(RPAQ IRIS.ACCENTGRAVEKEY IRIS.BUT54)
-
-(RPAQ IRIS.MINUSKEY IRIS.BUT46)
-
-(RPAQ IRIS.VIRGULEKEY IRIS.BUT52)
-
-(RPAQ IRIS.BACKSLASHKEY IRIS.BUT56)
-
-(RPAQ IRIS.EQUALKEY IRIS.BUT53)
-
-(RPAQ IRIS.LEFTBRACKETKEY IRIS.BUT48)
-
-(RPAQ IRIS.RIGHTBRACKETKEY IRIS.BUT55)
-
-(RPAQ IRIS.LEFTARROWKEY IRIS.BUT72)
-
-(RPAQ IRIS.DOWNARROWKEY IRIS.BUT73)
-
-(RPAQ IRIS.UPARROWKEY IRIS.BUT80)
-
-(RPAQ IRIS.PAD0 IRIS.BUT58)
-
-(RPAQ IRIS.PAD1 IRIS.BUT57)
-
-(RPAQ IRIS.PAD2 IRIS.BUT63)
-
-(RPAQ IRIS.PAD3 IRIS.BUT64)
-
-(RPAQ IRIS.PAD4 IRIS.BUT62)
-
-(RPAQ IRIS.PAD5 IRIS.BUT68)
-
-(RPAQ IRIS.PAD6 IRIS.BUT69)
-
-(RPAQ IRIS.PAD8 IRIS.BUT67)
-
-(RPAQ IRIS.PAD9 IRIS.BUT74)
-
-(RPAQ IRIS.PADPF1 IRIS.BUT71)
-
-(RPAQ IRIS.PADPF2 IRIS.BUT70)
-
-(RPAQ IRIS.PADPF3 IRIS.BUT78)
-
-(RPAQ IRIS.PADPF4 IRIS.BUT77)
-
-(RPAQ IRIS.PADPERIOD IRIS.BUT65)
-
-(RPAQ IRIS.PADMINUS IRIS.BUT75)
-
-(RPAQ IRIS.PADCOMMA IRIS.BUT76)
-
-(RPAQ IRIS.PADENTER IRIS.BUT81)
-
-(CONSTANTS (IRIS.AKEY IRIS.BUT10)
-	   (IRIS.BKEY IRIS.BUT35)
-	   (IRIS.CKEY IRIS.BUT27)
-	   (IRIS.DKEY IRIS.BUT17)
-	   (IRIS.EKEY IRIS.BUT16)
-	   (IRIS.FKEY IRIS.BUT18)
-	   (IRIS.GKEY IRIS.BUT25)
-	   (IRIS.HKEY IRIS.BUT26)
-	   (IRIS.IKEY IRIS.BUT39)
-	   (IRIS.JKEY IRIS.BUT33)
-	   (IRIS.KKEY IRIS.BUT34)
-	   (IRIS.LKEY IRIS.BUT41)
-	   (IRIS.MKEY IRIS.BUT43)
-	   (IRIS.NKEY IRIS.BUT36)
-	   (IRIS.OKEY IRIS.BUT40)
-	   (IRIS.PKEY IRIS.BUT47)
-	   (IRIS.QKEY IRIS.BUT9)
-	   (IRIS.RKEY IRIS.BUT23)
-	   (IRIS.SKEY IRIS.BUT11)
-	   (IRIS.TKEY IRIS.BUT24)
-	   (IRIS.UKEY IRIS.BUT32)
-	   (IRIS.VKEY IRIS.BUT28)
-	   (IRIS.WKEY IRIS.BUT15)
-	   (IRIS.XKEY IRIS.BUT20)
-	   (IRIS.YKEY IRIS.BUT32)
-	   (IRIS.ZKEY IRIS.BUT19)
-	   (IRIS.ZEROKEY IRIS.BUT45)
-	   (IRIS.ONEKEY IRIS.BUT7)
-	   (IRIS.TWOKEY IRIS.BUT13)
-	   (IRIS.THREEKEY IRIS.BUT14)
-	   (IRIS.FOURKEY IRIS.BUT21)
-	   (IRIS.FIVCEKEY IRIS.BUT22)
-	   (IRIS.SIXKEY IRIS.BUT29)
-	   (IRIS.SEVENKEY IRIS.BUT30)
-	   (IRIS.EIGHTKEY IRIS.BUT37)
-	   (IRIS.NINIKEY IRIS.BUT38)
-	   (IRIS.BREAKKEY IRIS.BUT0)
-	   (IRIS.SETUPKEY IRIS.BUT1)
-	   (IRIS.CNTRLKEY IRIS.BUT2)
-	   (IRIS.CAPSLOCKKEY IRIS.BUT3)
-	   (IRIS.RIGHTSHIFTKEY IRIS.BUT4)
-	   (IRIS.LEFTSHIFTKEY IRIS.BUT5)
-	   (IRIS.NOSCRLKEY IRIS.BUT12)
-	   (IRIS.ESCKEY IRIS.BUT6)
-	   (IRIS.TABKEY IRIS.BUT8)
-	   (IRIS.RETURNKEY IRIS.BUT50)
-	   (IRIS.SPACEKKEY IRIS.BUT82)
-	   (IRIS.LINEFEEDKEY IRIS.BUT59)
-	   (IRIS.BACKSPACEKEY IRIS.BUT60)
-	   (IRIS.DELETEKEY IRIS.BUT61)
-	   (IRIS.SEMICOLONKEY IRIS.BUT42)
-	   (IRIS.PERIODKEY IRIS.BUT51)
-	   (IRIS.COMMAKEY IRIS.BUT44)
-	   (IRIS.QUOTEKEY IRIS.BUT49)
-	   (IRIS.ACCENTGRAVEKEY IRIS.BUT54)
-	   (IRIS.MINUSKEY IRIS.BUT46)
-	   (IRIS.VIRGULEKEY IRIS.BUT52)
-	   (IRIS.BACKSLASHKEY IRIS.BUT56)
-	   (IRIS.EQUALKEY IRIS.BUT53)
-	   (IRIS.LEFTBRACKETKEY IRIS.BUT48)
-	   (IRIS.RIGHTBRACKETKEY IRIS.BUT55)
-	   (IRIS.LEFTARROWKEY IRIS.BUT72)
-	   (IRIS.DOWNARROWKEY IRIS.BUT73)
-	   (IRIS.UPARROWKEY IRIS.BUT80)
-	   (IRIS.PAD0 IRIS.BUT58)
-	   (IRIS.PAD1 IRIS.BUT57)
-	   (IRIS.PAD2 IRIS.BUT63)
-	   (IRIS.PAD3 IRIS.BUT64)
-	   (IRIS.PAD4 IRIS.BUT62)
-	   (IRIS.PAD5 IRIS.BUT68)
-	   (IRIS.PAD6 IRIS.BUT69)
-	   (IRIS.PAD8 IRIS.BUT67)
-	   (IRIS.PAD9 IRIS.BUT74)
-	   (IRIS.PADPF1 IRIS.BUT71)
-	   (IRIS.PADPF2 IRIS.BUT70)
-	   (IRIS.PADPF3 IRIS.BUT78)
-	   (IRIS.PADPF4 IRIS.BUT77)
-	   (IRIS.PADPERIOD IRIS.BUT65)
-	   (IRIS.PADMINUS IRIS.BUT75)
-	   (IRIS.PADCOMMA IRIS.BUT76)
-	   (IRIS.PADENTER IRIS.BUT81))
-)
-
-
-
-(* Screen buttons)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQ IRIS.SCRBUT0 (IPLUS IRIS.SBTOFFSET 0))
-
-(RPAQ IRIS.SCRBUT1 (IPLUS IRIS.SBTOFFSET 1))
-
-(RPAQ IRIS.SCRBUT2 (IPLUS IRIS.SBTOFFSET 2))
-
-(RPAQ IRIS.SCRBUT3 (IPLUS IRIS.SBTOFFSET 3))
-
-(RPAQ IRIS.SCRBUT4 (IPLUS IRIS.SBTOFFSET 4))
-
-(RPAQ IRIS.SCRBUT5 (IPLUS IRIS.SBTOFFSET 5))
-
-(RPAQ IRIS.SCRBUT6 (IPLUS IRIS.SBTOFFSET 6))
-
-(RPAQ IRIS.SCRBUT7 (IPLUS IRIS.SBTOFFSET 7))
-
-(RPAQ IRIS.SCRBUT8 (IPLUS IRIS.SBTOFFSET 8))
-
-(RPAQ IRIS.SCRBUT9 (IPLUS IRIS.SBTOFFSET 9))
-
-(RPAQ IRIS.SCRBUT10 (IPLUS IRIS.SBTOFFSET 10))
-
-(RPAQ IRIS.SCRBUT11 (IPLUS IRIS.SBTOFFSET 11))
-
-(RPAQ IRIS.SCRBUT12 (IPLUS IRIS.SBTOFFSET 12))
-
-(RPAQ IRIS.SCRBUT13 (IPLUS IRIS.SBTOFFSET 13))
-
-(RPAQ IRIS.SCRBUT14 (IPLUS IRIS.SBTOFFSET 14))
-
-(RPAQ IRIS.SCRBUT15 (IPLUS IRIS.SBTOFFSET 15))
-
-(RPAQ IRIS.SCRBUT16 (IPLUS IRIS.SBTOFFSET 16))
-
-(CONSTANTS (IRIS.SCRBUT0 (IPLUS IRIS.SBTOFFSET 0))
-	   (IRIS.SCRBUT1 (IPLUS IRIS.SBTOFFSET 1))
-	   (IRIS.SCRBUT2 (IPLUS IRIS.SBTOFFSET 2))
-	   (IRIS.SCRBUT3 (IPLUS IRIS.SBTOFFSET 3))
-	   (IRIS.SCRBUT4 (IPLUS IRIS.SBTOFFSET 4))
-	   (IRIS.SCRBUT5 (IPLUS IRIS.SBTOFFSET 5))
-	   (IRIS.SCRBUT6 (IPLUS IRIS.SBTOFFSET 6))
-	   (IRIS.SCRBUT7 (IPLUS IRIS.SBTOFFSET 7))
-	   (IRIS.SCRBUT8 (IPLUS IRIS.SBTOFFSET 8))
-	   (IRIS.SCRBUT9 (IPLUS IRIS.SBTOFFSET 9))
-	   (IRIS.SCRBUT10 (IPLUS IRIS.SBTOFFSET 10))
-	   (IRIS.SCRBUT11 (IPLUS IRIS.SBTOFFSET 11))
-	   (IRIS.SCRBUT12 (IPLUS IRIS.SBTOFFSET 12))
-	   (IRIS.SCRBUT13 (IPLUS IRIS.SBTOFFSET 13))
-	   (IRIS.SCRBUT14 (IPLUS IRIS.SBTOFFSET 14))
-	   (IRIS.SCRBUT15 (IPLUS IRIS.SBTOFFSET 15))
-	   (IRIS.SCRBUT16 (IPLUS IRIS.SBTOFFSET 16)))
-)
-
-
-
-(* Valuators)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQ IRIS.SGIRESERVED (IPLUS 0 IRIS.VALOFFSET))
-
-(RPAQ IRIS.DIAL0 (PLUS 1 IRIS.VALOFFSET))
-
-(RPAQ IRIS.DIAL1 (PLUS 2 IRIS.VALOFFSET))
-
-(RPAQ IRIS.DIAL2 (PLUS 3 IRIS.VALOFFSET))
-
-(RPAQ IRIS.DIAL3 (PLUS 4 IRIS.VALOFFSET))
-
-(RPAQ IRIS.DIAL4 (PLUS 5 IRIS.VALOFFSET))
-
-(RPAQ IRIS.DIAL5 (PLUS 6 IRIS.VALOFFSET))
-
-(RPAQ IRIS.DIAL6 (PLUS 7 IRIS.VALOFFSET))
-
-(RPAQ IRIS.DIAL7 (PLUS 8 IRIS.VALOFFSET))
-
-(RPAQ IRIS.DIAL8 (PLUS 9 IRIS.VALOFFSET))
-
-(RPAQ IRIS.MOUSEX (PLUS 10 IRIS.VALOFFSET))
-
-(RPAQ IRIS.MOUSEY (PLUS 11 IRIS.VALOFFSET))
-
-(RPAQ IRIS.LPENX (PLUS 12 IRIS.VALOFFSET))
-
-(RPAQ IRIS.PLENY (PLUS 13 IRIS.VALOFFSET))
-
-(RPAQ IRIS.NULLX (PLUS 14 IRIS.VALOFFSET))
-
-(RPAQ IRIS.NULLY (PLUS 15 IRIS.VALOFFSET))
-
-(CONSTANTS (IRIS.SGIRESERVED (IPLUS 0 IRIS.VALOFFSET))
-	   (IRIS.DIAL0 (PLUS 1 IRIS.VALOFFSET))
-	   (IRIS.DIAL1 (PLUS 2 IRIS.VALOFFSET))
-	   (IRIS.DIAL2 (PLUS 3 IRIS.VALOFFSET))
-	   (IRIS.DIAL3 (PLUS 4 IRIS.VALOFFSET))
-	   (IRIS.DIAL4 (PLUS 5 IRIS.VALOFFSET))
-	   (IRIS.DIAL5 (PLUS 6 IRIS.VALOFFSET))
-	   (IRIS.DIAL6 (PLUS 7 IRIS.VALOFFSET))
-	   (IRIS.DIAL7 (PLUS 8 IRIS.VALOFFSET))
-	   (IRIS.DIAL8 (PLUS 9 IRIS.VALOFFSET))
-	   (IRIS.MOUSEX (PLUS 10 IRIS.VALOFFSET))
-	   (IRIS.MOUSEY (PLUS 11 IRIS.VALOFFSET))
-	   (IRIS.LPENX (PLUS 12 IRIS.VALOFFSET))
-	   (IRIS.PLENY (PLUS 13 IRIS.VALOFFSET))
-	   (IRIS.NULLX (PLUS 14 IRIS.VALOFFSET))
-	   (IRIS.NULLY (PLUS 15 IRIS.VALOFFSET)))
-)
-
-
-
-(* Timers)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQ IRIS.TIMER0 (IPLUS IRIS.TIMOFFSET 0))
-
-(RPAQ IRIS.TIMER1 (IPLUS IRIS.TIMOFFSET 1))
-
-(RPAQ IRIS.TIMER2 (IPLUS IRIS.TIMOFFSET 2))
-
-(RPAQ IRIS.TIMER3 (IPLUS IRIS.TIMOFFSET 3))
-
-(RPAQ IRIS.TIMER4 (IPLUS IRIS.TIMOFFSET 4))
-
-(RPAQ IRIS.TIMER5 (IPLUS IRIS.TIMOFFSET 5))
-
-(RPAQ IRIS.TIMER6 (IPLUS IRIS.TIMOFFSET 6))
-
-(RPAQ IRIS.TIMER7 (IPLUS IRIS.TIMOFFSET 7))
-
-(CONSTANTS (IRIS.TIMER0 (IPLUS IRIS.TIMOFFSET 0))
-	   (IRIS.TIMER1 (IPLUS IRIS.TIMOFFSET 1))
-	   (IRIS.TIMER2 (IPLUS IRIS.TIMOFFSET 2))
-	   (IRIS.TIMER3 (IPLUS IRIS.TIMOFFSET 3))
-	   (IRIS.TIMER4 (IPLUS IRIS.TIMOFFSET 4))
-	   (IRIS.TIMER5 (IPLUS IRIS.TIMOFFSET 5))
-	   (IRIS.TIMER6 (IPLUS IRIS.TIMOFFSET 6))
-	   (IRIS.TIMER7 (IPLUS IRIS.TIMOFFSET 7)))
-)
-
-
-
-(* Misc devices)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQ IRIS.KEYBD (IPLUS 1 IRIS.KEYOFFSET))
-
-(RPAQQ IRIS.CURSORX 526)
-
-(RPAQQ IRIS.CURSORY 527)
-
-(RPAQQ IRIS.VALMARK 523)
-
-(RPAQQ IRIS.GERROR 524)
-
-(RPAQQ IRIS.REDRAW 528)
-
-(RPAQQ IRIS.WMSEND 529)
-
-(RPAQQ IRIS.WMREPLY 530)
-
-(RPAQQ IRIS.WMGFCLOSE 531)
-
-(RPAQQ IRIS.WMTXCLOSE 532)
-
-(RPAQQ IRIS.MODECHANGE 533)
-
-(RPAQQ IRIS.INPUTCHANGE 534)
-
-(RPAQQ IRIS.QFULL 535)
-
-(CONSTANTS (IRIS.KEYBD (IPLUS 1 IRIS.KEYOFFSET))
-	   (IRIS.CURSORX 526)
-	   (IRIS.CURSORY 527)
-	   (IRIS.VALMARK 523)
-	   (IRIS.GERROR 524)
-	   (IRIS.REDRAW 528)
-	   (IRIS.WMSEND 529)
-	   (IRIS.WMREPLY 530)
-	   (IRIS.WMGFCLOSE 531)
-	   (IRIS.WMTXCLOSE 532)
-	   (IRIS.MODECHANGE 533)
-	   (IRIS.INPUTCHANGE 534)
-	   (IRIS.QFULL 535))
-)
-(* * get.h)
-
-
-
-
-(* Values returned by IRIS.GETBUFFER)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ IRIS.NEITHERBUFFER 0)
-
-(RPAQQ IRIS.BACKBUFFER 1)
-
-(RPAQQ IRIS.FRONTBUFFER 2)
-
-(RPAQQ IRIS.BOTHBUFFERS 3)
-
-(RPAQQ IRIS.NOBUFFER 0)
-
-(RPAQQ IRIS.BCKBUFFER 1)
-
-(RPAQQ IRIS.FRNTBUFFER 2)
-
-(CONSTANTS (IRIS.NEITHERBUFFER 0)
-	   (IRIS.BACKBUFFER 1)
-	   (IRIS.FRONTBUFFER 2)
-	   (IRIS.BOTHBUFFERS 3)
-	   (IRIS.NOBUFFER 0)
-	   (IRIS.BCKBUFFER 1)
-	   (IRIS.FRNTBUFFER 2))
-)
-
-
-
-(* Values returned by IRIS.GETCMMODE)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ IRIS.MULTIMAP 0)
-
-(RPAQQ IRIS.ONEMAP 1)
-
-(RPAQQ IRIS.CMAPMULTI 0)
-
-(RPAQQ IRIS.CMAPONE 1)
-
-(CONSTANTS (IRIS.MULTIMAP 0)
-	   (IRIS.ONEMAP 1)
-	   (IRIS.CMAPMULTI 0)
-	   (IRIS.CMAPONE 1))
-)
-
-
-
-(* Values returned by IRIS.GETDISPLAYMODE)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ IRIS.RGBMODE 0)
-
-(RPAQQ IRIS.SINGLEBUFFER 1)
-
-(RPAQQ IRIS.DOUBLEBUFFER 2)
-
-(RPAQQ IRIS.DMRGB 0)
-
-(RPAQQ IRIS.DMSINGLE 1)
-
-(RPAQQ IRIS.DMDOUBLE 2)
-
-(CONSTANTS (IRIS.RGBMODE 0)
-	   (IRIS.SINGLEBUFFER 1)
-	   (IRIS.DOUBLEBUFFER 2)
-	   (IRIS.DMRGB 0)
-	   (IRIS.DMSINGLE 1)
-	   (IRIS.DMDOUBLE 2))
-)
-
-
-
-(* Values returned by IRIS.GETDISPLAYMODE)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ IRIS.HZ30 0)
-
-(RPAQQ IRIS.HZ60 1)
-
-(RPAQQ IRIS.NTSC 2)
-
-(RPAQQ IRIS.PAL 2)
-
-(RPAQQ IRIS.HZ50 3)
-
-(RPAQQ IRIS.MONA 5)
-
-(RPAQQ IRIS.MONB 6)
-
-(RPAQQ IRIS.MONC 7)
-
-(RPAQQ IRIS.MOND 8)
-
-(RPAQQ IRIS.MONSPECIAL 16)
-
-(CONSTANTS (IRIS.HZ30 0)
-	   (IRIS.HZ60 1)
-	   (IRIS.NTSC 2)
-	   (IRIS.PAL 2)
-	   (IRIS.HZ50 3)
-	   (IRIS.MONA 5)
-	   (IRIS.MONB 6)
-	   (IRIS.MONC 7)
-	   (IRIS.MOND 8)
-	   (IRIS.MONSPECIAL 16))
-)
-
-
-
-(* Individual hit bits returned by IRIS.HITCODE)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ IRIS.LEFTPLANE 1)
-
-(RPAQQ IRIS.RIGHTPLANE 2)
-
-(RPAQQ IRIS.BOTTOMPLANE 4)
-
-(RPAQQ IRIS.TOPPLANE 8)
-
-(RPAQQ IRIS.NEARPLANE 16)
-
-(RPAQQ IRIS.FARPLANE 32)
-
-(CONSTANTS (IRIS.LEFTPLANE 1)
-	   (IRIS.RIGHTPLANE 2)
-	   (IRIS.BOTTOMPLANE 4)
-	   (IRIS.TOPPLANE 8)
-	   (IRIS.NEARPLANE 16)
-	   (IRIS.FARPLANE 32))
-)
-(* * constants for rotation)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQ IRIS.XAXIS (CHARCODE X))
-
-(RPAQ IRIS.YAXIS (CHARCODE Y))
-
-(RPAQ IRIS.ZAXIS (CHARCODE Z))
-
-(CONSTANTS (IRIS.XAXIS (CHARCODE X))
-	   (IRIS.YAXIS (CHARCODE Y))
-	   (IRIS.ZAXIS (CHARCODE Z)))
-)
-(* * Other stuff)
-
-
-
-
-(* Approximate interval between retraces in milliseconds)
-
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ IRIS.RETRACEINTERVAL 33.33333)
-
-(CONSTANTS (IRIS.RETRACEINTERVAL 33.33333))
-)
-(PUTPROPS IRISCONSTANTS COPYRIGHT ("Xerox Corporation" 1985))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
diff --git a/obsolete/lispusers/IRISDEMOFNS b/obsolete/lispusers/IRISDEMOFNS
deleted file mode 100644
index ed1509c0..00000000
--- a/obsolete/lispusers/IRISDEMOFNS
+++ /dev/null
@@ -1,469 +0,0 @@
-(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
-(FILECREATED " 2-Feb-87 21:13:01" {ERIS}<IRIS>NEXT>IRISDEMOFNS.;10 21478  
-
-      changes to%:  (VARS IRISDEMOFNSCOMS)
-                    (FNS TETRA TETRA.DRAW.FACE TETRA.OBJ)
-
-      previous date%: " 4-Mar-86 10:57:38" {ERIS}<IRIS>NEXT>IRISDEMOFNS.;8)
-
-
-(PRETTYCOMPRINT IRISDEMOFNSCOMS)
-
-(RPAQQ IRISDEMOFNSCOMS [(FNS IRIS.DEGREES SNOW SPHERE TETRA TETRA.COLOR TETRA.DRAW.FACE TETRA.OBJ 
-                             TETRA.TILT.AND.RECURSE)
-                        (VARS IRIS.TILT TETRA.COLOR TETRA.EDGE.COLOR TETRA.SHRINK TETRA.TILT 
-                              IV.DEFAULT.STYLE)
-                        
-          
-          (* ;; "minimal 3-d support for the tetra demo")
-
-                        (RECORDS 3POINT)
-                        (FNS 3DOT 3DRAWTO 3MOVETO 3NORMALIZE 3PLUS 3POINT 3UNITCROSSPRODUCT 
-                             3DIFFERENCE 3CROSSPRODUCT 3LENGTH 3LINE 3TIMES DRAW.FACE? IRIS.XLATE)
-                        (VARS \IRIS.DUMMYBUFFER \IRIS.FEEDBACKBUFFER)
-                        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
-                               (ADDVARS (NLAMA)
-                                      (NLAML)
-                                      (LAMA TETRA])
-(DEFINEQ
-
-(IRIS.DEGREES
-  [LAMBDA (DEGREES)                                          (* edited%: "13-Dec-85 18:32")
-          
-          (* Takes an angle in degrees and returns an angle as the iris likes it
-          (tenths))
-
-    (FIX (TIMES DEGREES 10])
-
-(SNOW
-  [LAMBDA (N)                                                (* edited%: "11-Dec-85 23:12")
-    (for I to (OR N (RAND 5 20)) do (IRIS.PUSHMATRIX)
-                                    (IRIS.TRANSLATE (RAND 0 SCREENWIDTH)
-                                           (RAND 0 SCREENHEIGHT)
-                                           0 \IRISSTREAM)
-                                    (IRIS.ROTATE (RAND 0 1800)
-                                           88)
-                                    (IRIS.ROTATE (RAND 0 1800)
-                                           89)
-                                    (IRIS.ROTATE (RAND 0 1800)
-                                           90)
-                                    (IRIS.SCALE (RAND 0.1 1)
-                                           (RAND 0.1 1)
-                                           (RAND 0.1 1))
-                                    (SPHERE " Noel" (RAND 5 90)
-                                           (RAND 1 3))
-                                    (IRIS.POPMATRIX])
-
-(SPHERE
-  [LAMBDA (MSG THETA COUNT)                                  (* edited%: "11-Dec-85 15:24")
-    (IRIS.PUSHMATRIX)
-    (OR THETA (SETQ THETA 30))
-    (OR COUNT (SETQ COUNT 3))
-    (DSPCOLOR 'RED \IRISSTREAM)
-    (IRIS.PUSHMATRIX)
-    (for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM)
-                                              (DSPCOLOR (IMOD I 7)
-                                                     \IRISSTREAM)
-                                              (IRIS.ROTATE (ITIMES 10 THETA)
-                                                     IRIS.ZAXIS)
-                                              (PRINTOUT \IRISSTREAM MSG))
-    (IRIS.POPMATRIX)
-    (IRIS.PUSHMATRIX)
-    (IRIS.ROTATE 900 IRIS.YAXIS)
-    (DSPCOLOR 'BLACK \IRISSTREAM)
-    (SELECTQ COUNT
-        (1 NIL)
-        (for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM)
-                                                  (DSPCOLOR (IMOD I 7)
-                                                         \IRISSTREAM)
-                                                  (IRIS.ROTATE (ITIMES 10 THETA)
-                                                         IRIS.ZAXIS)
-                                                  (PRINTOUT \IRISSTREAM MSG)))
-    (IRIS.POPMATRIX)
-    (DSPCOLOR 'CYAN \IRISSTREAM)
-    (IRIS.ROTATE 900 IRIS.XAXIS)
-    (SELECTQ COUNT
-        ((1 2) 
-             NIL)
-        (for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM)
-                                                  (DSPCOLOR (IMOD I 7)
-                                                         \IRISSTREAM)
-                                                  (IRIS.ROTATE (ITIMES 10 THETA)
-                                                         IRIS.ZAXIS)
-                                                  (PRINTOUT \IRISSTREAM MSG)))
-    (IRIS.POPMATRIX])
-
-(TETRA
-  [CL:LAMBDA (&OPTIONAL (SIDE-LENGTH 200)
-                    (RECURSIVE-DEPTH 3)
-                    (SHRINK-FACTOR TETRA.SHRINK)
-                    (STYLE 'WIREFRAME)
-                    (DONTBASERECURSE NIL))                   (* ; "Edited 31-Jan-87 17:29 by gbn")
-
-(* ;;; "Draws a recursive tetrahedron.   shrinkfactor is the ratio of side length of parent and child.  style is one of 'wireframe, polygon or normal.")
-
-         (LET ((RECURSIVE-DEPTH (OR RECURSIVE-DEPTH 5))
-               (SHRINK-FACTOR (OR SHRINK-FACTOR TETRA.SHRINK))
-               (STYLE (OR STYLE IV.DEFAULT.STYLE)))
-              (if (EQ 0 RECURSIVE-DEPTH)
-                  then                                       (* ; "done")
-                       NIL
-                else (TETRA.OBJ SIDE-LENGTH (TETRA.COLOR RECURSIVE-DEPTH)
-                            STYLE DONTBASERECURSE)
-                     (if (NOT DONTBASERECURSE)
-                         then (IRIS.PUSHMATRIX)
-                              (IRIS.ROTATE (IRIS.DEGREES 180)
-                                     IRIS.YAXIS)
-                              (IRIS.ROTATE (IRIS.DEGREES (MINUS TETRA.TILT))
-                                     IRIS.XAXIS)
-                              (IRIS.TRANSLATE 0 (QUOTIENT SIDE-LENGTH (SQRT 3))
-                                     0)
-                              (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE
-                                     )
-                              (IRIS.POPMATRIX))
-                     (IRIS.PUSHMATRIX)
-                     (IRIS.TRANSLATE 0 (QUOTIENT SIDE-LENGTH (SQRT 3))
-                            0)                               (* ; 
-                                       "move the origin to the middle of the base of the tetrahedron")
-                     (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE)
-                     (IRIS.ROTATE (IRIS.DEGREES 120)
-                            IRIS.ZAXIS)
-                     (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE)
-                     (IRIS.ROTATE (IRIS.DEGREES 120)
-                            IRIS.ZAXIS)
-                     (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE) 
-          
-          (* ;; "(IRIS.TRANSLATE 0 (MINUS (QUOTIENT X (SQRT 3))) 0) (IRIS.ROTATE (IRIS.DEGREES 180) IRIS.XAXIS) (IRIS.ROTATE (IRIS.DEGREES 180) IRIS.ZAXIS) (TETRA.TILT.AND.RECURSE X RECDEPTH)")
-
-                     (IRIS.POPMATRIX])
-
-(TETRA.COLOR
-  [LAMBDA (COLOR)                                            (* gbn "21-Feb-86 17:11")
-    (IMOD COLOR 8])
-
-(TETRA.DRAW.FACE
-  [LAMBDA (STYLE COLOR LEFT RIGHT TOP)                       (* ; "Edited 31-Jan-87 18:44 by gbn")
-          
-          (* ;; "handles drawing a single face.  Left right and top are just logical names for the points of the triangle.  They need not correspond to Tetra's interpretation of those names.")
-
-    (SELECTQ STYLE
-        (WIREFRAME)
-        ((POLYGON NORMALS BACKFACES) 
-             (if (NOT DONTBASERECURSE)
-                 then (IRIS.POLF 3 (LIST LEFT RIGHT FRONT)))
-             (DSPCOLOR COLOR \IRISSTREAM)
-             (IRIS.POLF 3 (LIST LEFT RIGHT TOP))             (* ; 
-                           "(IRIS.POLF 3 (LIST FRONT RIGHT TOP)) (IRIS.POLF 3 (LIST FRONT LEFT TOP))")
-             (DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM)
-             (3MOVETO \IRISSTREAM LEFT)
-             (3DRAWTO \IRISSTREAM RIGHT)
-             (3DRAWTO \IRISSTREAM TOP)
-             (3DRAWTO \IRISSTREAM LEFT)
-             (SELECTQ STYLE
-                 (POLYGON)
-                 (NORMALS                                    (* ; 
-                                                             "compute and draw a normal to the face")
-                          [LET* ((LEFTTOP (3DIFFERENCE TOP LEFT))
-                                 (LEFTRIGHT (3DIFFERENCE RIGHT LEFT))
-                                 (NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT))
-                                 (NORMAL (3DIFFERENCE NORMALENDPT LEFT)))
-                                (3LINE LEFT (3PLUS LEFT (3TIMES (3NORMALIZE NORMAL)
-                                                               50])
-                 (BACKFACES                                  (* ; 
-                                                             "compute and draw a normal to the face")
-                            (LET* ((LEFTTOP (3DIFFERENCE TOP LEFT))
-                                   (LEFTRIGHT (3DIFFERENCE RIGHT LEFT))
-                                   (NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT))
-                                   (NORMAL (3DIFFERENCE NORMALENDPT LEFT))
-                                   (EYEVECTOR (3DIFFERENCE (IRIS.XLATE IV.VIEWPT)
-                                                     LEFT)))
-                                  (if (LESSP (3DOT EYEVECTOR NORMAL)
-                                             0.0)
-                                      then                   (* ; "this is not a backface so drawit")
-                                           (DSPCOLOR COLOR \IRISSTREAM)
-                                           (IRIS.POLF 3 (LIST LEFT RIGHT TOP))
-                                           (DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM)
-                                           (3MOVETO \IRISSTREAM LEFT)
-                                           (3DRAWTO \IRISSTREAM RIGHT)
-                                           (3DRAWTO \IRISSTREAM TOP)
-                                           (3DRAWTO \IRISSTREAM LEFT))))
-                 (ERROR "Unknown drawing style: " STYLE)))
-        (ERROR "Unknown drawing style: " STYLE])
-
-(TETRA.OBJ
-  [LAMBDA (X COLOR STYLE DONTBASERECURSE)                    (* ; "Edited 31-Jan-87 17:35 by gbn")
-
-(* ;;; "The function that draws a single tetrahedron (and optionally, it's faces.)")
-
-    (LET ([TOP (3POINT 0 (QUOTIENT X (SQRT 3))
-                      (SQRT (TIMES (TIMES X X)
-                                   (QUOTIENT 8 3.0]
-          (LEFT (3POINT (MINUS X)
-                       0 0))
-          (RIGHT (3POINT X 0 0))
-          (FRONT (3POINT 0 (TIMES (SQRT 3)
-                                  X)
-                        0)))
-         (IRIS.PUSHATTRIBUTES)
-         (SELECTQ STYLE
-             (WIREFRAME (DSPCOLOR COLOR \IRISSTREAM)
-                        (3MOVETO \IRISSTREAM LEFT)
-                        (3DRAWTO \IRISSTREAM RIGHT)
-                        (3DRAWTO \IRISSTREAM FRONT)
-                        (3DRAWTO \IRISSTREAM LEFT)
-                        (3DRAWTO \IRISSTREAM TOP)
-                        (3DRAWTO \IRISSTREAM RIGHT)
-                        (3MOVETO \IRISSTREAM FRONT)
-                        (3DRAWTO \IRISSTREAM TOP))
-             ((POLYGON NORMALS BACKFACES) 
-                  (DSPCOLOR COLOR \IRISSTREAM)
-                  (if (NOT DONTBASERECURSE)
-                      then (TETRA.DRAW.FACE STYLE COLOR LEFT RIGHT FRONT))
-                  (TETRA.DRAW.FACE STYLE COLOR LEFT RIGHT TOP)
-                  (TETRA.DRAW.FACE STYLE COLOR RIGHT FRONT TOP)
-                  (TETRA.DRAW.FACE STYLE COLOR FRONT LEFT TOP))
-             (ERROR "Unknown drawing style: " STYLE))
-         (IRIS.POPATTRIBUTES])
-
-(TETRA.TILT.AND.RECURSE
-  [LAMBDA (X RECDEPTH SHRINKFACTOR STYLE)                    (* edited%: "16-Dec-85 17:41")
-          
-          (* * sets up the transformations to recurse, and calls tetra)
-          
-          (* * called with 0 0 0 already placed at the "bottom edge" on the face of the 
-          larger tetra)
-          
-          (* BOTTOMY is the y component of the point BOTTOM, which is not explicitly 
-          calculated)
-
-    (LET [(BOTTOMY (QUOTIENT X (SQRT 3]
-         (IRIS.PUSHMATRIX)
-         (IRIS.TRANSLATE 0 (MINUS (QUOTIENT X (SQRT 3)))
-                0)
-         (IRIS.ROTATE (IRIS.DEGREES TETRA.TILT)
-                IRIS.XAXIS)
-         (IRIS.TRANSLATE 0 (DIFFERENCE BOTTOMY (TIMES BOTTOMY SHRINKFACTOR))
-                0)
-         (IRIS.SCALE SHRINKFACTOR SHRINKFACTOR SHRINKFACTOR)
-         (TETRA (TIMES SHRINKFACTOR X)
-                (SUB1 RECDEPTH)
-                SHRINKFACTOR STYLE T)                        (* IRIS.TRANSLATE 0 (MINUS BOTTOMY) 0)
-          
-          (* put 0 0 0 back on the edge of the larger tetra)
-
-         (IRIS.POPMATRIX])
-)
-
-(RPAQQ IRIS.TILT 70.52878)
-
-(RPAQQ TETRA.COLOR BLUE)
-
-(RPAQQ TETRA.EDGE.COLOR BLACK)
-
-(RPAQQ TETRA.SHRINK 0.7)
-
-(RPAQQ TETRA.TILT 70.52878)
-
-(RPAQQ IV.DEFAULT.STYLE WIREFRAME)
-
-
-
-(* ;; "minimal 3-d support for the tetra demo")
-
-(DECLARE%: EVAL@COMPILE
-
-(RECORD 3POINT (|3X| |3Y| |3Z|))
-)
-(DEFINEQ
-
-(3DOT
-  [LAMBDA (A B)                                              (* gbn " 3-Mar-86 17:54")
-    (PLUS (TIMES (fetch |3X| of A)
-                 (fetch |3X| of B))
-          (TIMES (fetch |3Y| of A)
-                 (fetch |3Y| of B))
-          (TIMES (fetch |3Z| of A)
-                 (fetch |3Z| of B])
-
-(3DRAWTO
-  [LAMBDA (STREAM XOR3PT Y Z)                                (* edited%: "13-Dec-85 16:16")
-    (if (NUMBERP XOR3PT)
-        then (IRIS.DRAW XOR3PT Y Z STREAM)
-      else (IRIS.DRAW (fetch |3X| of XOR3PT)
-                  (fetch |3Y| of XOR3PT)
-                  (fetch |3Z| of XOR3PT)
-                  STREAM])
-
-(3MOVETO
-  [LAMBDA (STREAM XOR3PT Y Z)                                (* edited%: "13-Dec-85 16:16")
-    (if (NUMBERP XOR3PT)
-        then (IRIS.MOVE XOR3PT Y Z STREAM)
-      else (IRIS.MOVE (fetch |3X| of XOR3PT)
-                  (fetch |3Y| of XOR3PT)
-                  (fetch |3Z| of XOR3PT)
-                  STREAM])
-
-(3NORMALIZE
-  [LAMBDA (3VECTOR)                                          (* gbn " 3-Mar-86 15:51")
-          
-          (* * Produces a vector with the same direction but unit magnitude as 3VECTOR)
-
-    (LET ((LENGTH (3LENGTH 3VECTOR)))
-         (3POINT (QUOTIENT (fetch |3X| of 3VECTOR)
-                        LENGTH)
-                (QUOTIENT (fetch |3Y| of 3VECTOR)
-                       LENGTH)
-                (QUOTIENT (fetch |3Z| of 3VECTOR)
-                       LENGTH])
-
-(3PLUS
-  [LAMBDA (A B)                                              (* gbn " 3-Mar-86 14:46")
-                                                             (* vector sum of a and b)
-    (3POINT (PLUS (fetch |3X| of A)
-                  (fetch |3X| of B))
-           (PLUS (fetch |3Y| of A)
-                 (fetch |3Y| of B))
-           (PLUS (fetch |3Z| of A)
-                 (fetch |3Z| of B])
-
-(3POINT
-  [LAMBDA (X Y Z)                                            (* edited%: "13-Dec-85 16:02")
-                                                             (* creates a |3-d| point)
-    (create 3POINT
-           |3X| _ X
-           |3Y| _ Y
-           |3Z| _ Z])
-
-(3UNITCROSSPRODUCT
-  [LAMBDA (A B)                                              (* gbn " 3-Mar-86 15:51")
-    (LET* ((NORMAL (3CROSSPRODUCT A B))
-           (LENGTH (3LENGTH NORMAL)))
-          (replace |3X| of NORMAL with (QUOTIENT (fetch |3X| of NORMAL)
-                                              LENGTH))
-          (replace |3Y| of NORMAL with (QUOTIENT (fetch |3Y| of NORMAL)
-                                              LENGTH))
-          (replace |3Z| of NORMAL with (QUOTIENT (fetch |3Z| of NORMAL)
-                                              LENGTH))
-          NORMAL])
-
-(3DIFFERENCE
-  [LAMBDA (DEST SOURCE)                                      (* gbn "28-Feb-86 17:13")
-                                                             (* vector difference from source to 
-                                                             dest)
-    (3POINT (DIFFERENCE (fetch |3X| of DEST)
-                   (fetch |3X| of SOURCE))
-           (DIFFERENCE (fetch |3Y| of DEST)
-                  (fetch |3Z| of SOURCE))
-           (DIFFERENCE (fetch |3Z| of DEST)
-                  (fetch |3Z| of SOURCE])
-
-(3CROSSPRODUCT
-  [LAMBDA (A B)                                              (* gbn "28-Feb-86 17:17")
-    (3POINT (DIFFERENCE (TIMES (fetch |3Y| of A)
-                               (fetch |3Z| of B))
-                   (TIMES (fetch |3Z| of A)
-                          (fetch |3Y| of B)))
-           (DIFFERENCE (TIMES (fetch |3Z| of A)
-                              (fetch |3X| of B))
-                  (TIMES (fetch |3X| of A)
-                         (fetch |3Z| of B)))
-           (DIFFERENCE (TIMES (fetch |3X| of A)
-                              (fetch |3Y| of B))
-                  (TIMES (fetch |3Y| of A)
-                         (fetch |3X| of B])
-
-(3LENGTH
-  [LAMBDA (A)                                                (* gbn " 3-Mar-86 15:36")
-          
-          (* * returns the euclidean norm of the |3d| vector)
-
-    (SQRT (PLUS (TIMES (fetch |3X| of A)
-                       (fetch |3X| of A))
-                (TIMES (fetch |3Y| of A)
-                       (fetch |3Y| of A))
-                (TIMES (fetch |3Z| of A)
-                       (fetch |3Z| of A])
-
-(3LINE
-  [LAMBDA (A B)                                              (* gbn "28-Feb-86 17:22")
-    (3MOVETO \IRISSTREAM A)
-    (3DRAWTO \IRISSTREAM B])
-
-(3TIMES
-  [LAMBDA (VECTOR SCALAR)                                    (* gbn " 3-Mar-86 14:47")
-    (3POINT (TIMES (fetch |3X| of VECTOR)
-                   SCALAR)
-           (TIMES (fetch |3Y| of VECTOR)
-                  SCALAR)
-           (TIMES (fetch |3Z| of VECTOR)
-                  SCALAR])
-
-(DRAW.FACE?
-  [LAMBDA (LEFT RIGHT TOP COLOR)                             (* gbn " 3-Mar-86 18:45")
-          
-          (* handles drawing a single face. Left right and top are just logical names for 
-          the points of the triangle. They need not correspond to Tetra's interpretation 
-          of those names.)
-
-    (LET* ((LEFTTOP (3DIFFERENCE TOP LEFT))
-           (LEFTRIGHT (3DIFFERENCE RIGHT LEFT))
-           (NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT))
-           (NORMAL (3DIFFERENCE NORMALENDPT LEFT))
-           (EYEVECTOR (3DIFFERENCE (IRIS.XLATE IV.VIEWPT)
-                             LEFT)))
-          (if (GREATERP (3DOT EYEVECTOR NORMAL)
-                     0.0)
-              then                                           (* this is not a backface so drawit)
-                   (DSPCOLOR (OR COLOR 'CYAN)
-                          \IRISSTREAM)
-                   (IRIS.POLF 3 (LIST LEFT RIGHT TOP))
-                   (DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM)
-                   (3MOVETO \IRISSTREAM LEFT)
-                   (3DRAWTO \IRISSTREAM RIGHT)
-                   (3DRAWTO \IRISSTREAM TOP)
-                   (3DRAWTO \IRISSTREAM LEFT])
-
-(IRIS.XLATE
-  [LAMBDA (3VECTOR)                                          (* gbn " 3-Mar-86 17:18")
-    (IRIS.FEEDBACK \IRIS.DUMMYBUFFER 9)
-    (IRIS.XFPT (fetch |3X| of 3VECTOR)
-           (fetch |3Y| of 3VECTOR)
-           (fetch |3Z| of 3VECTOR))
-    (if (NOT (EQUAL (IRIS.ENDFEEDBACK \IRIS.FEEDBACKBUFFER)
-                    9))
-        then (HELP "NINE ITEMS NOT RETURNED"))
-    (3POINT (create FLOATP
-                   HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 2)
-                   LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 3))
-           (create FLOATP
-                  HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 4)
-                  LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 5))
-           (create FLOATP
-                  HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 6)
-                  LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 7])
-)
-
-(RPAQ \IRIS.DUMMYBUFFER (READARRAY 9 (QUOTE FIXP) 1))
-(1 1 1 1 1 1 1 1 1 NIL
-)
-
-(RPAQ \IRIS.FEEDBACKBUFFER (READARRAY 9 (QUOTE FIXP) 1))
-(56 17275 9800 17288 8544 17585 41814 17585 41814 NIL
-)
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA )
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA TETRA)
-)
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1291 13248 (IRIS.DEGREES 1301 . 1568) (SNOW 1570 . 2622) (SPHERE 2624 . 4537) (TETRA 
-4539 . 7134) (TETRA.COLOR 7136 . 7267) (TETRA.DRAW.FACE 7269 . 10466) (TETRA.OBJ 10468 . 12107) (
-TETRA.TILT.AND.RECURSE 12109 . 13246)) (13570 21123 (3DOT 13580 . 13945) (3DRAWTO 13947 . 14317) (
-3MOVETO 14319 . 14689) (3NORMALIZE 14691 . 15221) (3PLUS 15223 . 15686) (3POINT 15688 . 15975) (
-3UNITCROSSPRODUCT 15977 . 16640) (3DIFFERENCE 16642 . 17238) (3CROSSPRODUCT 17240 . 18011) (3LENGTH 
-18013 . 18495) (3LINE 18497 . 18667) (3TIMES 18669 . 19007) (DRAW.FACE? 19009 . 20260) (IRIS.XLATE 
-20262 . 21121)))))
-STOP
diff --git a/obsolete/lispusers/IRISIO b/obsolete/lispusers/IRISIO
deleted file mode 100644
index e70744cb..00000000
--- a/obsolete/lispusers/IRISIO
+++ /dev/null
@@ -1,574 +0,0 @@
-(FILECREATED "12-Nov-85 19:11:43" {ERIS}<IRIS>KOTO>IRISIO.;2 21026  
-
-      changes to:  (VARS IRISIOCOMS)
-		   (FNS IRIS.SENDFS)
-
-      previous date: " 9-Sep-85 13:47:28" {ERIS}<IRIS>KOTO>IRISIO.;1)
-
-
-(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT IRISIOCOMS)
-
-(RPAQQ IRISIOCOMS [(COMS (* User level primitives)
-			   (FNS IRIS.GEXIT IRIS.GFLUSH IRIS.GINIT IRIS.GRESET)
-			   (MACROS IRIS.GFLUSH))
-	(COMS (* Lower level primitives)
-	      (FNS IRIS.RECBS IRIS.RECFS IRIS.RECLS IRIS.RECSS IRIS.SENDBS IRIS.SENDFS IRIS.SENDLS 
-		   IRIS.SENDQS IRIS.SENDSS IRIS.SETFASTCOM)
-	      (MACROS IRIS.DOSYNC IRIS.ECHOFF IRIS.ECHOON IRIS.FLUSHG IRIS.GCMD IRIS.GETGCHAR 
-		      IRIS.GEXIT IRIS.GFINISH IRIS.PUTGCHAR IRIS.REC32 IRIS.REC6 IRIS.RECB IRIS.RECCR 
-		      IRIS.RECF IRIS.RECL IRIS.RECO IRIS.RECOS IRIS.RECS IRIS.SEND6 IRIS.SEND8 
-		      IRIS.SENDB IRIS.SENDC IRIS.SENDF IRIS.SENDL IRIS.SENDO IRIS.SENDS 
-		      SPPINPUTSTREAM SPPSTREAM?)
-	      (CONSTANTS (STDERR T)
-			 (IRIS\AESC 46)
-			 (IRIS\RESC 126)
-			 (IRIS\TESC 16)))
-	[DECLARE: EVAL@LOAD DONTCOPY (P (LOADDEF (QUOTE FLOATP)
-						 (QUOTE RECORD)
-						 (QUOTE LLARITH]
-	(INITVARS (IRISCONN)
-		  (IRISSPPON T))
-	(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-									      (NLAML)
-									      (LAMA])
-
-
-
-(* User level primitives)
-
-(DEFINEQ
-
-(IRIS.GEXIT
-  (LAMBDA (stream)
-    (if stream
-	then (IRIS.FLUSHG stream)
-      else (IRIS.FLUSHG IRISCONN))))
-
-(IRIS.GFLUSH
-  (LAMBDA (stream)
-    (if stream
-	then (IRIS.FLUSHG stream)
-      else (IRIS.FLUSHG IRISCONN))))
-
-(IRIS.GINIT
-  (LAMBDA (STREAM)                                           (* LeL, " 3-Sep-85 17:18")
-    (if (NOT STREAM)
-	then (SETQ STREAM IRISCONN))
-    (IRIS.SETFASTCOM STREAM)                                 (* Assumes that we communicate on the net)
-    (IRIS.XGINIT STREAM)
-    (IRIS.FLUSHG STREAM)))
-
-(IRIS.GRESET
-  (LAMBDA (STREAM)                                           (* LeL, " 3-Sep-85 17:18")
-    (IRIS.XGRESET STREAM)
-    (IRIS.FLUSHG STREAM)))
-)
-(DECLARE: EVAL@COMPILE 
-[PUTPROPS IRIS.GFLUSH MACRO (arg? (* Just for speed...)
-				  (if arg? then (CONS (QUOTE IRIS.FLUSHG)
-						      arg?)
-				      else
-				      (QUOTE (IRIS.FLUSHG IRISCONN]
-)
-
-
-
-(* Lower level primitives)
-
-(DEFINEQ
-
-(IRIS.RECBS
-  (LAMBDA (values stream)                                    (* LeL, " 6-Sep-85 14:15")
-                                                             (* Receive an array of bytes and fill VALUES)
-    (PROG (nLongs nBytes)
-          (SETQ nLongs (LRSH (IPLUS (SETQ nBytes (IRIS.RECL stream))
-				    3)
-			     2))                             (* Number of longs -
-							     FIXP -
-							     to recieve)
-          (if (NEQ IRIS\RESC (IRIS.GETGCHAR stream))
-	      then (PRINT "IRIS.RECBS: error in array transport" STDERR)
-		   (while (SPP.READP stream) do (BIN stream)) 
-                                                             (* Flush input)
-		   (RETURN))
-          (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 3
-	     bind aLong (arrayMax _(IPLUS (ARRAYORIG values)
-					  nVals))
-	     do (SETQ aLong (IRIS.REC32 stream))             (* Recieve 6 six-bits words to make a long)
-		(if (IRIS.DOSYNC i)
-		    then (IRIS.GETGCHAR stream)
-			 (IRIS.PUTGCHAR IRIS\AESC stream)
-			 (IRIS.FLUSHG stream))
-		(for j from 0 to 2 when (LEQ (IPLUS ptr j)
-					     arrayMax)
-		   do (SETA values (IPLUS ptr j)
-			    (LOGAND 255 (LRSH aLong (LLSH j 3))))))
-          (IRIS.GETGCHAR stream))))
-
-(IRIS.RECFS
-  (LAMBDA (values stream)                                    (* LeL, " 6-Sep-85 12:50")
-                                                             (* Common subroutine to IRIS.RECFS and IRIS.RECLS)
-    (PROG (nLongs)
-          (SETQ nLongs (IRIS.RECL stream))
-          (if (NEQ IRIS\RESC (IRIS.GETGCHAR stream))
-	      then (printout STDERR "IRIS.RECFLS: error in array transport" T)
-		   (while (SPP.READP stream) do (BIN stream)) 
-                                                             (* Empty the stream buffer)
-		   (RETURN))
-          (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values)
-	     bind aLong (aFloat _(NCREATE 'FLOATP))
-	     do (SETQ aLong (IRIS.REC32 stream))
-		(if (IRIS.DOSYNC i)
-		    then (IRIS.GETGCHAR stream)
-			 (IRIS.PUTGCHAR IRIS\AESC stream)
-			 (IRIS.FLUSHG stream))
-		(replace (FLOATP HIWORD) of aFloat with (LRSH aLong 16))
-		(replace (FLOATP LOWORD) of aFloat with (LOGAND aLong 65535))
-		(SETA values ptr aFloat))
-          (IRIS.GETGCHAR stream))))
-
-(IRIS.RECLS
-  (LAMBDA (values STREAM)                                    (* LeL, " 6-Sep-85 10:22")
-                                                             (* Recieve an array of longs)
-    (PROG (nLongs)
-          (SETQ nLongs (IRIS.RECL STREAM))
-          (if (NEQ IRIS\RESC (IRIS.GETGCHAR STREAM))
-	      then (PRINT "IRIS.RECLS: error in array transport" STDERR)
-		   (while (SPP.READP stream) do (BIN stream))
-		   (RETURN))
-          (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) bind aLong
-	     do (SETQ aLong (IRIS.REC32 STREAM))
-		(if (IRIS.DOSYNC i)
-		    then (IRIS.GETGCHAR STREAM)
-			 (IRIS.PUTGCHAR IRIS\AESC STREAM)
-			 (IRIS.FLUSHG STREAM))
-		(SETA values ptr aLong))
-          (IRIS.GETGCHAR STREAM))))
-
-(IRIS.RECSS
-  (LAMBDA (values stream)                                    (* LeL, " 6-Sep-85 14:17")
-                                                             (* Recieve an array of SMALL INTEGERS)
-    (PROG (nLongs nShorts)
-          (SETQ nLongs (LRSH (ADD1 (SETQ nShorts (IRIS.RECL stream)))
-			     1))
-          (if (NEQ IRIS\RESC (IRIS.GETGCHAR stream))
-	      then (PRINT "IRIS.RECSS: error in array transport" STDERR)
-		   (while (SPP.READP stream) do (BIN stream))
-		   (RETURN))
-          (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 2 bind aLong
-	     do (SETQ aLong (IRIS.REC32 stream))
-		(if (IRIS.DOSYNC i)
-		    then (IRIS.GETGCHAR stream)
-			 (IRIS.PUTGCHAR IRIS\AESC stream)
-			 (IRIS.FLUSHG stream))
-		(SETA values ptr (LRSH aLong 16))
-		(if (OR (LESSP i (SUB1 nLongs))
-			(EVENP nShorts))
-		    then (SETA values (ADD1 ptr)
-			       (LOGAND 65535 aLong))))
-          (IRIS.GETGCHAR stream))))
-
-(IRIS.SENDBS
-  (LAMBDA (values nVals stream)                              (* LeL, " 9-Sep-85 05:29")
-                                                             (* Send an array of bytes)
-    (PROG (nLongs)
-          (SETQ nLongs (LRSH (IPLUS nVals 3)
-			     2))
-          (COND
-	    ((ARRAYP values)
-	      (IRIS.SENDL nVals stream)                      (* Fill a 32 bits word starting from highest byte :)
-	      (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 4
-		 bind aLong (arrayMax _(IPLUS (ARRAYORIG values)
-					      nVals))
-		 do (SETQ aLong (for j from 0 to 4 when (LEQ (IPLUS ptr j)
-							     arrayMax)
-				   sum (LLSH (ELT values (IPLUS ptr j))
-					     (LLSH j 3))))
-		    (if (IRIS.DOSYNC i)
-			then (IRIS.PUTGCHAR IRIS\AESC stream))
-		    (IRIS.SENDL aLong stream)))
-	    ((LISTP values)
-	      (IRIS.SENDL nVals stream)
-	      (for i from 0 to (SUB1 nLongs) bind (ptr _ values)
-		 do (SETQ aLong (for j from 24 to 0 by -8 when ptr sum (LLSH (pop ptr)
-									     j)))
-		    (if (IRIS.DOSYNC i)
-			then (IRIS.PUTGCHAR IRIS\AESC stream))
-		    (IRIS.SENDL aLong stream)))))))
-
-(IRIS.SENDFS
-  [LAMBDA (values nVals stream)                              (* gbn "11-Nov-85 19:48")
-
-          (* * Sends an array or (possibly two-layered) list of numbers)
-
-
-    (COND
-      ([AND (ARRAYP values)
-	      (NUMBERP (ELT values (ARRAYORIG values]
-                                                             (* An array of numbers)
-	(IRIS.SENDL (LLSH nVals 2)
-		    stream)
-	(for i from 0 to (SUB1 nVals) as ptr from (ARRAYORIG values)
-	   do (if (IRIS.DOSYNC i)
-		    then (IRIS.PUTGCHAR IRIS\AESC stream))
-		(IRIS.SENDF (ELT values ptr)
-			    stream)))
-      ((AND (LISTP values)
-	      (NUMBERP (CAR values)))                    (* A list of numbers)
-	(IRIS.SENDL (LLSH nVals 2)
-		    stream)
-	(for i in values as counter from 0
-	   do (if (IRIS.DOSYNC counter)
-		    then (IRIS.PUTGCHAR IRIS\AESC stream))
-		(IRIS.SENDF i stream)))
-      ((AND (LISTP values)
-	      (POSITIONP (CAR values))
-	      (NUMBERP (CAAR values)))                   (* A list of positions)
-	(IRIS.SENDL (LLSH nVals 2)
-		    stream)
-	(for i in values bind (counter _ -1)
-	   do (if (IRIS.DOSYNC (add counter 1))
-		    then (IRIS.PUTGCHAR IRIS\AESC stream))
-		(IRIS.SENDF (CAR i)
-			    stream)
-		(if (IRIS.DOSYNC (add counter 1))
-		    then (IRIS.PUTGCHAR IRIS\AESC stream))
-		(IRIS.SENDF (CDR i)
-			    stream)))
-      [(AND (LISTP values)
-	      (LISTP (CAR values))
-	      (NUMBERP (CAAR values)))                   (* A list of list of numbers)
-	(IRIS.SENDL (LLSH nVals 2)
-		    stream)
-	(for i in values bind (counter _ -1) do (for j in i eachtime (add counter 1)
-							   do (if (IRIS.DOSYNC counter)
-								    then (IRIS.PUTGCHAR IRIS\AESC 
-											  stream))
-								(IRIS.SENDF j stream]
-      (T (ERROR values "-- is not an list [of list]/array of numbers"])
-
-(IRIS.SENDLS
-  (LAMBDA (values nVals stream)                              (* LeL, " 9-Sep-85 02:14")
-
-          (* * Sends an array or (possibly two-layered) list of numbers)
-
-
-    (COND
-      ((AND (ARRAYP values)
-	    (NUMBERP (ELT values (ARRAYORIG values))))       (* An array of numbers)
-	(IRIS.SENDL (LLSH nVals 2)
-		    stream)
-	(for i from 0 to (SUB1 nVals) as ptr from (ARRAYORIG values)
-	   do (if (IRIS.DOSYNC i)
-		  then (IRIS.PUTGCHAR IRIS\AESC stream))
-	      (IRIS.SENDL (ELT values ptr)
-			  stream)))
-      ((AND (LISTP values)
-	    (NUMBERP (CAR values)))                          (* A list of numbers)
-	(IRIS.SENDL (LLSH nVals 2)
-		    stream)
-	(for i in values as counter from 0
-	   do (if (IRIS.DOSYNC counter)
-		  then (IRIS.PUTGCHAR IRIS\AESC stream))
-	      (IRIS.SENDL i stream)))
-      ((AND (LISTP values)
-	    (LISTP (CAR values))
-	    (NUMBERP (CAAR values)))                         (* A list of list of numbers)
-	(IRIS.SENDL (LLSH nVals 2)
-		    stream)
-	(for i in values bind (counter _ -1) do (for j in i eachtime (add counter 1)
-						   do (if (IRIS.DOSYNC counter)
-							  then (IRIS.PUTGCHAR IRIS\AESC stream))
-						      (IRIS.SENDL j stream))))
-      (T (ERROR values "-- is not an list [of list]/array of numbers")))))
-
-(IRIS.SENDQS
-  (LAMBDA (values nVals stream)                              (* LeL, " 2-Sep-85 12:47")
-    (IRIS.SENDL (LLSH nVals 3))
-    (COND
-      ((ARRAYP values)
-	(for i from 0 to (LLSH nVals 1) by 2 as ptr from 0 by 8
-	   do (if (IRIS.DOSYNC i)
-		  then (IRIS.PUTGCHAR IRIS\AESC stream))
-	      (IRIS.SENDL (LOGOR (LLSH (ELT values ptr)
-				       16)
-				 (LLSH (ELT values (IPLUS ptr 1))
-				       24)
-				 (LLSH (ELT values (IPLUS ptr 2))
-				       8)
-				 (ELT values (IPLUS ptr 3)))
-			  stream)
-	      (if (IRIS.DOSYNC (IPLUS i 1))
-		  then (IRIS.PUTGCHAR IRIS\AESC stream))
-	      (IRIS.SENDL (LOGOR (LLSH (ELT values (IPLUS ptr 4))
-				       24)
-				 (LLSH (ELT values (IPLUS ptr 5))
-				       16)
-				 (ELT values (IPLUS ptr 6))
-				 (LLSH (ELT values (IPLUS ptr 7))
-				       8))
-			  stream)))
-      ((LISTP values)
-	(for i from 0 to (LLSH nVals 1) by 2 as ptr from values by 8
-	   do (if (IRIS.DOSYNC i)
-		  then (IRIS.PUTGCHAR IRIS\AESC stream))
-	      (IRIS.SENDL (LOGOR (LLSH (CAR values)
-				       16)
-				 (LLSH (CADR values)
-				       24)
-				 (LLSH (CADDR values)
-				       8)
-				 (CADDDR values))
-			  stream)
-	      (SETQ values (NTH values 5))
-	      (if (IRIS.DOSYNC (IPLUS i 1))
-		  then (IRIS.PUTGCHAR IRIS\AESC stream))
-	      (IRIS.SENDL (LOGOR (LLSH (ELT values (CAR values))
-				       24)
-				 (LLSH (ELT values (CADR values))
-				       16)
-				 (CADDR values)
-				 (LLSH (CADDDR values)
-				       8))
-			  stream)
-	      (SETQ values (NTH values 5))))
-      (T (ERROR values "-- neither an array nor a list")))))
-
-(IRIS.SENDSS
-  (LAMBDA (values nVals stream)                              (* LeL, " 6-Sep-85 14:20")
-
-          (* * Sends an array or list of numbers shorts (SMALLPs))
-
-
-    (LET ((nLongs (LRSH nVals 1))
-	  (nBytes (LLSH nVals 1)))
-         (COND
-	   ((AND (ARRAYP values)
-		 (NUMBERP (ELT values (ARRAYORIG values))))
-                                                             (* An array of numbers)
-	     (IRIS.SENDL nBytes stream)
-	     (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 2 bind aLong
-		do (SETQ aLong (ELT values ptr))
-		   (if (OR (LESSP i nLongs)
-			   (EVENP nVals))
-		       then (add aLong (LLSH (ELT values (ADD1 ptr))
-					     16)))
-		   (if (IRIS.DOSYNC i)
-		       then (IRIS.PUTGCHAR IRIS\AESC stream))
-		   (IRIS.SENDL aLong stream)))
-	   ((AND (LISTP values)
-		 (NUMBERP (CAR values)))                     (* A list of numbers)
-	     (IRIS.SENDL nBytes stream)
-	     (for i from 0 to (SUB1 nLongs) bind aLong (pnt _ values)
-		do (SETQ aLong (pop pnt))
-		   (if pnt
-		       then (add aLong (LLSH (pop pnt)
-					     16)))
-		   (if (IRIS.DOSYNC i)
-		       then (IRIS.PUTGCHAR IRIS\AESC stream))
-		   (IRIS.SENDL i stream)))
-	   (T (ERROR values "-- is not an list [of list]/array of numbers"))))))
-
-(IRIS.SETFASTCOM
-  (LAMBDA (STREAM)                                           (* gbn "19-Mar-85 21:02")
-    (IRIS.GCMD 1 STREAM)))
-)
-(DECLARE: EVAL@COMPILE 
-[PUTPROPS IRIS.DOSYNC MACRO ((i)
-	   (COND ((EQ 0 (LOGAND i 7)))
-		 (T NIL]
-(PUTPROPS IRIS.ECHOFF MACRO ((STREAM)
-	   (STREAMPROP STREAM (QUOTE IRIS\ECHOFLAG)
-		       NIL)))
-(PUTPROPS IRIS.ECHOON MACRO ((STREAM)
-	   (STREAMPROP STREAM (QUOTE IRIS\ECHOFLAG)
-		       T)))
-(PUTPROPS IRIS.FLUSHG MACRO (= . SPP.FORCEOUTPUT))
-(PUTPROPS IRIS.GCMD MACRO ((CMD STREAM)
-	   (* Sends a command)
-	   (BOUT STREAM IRIS\TESC)
-	   (* Escape character)
-	   (IRIS.SEND6 CMD STREAM)
-	   (* ...followed by the number in two six bits transmission)
-	   (IRIS.SEND6 (LRSH CMD 6)
-		       STREAM)))
-[PUTPROPS IRIS.GETGCHAR MACRO ((STREAM)
-	   (BIN (SPPINPUTSTREAM STREAM]
-[PUTPROPS IRIS.GEXIT MACRO ((stream)
-	   (if stream then (IRIS.FLUSHG stream)
-	       else
-	       (IRIS.FLUSHG IRISCONN]
-(PUTPROPS IRIS.GFINISH MACRO ((stream)
-	   (* null defn)
-	   (IRIS.FLUSHG stream)))
-(PUTPROPS IRIS.PUTGCHAR MACRO ((onechar SPPSTREAM)
-	   (BOUT SPPSTREAM onechar)))
-[PUTPROPS IRIS.REC32 MACRO ((stream)
-	   (for j from 0 to 30 by 6 sum (LLSH (IRIS.REC6 stream)
-					      j]
-(PUTPROPS IRIS.REC6 MACRO ((STREAM)
-	   (* Recieve a 6 bit word; we substract 32 because the other end add3s 32 to avoid sending 
-	      control characters)
-	   (* NO LONGER ANDS 63)
-	   (IDIFFERENCE (IRIS.GETGCHAR STREAM)
-			32)))
-[PUTPROPS IRIS.RECB MACRO (LAMBDA (STREAM)
-				  (* Receive a byte)
-				  (* is passed the spp outputstream, so must grab the input stream 
-				     from it)
-				  (SETQ STREAM (SPPINPUTSTREAM STREAM))
-				  (while (NEQ IRIS\RESC (BIN STREAM)))
-				  (LOGOR (IRIS.REC6 STREAM)
-					 (LLSH (IRIS.REC6 STREAM)
-					       6]
-[PUTPROPS IRIS.RECCR MACRO ((STREAM)
-	   (* recieve a CarriageReturn)
-	   (IRIS.GETGCHAR STREAM)
-	   (* OR (EQ (IRIS.GETGCHAR STREAM)
-		     (IPLUS 32 (CHARCODE CR)))
-	      (ERROR "IRIS.RECCR received a non-carriage return from the IRIS"]
-[PUTPROPS IRIS.RECF MACRO (LAMBDA (SPPSTREAM)
-				  (* gbn "17-Jun-85 17:31")
-				  (* receive a float. uses IRIS.RECL to receive a 32 bit word and 
-				     convert it to float)
-				  (PROG (AFLOAT ALONG)
-					(SETQ ALONG (IRIS.RECL SPPSTREAM))
-					(SETQ AFLOAT (NCREATE (QUOTE FLOATP)))
-					(replace (FLOATP HIWORD)
-						 of AFLOAT with (LRSH ALONG 16))
-					(replace (FLOATP LOWORD)
-						 of AFLOAT with (LOGAND ALONG 65535))
-					(RETURN AFLOAT]
-(PUTPROPS IRIS.RECL MACRO ((stream)
-	   (while (NEQ IRIS\RESC (IRIS.GETGCHAR stream))
-		  do NIL)
-	   (IRIS.REC32 stream)))
-(PUTPROPS IRIS.RECO MACRO ((STREAM)
-	   (* Recieve a boolean)
-	   (IRIS.RECB STREAM)))
-(PUTPROPS IRIS.RECOS MACRO ((values STREAM)
-	   (* Recieve an array of boolean)
-	   (IRIS.RECBS values STREAM)))
-[PUTPROPS IRIS.RECS MACRO ((stream)
-	   (* Recieve a SMALL INTEGER)
-	   (while (NEQ (IRIS.GETGCHAR stream)
-		       IRIS\RESC)
-		  do NIL)
-	   (LET* ((1stbyte (IRIS.REC6 stream))
-		  (2ndbyte (IRIS.REC6 stream)))
-		 (LOGOR 1stbyte (LLSH 2ndbyte 6)
-			(LLSH (IRIS.REC6 stream)
-			      12]
-[PUTPROPS IRIS.SEND6 MACRO ((n STREAM)
-	   (* Add 32 to avoid sending control characters)
-	   (BOUT STREAM (IPLUS 32 (LOGAND 63 n]
-(PUTPROPS IRIS.SEND8 MACRO ((n STREAM)
-	   (BOUT STREAM n)))
-(PUTPROPS IRIS.SENDB MACRO ((VALUE STREAM)
-	   (* Send a byte)
-	   (IRIS.SEND8 VALUE STREAM)))
-(PUTPROPS IRIS.SENDC MACRO ((string stream)
-	   (* Send a string of characters)
-	   (* should probably allocate a global resource)
-	   (IRIS.SENDBS (NCONC1 (CHCON string)
-				0)
-			(ADD1 (NCHARS string))
-			stream)))
-[PUTPROPS IRIS.SENDF MACRO ((value stream)
-	   (* Send a float)
-	   (LET ((float (FLOAT value)))
-		(IRIS.SEND8 (\GETBASEBYTE float 0)
-			    stream)
-		(IRIS.SEND8 (\GETBASEBYTE float 1)
-			    stream)
-		(IRIS.SEND8 (\GETBASEBYTE float 2)
-			    stream)
-		(IRIS.SEND8 (\GETBASEBYTE float 3)
-			    stream]
-[PUTPROPS IRIS.SENDL MACRO (LAMBDA (VALUE STREAM)
-				   (* Sends a 32 bit integer)
-				   (SELECTQ (TYPENAME VALUE)
-					    (SMALLP (if (ILESSP VALUE 0)
-							then
-							(IRIS.SEND8 255 STREAM)
-							(IRIS.SEND8 255 STREAM)
-							else
-							(IRIS.SEND8 0 STREAM)
-							(IRIS.SEND8 0 STREAM))
-						    (IRIS.SEND8 (LOGAND (LRSH VALUE 8)
-									255)
-								STREAM)
-						    (IRIS.SEND8 (LOGAND VALUE 255)
-								STREAM))
-					    (FIXP (IRIS.SEND8 (\GETBASEBYTE VALUE 0)
-							      STREAM)
-						  (IRIS.SEND8 (\GETBASEBYTE VALUE 1)
-							      STREAM)
-						  (IRIS.SEND8 (\GETBASEBYTE VALUE 2)
-							      STREAM)
-						  (IRIS.SEND8 (\GETBASEBYTE VALUE 3)
-							      STREAM))
-					    (ERROR VALUE 
-				   "can't be sent thru IRIS.SENDL (neither an FIXP nor a SMALLP)"]
-(PUTPROPS IRIS.SENDO MACRO ((value STREAM)
-	   (* send a boolean)
-	   (IRIS.SENDB value STREAM)))
-(PUTPROPS IRIS.SENDS MACRO ((value STREAM)
-	   (* Send a SMALL INTEGER (16 bits))
-	   (IRIS.SEND8 (LOGAND 255 (LRSH value 8))
-		       STREAM)
-	   (IRIS.SEND8 (LOGAND 255 value)
-		       STREAM)))
-[PUTPROPS SPPINPUTSTREAM MACRO ((OUTPUTSTREAM)
-	   (* gbn "17-Jun-85 17:40")
-	   (fetch (SPPCON SPPINPUTSTREAM)
-		  of
-		  (fetch (STREAM F1)
-			 of OUTPUTSTREAM]
-[PUTPROPS SPPSTREAM? MACRO (LAMBDA (STREAM)
-				   (AND (TYPENAME STREAM (QUOTE STREAM))
-					(TYPENAMEP (fetch F1 of STREAM)
-						   (QUOTE SPPCON]
-)
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ STDERR T)
-
-(RPAQQ IRIS\AESC 46)
-
-(RPAQQ IRIS\RESC 126)
-
-(RPAQQ IRIS\TESC 16)
-
-(CONSTANTS (STDERR T)
-	   (IRIS\AESC 46)
-	   (IRIS\RESC 126)
-	   (IRIS\TESC 16))
-)
-(DECLARE: EVAL@LOAD DONTCOPY 
-(LOADDEF (QUOTE FLOATP)
-	 (QUOTE RECORD)
-	 (QUOTE LLARITH))
-)
-
-(RPAQ? IRISCONN )
-
-(RPAQ? IRISSPPON T)
-(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA )
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA )
-)
-(PUTPROPS IRISIO COPYRIGHT ("Xerox Corporation" 1985))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (1379 2155 (IRIS.GEXIT 1389 . 1514) (IRIS.GFLUSH 1516 . 1642) (IRIS.GINIT 1644 . 1986) (
-IRIS.GRESET 1988 . 2153)) (2392 15323 (IRIS.RECBS 2402 . 3820) (IRIS.RECFS 3822 . 4990) (IRIS.RECLS 
-4992 . 5841) (IRIS.RECSS 5843 . 6941) (IRIS.SENDBS 6943 . 8275) (IRIS.SENDFS 8277 . 10344) (
-IRIS.SENDLS 10346 . 11826) (IRIS.SENDQS 11828 . 13707) (IRIS.SENDSS 13709 . 15181) (IRIS.SETFASTCOM 
-15183 . 15321)))))
-STOP
diff --git a/obsolete/lispusers/IRISLIB b/obsolete/lispusers/IRISLIB
deleted file mode 100644
index 44a0f4e2..00000000
--- a/obsolete/lispusers/IRISLIB
+++ /dev/null
@@ -1,3943 +0,0 @@
-(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
-(FILECREATED " 2-Feb-87 23:35:29" {ERIS}<IRIS>NEXT>IRISLIB.;7 150378 
-
-      changes to%:  (VARS IRISLIBCOMS)
-                    (FNS IRIS\ERROR)
-
-      previous date%: " 9-Sep-85 05:32:30" {ERIS}<IRIS>NEXT>IRISLIB.;1)
-
-
-(* "
-Copyright (c) 1985, 1987 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT IRISLIBCOMS)
-
-(RPAQQ IRISLIBCOMS 
-       ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES SPPDECLS (LOADCOMP)
-                                                IRISIO IRISSTREAM))
-        (GLOBALVARS IRISCONN)
-        (FNS IRIS.XSETSLOWCOM IRIS.XSETFASTCOM IRIS.GVERSION IRIS.GDOWNLOAD IRIS.PAGECOLOR 
-             IRIS.TEXTCOLOR IRIS.TEXTPORT IRIS.ARC IRIS.ARCF IRIS.ARCFI IRIS.ARCI IRIS.ATTACHCURSOR 
-             IRIS.BACKBUFFER IRIS.BBOX2 IRIS.BBOX2I IRIS.BLINK IRIS.CALLOBJ IRIS.CHARSTR IRIS.CIRC 
-             IRIS.CIRCF IRIS.CIRCFI IRIS.CIRCI IRIS.CLEAR IRIS.CLEARHITCODE IRIS.CLOSEOBJ IRIS.CMOV 
-             IRIS.CMOV2 IRIS.CMOV2I IRIS.CMOVI IRIS.COLOR IRIS.CURSOFF IRIS.CURSON IRIS.CURVEIT 
-             IRIS.DEFCURSOR IRIS.DEFLINESTYLE IRIS.DEFRASTERFONT IRIS.DELOBJ IRIS.DOUBLEBUFFER 
-             IRIS.DRAW IRIS.DRAW2 IRIS.DRAW2I IRIS.DRAWI IRIS.EDITOBJ IRIS.ENDPICK IRIS.ENDSELECT 
-             IRIS.FINISH IRIS.FONT IRIS.FRONTBUFFER IRIS.GCONFIG IRIS.GENOBJ IRIS.GENTAG 
-             IRIS.GETBUFFER IRIS.GETBUTTON IRIS.GETCMMODE IRIS.GETCOLOR IRIS.GETCURSOR IRIS.GETDEPTH 
-             IRIS.GETDISPLAYMODE IRIS.GETFONT IRIS.GETHEIGHT IRIS.GETHITCODE IRIS.GETLSBACKUP 
-             IRIS.GETLSTYLE IRIS.GETLWIDTH IRIS.GETMAP IRIS.GETMATRIX IRIS.GETPLANES IRIS.GETRESETLS 
-             IRIS.GETSCRMASK IRIS.GETVALUATOR IRIS.GETVIEWPORT IRIS.GETWRITEMASK IRIS.XGINIT 
-             IRIS.XGRESET IRIS.GRGBCOLOR IRIS.GRGBCURSOR IRIS.GRGBMASK IRIS.ISOBJ IRIS.ISTAG 
-             IRIS.LINEWIDTH IRIS.LOADMATRIX IRIS.LOOKAT IRIS.LSBACKUP IRIS.MAKEOBJ IRIS.MAKETAG 
-             IRIS.MAPCOLOR IRIS.MAPW IRIS.MAPW2 IRIS.MOVE IRIS.MOVE2 IRIS.MOVE2I IRIS.MOVEI 
-             IRIS.MULTIMAP IRIS.MULTMATRIX IRIS.NOISE IRIS.ONEMAP IRIS.ORTHO IRIS.ORTHO2 
-             IRIS.PERSPECTIVE IRIS.PICK IRIS.PICKSIZE IRIS.PNT IRIS.PNT2 IRIS.PNT2I IRIS.PNTI 
-             IRIS.POLARVIEW IRIS.POLF IRIS.POLF2 IRIS.POLF2I IRIS.POLFI IRIS.POLY IRIS.POLY2 
-             IRIS.POLY2I IRIS.POLYI IRIS.POPATTRIBUTES IRIS.POPMATRIX IRIS.POPVIEWPORT 
-             IRIS.PUSHATTRIBUTES IRIS.PUSHMATRIX IRIS.PUSHVIEWPORT IRIS.QENTER IRIS.QREAD IRIS.QRESET 
-             IRIS.QTEST IRIS.READPIXELS IRIS.READRGB IRIS.RECT IRIS.RECTF IRIS.RECTFI IRIS.RECTI 
-             IRIS.RESETLS IRIS.RGBCOLOR IRIS.RGBCURSOR IRIS.RGBMODE IRIS.RGBWRITEMASK IRIS.ROTATE 
-             IRIS.SCALE IRIS.SCRMASK IRIS.SELECT IRIS.SETBUTTON IRIS.SETCURSOR IRIS.SETDEPTH 
-             IRIS.SETLINESTYLE IRIS.SETMAP IRIS.SETVALUATOR IRIS.SINGLEBUFFER IRIS.STRWIDTH 
-             IRIS.SWAPBUFFERS IRIS.SWAPINTERVAL IRIS.GSYNC IRIS.TIE IRIS.TRANSLATE IRIS.VIEWPORT 
-             IRIS.WINDOW IRIS.WRITEMASK IRIS.WRITEPIXELS IRIS.WRITERGB IRIS.TPON IRIS.TPOFF 
-             IRIS.TEXTWRITEMASK IRIS.XGEXIT IRIS.CLKON IRIS.CLKOFF IRIS.LAMPON IRIS.LAMPOFF 
-             IRIS.SETBELL IRIS.RINGBELL IRIS.TADELAY IRIS.ARCFS IRIS.ARCS IRIS.BBOX2S 
-             IRIS.BLANKSCREEN IRIS.BLKQREAD IRIS.GETMCOLOR IRIS.CALLFUNC IRIS.CHUNKSIZE IRIS.CIRCFS 
-             IRIS.CIRCS IRIS.CMOV2S IRIS.CMOVS IRIS.COMPACTIFY IRIS.QDEVICE IRIS.UNQDEVICE 
-             IRIS.CURVEBASIS IRIS.CURVEPRECISION IRIS.CRV IRIS.GETTP IRIS.GBEGIN IRIS.TEXTINIT 
-             IRIS.CRVN IRIS.DEFBASIS IRIS.DELTAG IRIS.DEPTHCUE IRIS.DRAW2S IRIS.DRAWS 
-             IRIS.ENDFEEDBACK IRIS.FEEDBACK IRIS.GETCPOS IRIS.GETDCM IRIS.GETGPOS IRIS.GETLSREPEAT 
-             IRIS.GETMEM IRIS.GETMONITOR IRIS.GETOPENOBJ IRIS.GETZBUFFER IRIS.GEWRITE IRIS.INITNAMES 
-             IRIS.LOADNAME IRIS.LSREPEAT IRIS.MOVE2S IRIS.MOVES IRIS.NEWTAG IRIS.PASSTHROUGH 
-             IRIS.PATCHBASIS IRIS.PATCHPRECISION IRIS.PATCH IRIS.PCLOS IRIS.PDR IRIS.PDR2 IRIS.PDRI 
-             IRIS.PDR2I IRIS.PDRS IRIS.PDR2S IRIS.POLF2S IRIS.POLFS IRIS.POLY2S IRIS.POLYS IRIS.PMV 
-             IRIS.PMV2 IRIS.PMVI IRIS.PMV2I IRIS.PMVS IRIS.PMV2S IRIS.PNT2S IRIS.PNTS IRIS.POPNAME 
-             IRIS.PUSHNAME IRIS.RDR IRIS.RDR2 IRIS.RDRI IRIS.RDR2I IRIS.RDRS IRIS.RDR2S IRIS.RECTCOPY 
-             IRIS.RMV IRIS.RMV2 IRIS.RMVI IRIS.RMV2I IRIS.RMVS IRIS.RMV2S IRIS.RPDR IRIS.RPDR2 
-             IRIS.RPDRI IRIS.RPDR2I IRIS.RPDRS IRIS.RPDR2S IRIS.RPMV IRIS.RPMV2 IRIS.RPMVI 
-             IRIS.RPMV2I IRIS.RPMVS IRIS.RPMV2S IRIS.SETDBLIGHTS IRIS.SETMONITOR IRIS.SETSHADE 
-             IRIS.SHADERANGE IRIS.SPCLOS IRIS.SPLF IRIS.SPLF2 IRIS.SPLFI IRIS.SPLF2I IRIS.SPLFS 
-             IRIS.SPLF2S IRIS.XFPT IRIS.XFPTI IRIS.XFPTS IRIS.XFPT2 IRIS.XFPT2I IRIS.XFPT2S 
-             IRIS.XFPT4 IRIS.XFPT4I IRIS.XFPT4S IRIS.ZBUFFER IRIS.CHARST IRIS.STRWID IRIS.DEFPATTERN 
-             IRIS.GETPATTERN IRIS.SETPATTERN IRIS.OBJINSERT IRIS.OBJDELETE IRIS.OBJREPLACE 
-             IRIS.ZCLEAR IRIS.CURORIGIN IRIS.PAGEWRITEMASK IRIS.PATCHCURVES IRIS.DBTEXT IRIS.LASTONE 
-             IRIS\ERROR)))
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(FILESLOAD SPPDECLS (LOADCOMP)
-       IRISIO IRISSTREAM)
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS IRISCONN)
-)
-(DEFINEQ
-
-(IRIS.XSETSLOWCOM
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 0 sppStream])
-
-(IRIS.XSETFASTCOM
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 1 sppStream])
-
-(IRIS.GVERSION
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 2 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GDOWNLOAD
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 3 sppStream])
-
-(IRIS.PAGECOLOR
-  [LAMBDA (color sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if color
-        then (IRIS.GCMD 4 sppStream)
-             (IRIS.SENDS color sppStream)
-      else (IRIS\ERROR %'IRIS.PAGECOLOR %' (color])
-
-(IRIS.TEXTCOLOR
-  [LAMBDA (color sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if color
-        then (IRIS.GCMD 5 sppStream)
-             (IRIS.SENDS color sppStream)
-      else (IRIS\ERROR %'IRIS.TEXTCOLOR %' (color])
-
-(IRIS.TEXTPORT
-  [LAMBDA (left right top bottom sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND left right top bottom)
-        then (IRIS.GCMD 6 sppStream)
-             (IRIS.SENDS left sppStream)
-             (IRIS.SENDS right sppStream)
-             (IRIS.SENDS top sppStream)
-             (IRIS.SENDS bottom sppStream)
-      else (IRIS\ERROR %'IRIS.TEXTPORT %' (left right top bottom])
-
-(IRIS.ARC
-  [LAMBDA (x y radius startang endang sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius startang endang)
-        then (IRIS.GCMD 7 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF radius sppStream)
-             (IRIS.SENDS startang sppStream)
-             (IRIS.SENDS endang sppStream)
-      else (IRIS\ERROR %'IRIS.ARC %' (x y radius startang endang])
-
-(IRIS.ARCF
-  [LAMBDA (x y radius startang endang sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius startang endang)
-        then (IRIS.GCMD 8 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF radius sppStream)
-             (IRIS.SENDS startang sppStream)
-             (IRIS.SENDS endang sppStream)
-      else (IRIS\ERROR %'IRIS.ARCF %' (x y radius startang endang])
-
-(IRIS.ARCFI
-  [LAMBDA (x y radius startang endang sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius startang endang)
-        then (IRIS.GCMD 9 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL radius sppStream)
-             (IRIS.SENDS startang sppStream)
-             (IRIS.SENDS endang sppStream)
-      else (IRIS\ERROR %'IRIS.ARCFI %' (x y radius startang endang])
-
-(IRIS.ARCI
-  [LAMBDA (x y radius startang endang sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius startang endang)
-        then (IRIS.GCMD 10 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL radius sppStream)
-             (IRIS.SENDS startang sppStream)
-             (IRIS.SENDS endang sppStream)
-      else (IRIS\ERROR %'IRIS.ARCI %' (x y radius startang endang])
-
-(IRIS.ATTACHCURSOR
-  [LAMBDA (vx vy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND vx vy)
-        then (IRIS.GCMD 11 sppStream)
-             (IRIS.SENDS vx sppStream)
-             (IRIS.SENDS vy sppStream)
-      else (IRIS\ERROR %'IRIS.ATTACHCURSOR %' (vx vy])
-
-(IRIS.BACKBUFFER
-  [LAMBDA (b sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if b
-        then (IRIS.GCMD 12 sppStream)
-             (IRIS.SENDO b sppStream)
-      else (IRIS\ERROR %'IRIS.BACKBUFFER %' (b])
-
-(IRIS.BBOX2
-  [LAMBDA (xmin ymin x1 y1 x2 y2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND xmin ymin x1 y1 x2 y2)
-        then (IRIS.GCMD 14 sppStream)
-             (IRIS.SENDS xmin sppStream)
-             (IRIS.SENDS ymin sppStream)
-             (IRIS.SENDF x1 sppStream)
-             (IRIS.SENDF y1 sppStream)
-             (IRIS.SENDF x2 sppStream)
-             (IRIS.SENDF y2 sppStream)
-      else (IRIS\ERROR %'IRIS.BBOX2 %' (xmin ymin x1 y1 x2 y2])
-
-(IRIS.BBOX2I
-  [LAMBDA (xmin ymin x1 y1 x2 y2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND xmin ymin x1 y1 x2 y2)
-        then (IRIS.GCMD 15 sppStream)
-             (IRIS.SENDS xmin sppStream)
-             (IRIS.SENDS ymin sppStream)
-             (IRIS.SENDL x1 sppStream)
-             (IRIS.SENDL y1 sppStream)
-             (IRIS.SENDL x2 sppStream)
-             (IRIS.SENDL y2 sppStream)
-      else (IRIS\ERROR %'IRIS.BBOX2I %' (xmin ymin x1 y1 x2 y2])
-
-(IRIS.BLINK
-  [LAMBDA (rate color red green blue sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND rate color red green blue)
-        then (IRIS.GCMD 17 sppStream)
-             (IRIS.SENDS rate sppStream)
-             (IRIS.SENDS color sppStream)
-             (IRIS.SENDS red sppStream)
-             (IRIS.SENDS green sppStream)
-             (IRIS.SENDS blue sppStream)
-      else (IRIS\ERROR %'IRIS.BLINK %' (rate color red green blue])
-
-(IRIS.CALLOBJ
-  [LAMBDA (obj sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if obj
-        then (IRIS.GCMD 18 sppStream)
-             (IRIS.SENDL obj sppStream)
-      else (IRIS\ERROR %'IRIS.CALLOBJ %' (obj])
-
-(IRIS.CHARSTR
-  [LAMBDA (str sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if str
-        then (IRIS.GCMD 19 sppStream)
-             (IRIS.SENDC str sppStream)
-      else (IRIS\ERROR %'IRIS.CHARSTR %' (str])
-
-(IRIS.CIRC
-  [LAMBDA (x y radius sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius)
-        then (IRIS.GCMD 20 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF radius sppStream)
-      else (IRIS\ERROR %'IRIS.CIRC %' (x y radius])
-
-(IRIS.CIRCF
-  [LAMBDA (x y radius sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius)
-        then (IRIS.GCMD 21 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF radius sppStream)
-      else (IRIS\ERROR %'IRIS.CIRCF %' (x y radius])
-
-(IRIS.CIRCFI
-  [LAMBDA (x y radius sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius)
-        then (IRIS.GCMD 22 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL radius sppStream)
-      else (IRIS\ERROR %'IRIS.CIRCFI %' (x y radius])
-
-(IRIS.CIRCI
-  [LAMBDA (x y radius sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius)
-        then (IRIS.GCMD 23 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL radius sppStream)
-      else (IRIS\ERROR %'IRIS.CIRCI %' (x y radius])
-
-(IRIS.CLEAR
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 24 sppStream])
-
-(IRIS.CLEARHITCODE
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 25 sppStream])
-
-(IRIS.CLOSEOBJ
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 29 sppStream])
-
-(IRIS.CMOV
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 30 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF z sppStream)
-      else (IRIS\ERROR %'IRIS.CMOV %' (x y z])
-
-(IRIS.CMOV2
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 31 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-      else (IRIS\ERROR %'IRIS.CMOV2 %' (x y])
-
-(IRIS.CMOV2I
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 32 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-      else (IRIS\ERROR %'IRIS.CMOV2I %' (x y])
-
-(IRIS.CMOVI
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 33 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL z sppStream)
-      else (IRIS\ERROR %'IRIS.CMOVI %' (x y z])
-
-(IRIS.COLOR
-  [LAMBDA (color sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if color
-        then (IRIS.GCMD 34 sppStream)
-             (IRIS.SENDS color sppStream)
-      else (IRIS\ERROR %'IRIS.COLOR %' (color])
-
-(IRIS.CURSOFF
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 35 sppStream])
-
-(IRIS.CURSON
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 36 sppStream])
-
-(IRIS.CURVEIT
-  [LAMBDA (iterationcount sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if iterationcount
-        then (IRIS.GCMD 38 sppStream)
-             (IRIS.SENDS iterationcount sppStream)
-      else (IRIS\ERROR %'IRIS.CURVEIT %' (iterationcount])
-
-(IRIS.DEFCURSOR
-  [LAMBDA (n curs sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n curs)
-        then (IRIS.GCMD 39 sppStream)
-             (IRIS.SENDS n sppStream)
-             (IRIS.SENDSS curs 16 sppStream)
-      else (IRIS\ERROR %'IRIS.DEFCURSOR %' (n curs])
-
-(IRIS.DEFLINESTYLE
-  [LAMBDA (n ls sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n ls)
-        then (IRIS.GCMD 40 sppStream)
-             (IRIS.SENDS n sppStream)
-             (IRIS.SENDS ls sppStream)
-      else (IRIS\ERROR %'IRIS.DEFLINESTYLE %' (n ls])
-
-(IRIS.DEFRASTERFONT
-  [LAMBDA (n ht nc chars nr raster sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n ht nc chars nr raster)
-        then (IRIS.GCMD 42 sppStream)
-             (IRIS.SENDS n sppStream)
-             (IRIS.SENDS ht sppStream)
-             (IRIS.SENDS nc sppStream)
-             (IRIS.SENDQS chars nc sppStream)
-             (IRIS.SENDS nr sppStream)
-             (IRIS.SENDSS raster nr sppStream)
-      else (IRIS\ERROR %'IRIS.DEFRASTERFONT %' (n ht nc chars nr raster])
-
-(IRIS.DELOBJ
-  [LAMBDA (obj sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if obj
-        then (IRIS.GCMD 45 sppStream)
-             (IRIS.SENDL obj sppStream)
-      else (IRIS\ERROR %'IRIS.DELOBJ %' (obj])
-
-(IRIS.DOUBLEBUFFER
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 46 sppStream])
-
-(IRIS.DRAW
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 47 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF z sppStream)
-      else (IRIS\ERROR %'IRIS.DRAW %' (x y z])
-
-(IRIS.DRAW2
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 48 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-      else (IRIS\ERROR %'IRIS.DRAW2 %' (x y])
-
-(IRIS.DRAW2I
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 49 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-      else (IRIS\ERROR %'IRIS.DRAW2I %' (x y])
-
-(IRIS.DRAWI
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 50 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL z sppStream)
-      else (IRIS\ERROR %'IRIS.DRAWI %' (x y z])
-
-(IRIS.EDITOBJ
-  [LAMBDA (obj sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if obj
-        then (IRIS.GCMD 51 sppStream)
-             (IRIS.SENDL obj sppStream)
-      else (IRIS\ERROR %'IRIS.EDITOBJ %' (obj])
-
-(IRIS.ENDPICK
-  [LAMBDA (buffer sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if buffer
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 52 sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECL sppStream))
-                  (IRIS.RECSS buffer sppStream)
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.ENDPICK %' (buffer])
-
-(IRIS.ENDSELECT
-  [LAMBDA (buffer sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if buffer
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 53 sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECL sppStream))
-                  (IRIS.RECSS buffer sppStream)
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.ENDSELECT %' (buffer])
-
-(IRIS.FINISH
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 54 sppStream])
-
-(IRIS.FONT
-  [LAMBDA (fntnum sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if fntnum
-        then (IRIS.GCMD 55 sppStream)
-             (IRIS.SENDS fntnum sppStream)
-      else (IRIS\ERROR %'IRIS.FONT %' (fntnum])
-
-(IRIS.FRONTBUFFER
-  [LAMBDA (b sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if b
-        then (IRIS.GCMD 56 sppStream)
-             (IRIS.SENDO b sppStream)
-      else (IRIS\ERROR %'IRIS.FRONTBUFFER %' (b])
-
-(IRIS.GCONFIG
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 57 sppStream])
-
-(IRIS.GENOBJ
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 58 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GENTAG
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 59 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETBUFFER
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 60 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETBUTTON
-  [LAMBDA (b sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if b
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 61 sppStream)
-                  (IRIS.SENDS b sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECO sppStream))
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.GETBUTTON %' (b])
-
-(IRIS.GETCMMODE
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 62 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECO sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETCOLOR
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 63 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETCURSOR
-  [LAMBDA (index color wtm b sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND index color wtm b)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 64 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET index (IRIS.RECS sppStream))
-             (SET color (IRIS.RECS sppStream))
-             (SET wtm (IRIS.RECS sppStream))
-             (SET b (IRIS.RECO sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GETCURSOR %' (index color wtm b])
-
-(IRIS.GETDEPTH
-  [LAMBDA (near far sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND near far)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 65 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET near (IRIS.RECS sppStream))
-             (SET far (IRIS.RECS sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GETDEPTH %' (near far])
-
-(IRIS.GETDISPLAYMODE
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 66 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETFONT
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 67 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETHEIGHT
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 68 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETHITCODE
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 69 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETLSBACKUP
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 70 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECO sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETLSTYLE
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 71 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETLWIDTH
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 72 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETMAP
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 73 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETMATRIX
-  [LAMBDA (m sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if m
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 74 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (IRIS.RECFS m sppStream)
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GETMATRIX %' (m])
-
-(IRIS.GETPLANES
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 76 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETRESETLS
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 77 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECO sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETSCRMASK
-  [LAMBDA (left right bottom top sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND left right bottom top)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 78 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET left (IRIS.RECS sppStream))
-             (SET right (IRIS.RECS sppStream))
-             (SET bottom (IRIS.RECS sppStream))
-             (SET top (IRIS.RECS sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GETSCRMASK %' (left right bottom top])
-
-(IRIS.GETVALUATOR
-  [LAMBDA (v sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if v
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 80 sppStream)
-                  (IRIS.SENDS v sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECL sppStream))
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.GETVALUATOR %' (v])
-
-(IRIS.GETVIEWPORT
-  [LAMBDA (left right bottom top sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND left right bottom top)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 81 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET left (IRIS.RECS sppStream))
-             (SET right (IRIS.RECS sppStream))
-             (SET bottom (IRIS.RECS sppStream))
-             (SET top (IRIS.RECS sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GETVIEWPORT %' (left right bottom top])
-
-(IRIS.GETWRITEMASK
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 82 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.XGINIT
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 83 sppStream])
-
-(IRIS.XGRESET
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 84 sppStream])
-
-(IRIS.GRGBCOLOR
-  [LAMBDA (red green blue sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND red green blue)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 85 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET red (IRIS.RECS sppStream))
-             (SET green (IRIS.RECS sppStream))
-             (SET blue (IRIS.RECS sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GRGBCOLOR %' (red green blue])
-
-(IRIS.GRGBCURSOR
-  [LAMBDA (index red green blue redm greenm blum b sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND index red green blue redm greenm blum b)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 86 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET index (IRIS.RECS sppStream))
-             (SET red (IRIS.RECS sppStream))
-             (SET green (IRIS.RECS sppStream))
-             (SET blue (IRIS.RECS sppStream))
-             (SET redm (IRIS.RECS sppStream))
-             (SET greenm (IRIS.RECS sppStream))
-             (SET blum (IRIS.RECS sppStream))
-             (SET b (IRIS.RECO sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GRGBCURSOR %' (index red green blue redm greenm blum b])
-
-(IRIS.GRGBMASK
-  [LAMBDA (redm greenm blum sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND redm greenm blum)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 87 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET redm (IRIS.RECS sppStream))
-             (SET greenm (IRIS.RECS sppStream))
-             (SET blum (IRIS.RECS sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GRGBMASK %' (redm greenm blum])
-
-(IRIS.ISOBJ
-  [LAMBDA (obj sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if obj
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 89 sppStream)
-                  (IRIS.SENDL obj sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECO sppStream))
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.ISOBJ %' (obj])
-
-(IRIS.ISTAG
-  [LAMBDA (t sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if t
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 90 sppStream)
-                  (IRIS.SENDL t sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECO sppStream))
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.ISTAG %' (t])
-
-(IRIS.LINEWIDTH
-  [LAMBDA (n sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if n
-        then (IRIS.GCMD 92 sppStream)
-             (IRIS.SENDS n sppStream)
-      else (IRIS\ERROR %'IRIS.LINEWIDTH %' (n])
-
-(IRIS.LOADMATRIX
-  [LAMBDA (m sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if m
-        then (IRIS.GCMD 93 sppStream)
-             (IRIS.SENDFS m 16 sppStream)
-      else (IRIS\ERROR %'IRIS.LOADMATRIX %' (m])
-
-(IRIS.LOOKAT
-  [LAMBDA (vx vy vz px py pz twist sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND vx vy vz px py pz twist)
-        then (IRIS.GCMD 94 sppStream)
-             (IRIS.SENDF vx sppStream)
-             (IRIS.SENDF vy sppStream)
-             (IRIS.SENDF vz sppStream)
-             (IRIS.SENDF px sppStream)
-             (IRIS.SENDF py sppStream)
-             (IRIS.SENDF pz sppStream)
-             (IRIS.SENDS twist sppStream)
-      else (IRIS\ERROR %'IRIS.LOOKAT %' (vx vy vz px py pz twist])
-
-(IRIS.LSBACKUP
-  [LAMBDA (b sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if b
-        then (IRIS.GCMD 95 sppStream)
-             (IRIS.SENDO b sppStream)
-      else (IRIS\ERROR %'IRIS.LSBACKUP %' (b])
-
-(IRIS.MAKEOBJ
-  [LAMBDA (obj sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if obj
-        then (IRIS.GCMD 96 sppStream)
-             (IRIS.SENDL obj sppStream)
-      else (IRIS\ERROR %'IRIS.MAKEOBJ %' (obj])
-
-(IRIS.MAKETAG
-  [LAMBDA (t sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if t
-        then (IRIS.GCMD 97 sppStream)
-             (IRIS.SENDL t sppStream)
-      else (IRIS\ERROR %'IRIS.MAKETAG %' (t])
-
-(IRIS.MAPCOLOR
-  [LAMBDA (color red green blue sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND color red green blue)
-        then (IRIS.GCMD 98 sppStream)
-             (IRIS.SENDS color sppStream)
-             (IRIS.SENDS red sppStream)
-             (IRIS.SENDS green sppStream)
-             (IRIS.SENDS blue sppStream)
-      else (IRIS\ERROR %'IRIS.MAPCOLOR %' (color red green blue])
-
-(IRIS.MAPW
-  [LAMBDA (vobj sx sy wx1 wy1 wz1 wx2 wy2 wz2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND vobj sx sy wx1 wy1 wz1 wx2 wy2 wz2)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 99 sppStream)
-             (IRIS.SENDL vobj sppStream)
-             (IRIS.SENDS sx sppStream)
-             (IRIS.SENDS sy sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET wx1 (IRIS.RECF sppStream))
-             (SET wy1 (IRIS.RECF sppStream))
-             (SET wz1 (IRIS.RECF sppStream))
-             (SET wx2 (IRIS.RECF sppStream))
-             (SET wy2 (IRIS.RECF sppStream))
-             (SET wz2 (IRIS.RECF sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.MAPW %' (vobj sx sy wx1 wy1 wz1 wx2 wy2 wz2])
-
-(IRIS.MAPW2
-  [LAMBDA (vobj sx sy wx wy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND vobj sx sy wx wy)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 100 sppStream)
-             (IRIS.SENDL vobj sppStream)
-             (IRIS.SENDS sx sppStream)
-             (IRIS.SENDS sy sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET wx (IRIS.RECF sppStream))
-             (SET wy (IRIS.RECF sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.MAPW2 %' (vobj sx sy wx wy])
-
-(IRIS.MOVE
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 102 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF z sppStream)
-      else (IRIS\ERROR %'IRIS.MOVE %' (x y z])
-
-(IRIS.MOVE2
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 103 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-      else (IRIS\ERROR %'IRIS.MOVE2 %' (x y])
-
-(IRIS.MOVE2I
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 104 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-      else (IRIS\ERROR %'IRIS.MOVE2I %' (x y])
-
-(IRIS.MOVEI
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 105 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL z sppStream)
-      else (IRIS\ERROR %'IRIS.MOVEI %' (x y z])
-
-(IRIS.MULTIMAP
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 106 sppStream])
-
-(IRIS.MULTMATRIX
-  [LAMBDA (m sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if m
-        then (IRIS.GCMD 107 sppStream)
-             (IRIS.SENDFS m 16 sppStream)
-      else (IRIS\ERROR %'IRIS.MULTMATRIX %' (m])
-
-(IRIS.NOISE
-  [LAMBDA (v delta sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND v delta)
-        then (IRIS.GCMD 108 sppStream)
-             (IRIS.SENDS v sppStream)
-             (IRIS.SENDS delta sppStream)
-      else (IRIS\ERROR %'IRIS.NOISE %' (v delta])
-
-(IRIS.ONEMAP
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 111 sppStream])
-
-(IRIS.ORTHO
-  [LAMBDA (left right bottom top near far sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND left right bottom top near far)
-        then (IRIS.GCMD 112 sppStream)
-             (IRIS.SENDF left sppStream)
-             (IRIS.SENDF right sppStream)
-             (IRIS.SENDF bottom sppStream)
-             (IRIS.SENDF top sppStream)
-             (IRIS.SENDF near sppStream)
-             (IRIS.SENDF far sppStream)
-      else (IRIS\ERROR %'IRIS.ORTHO %' (left right bottom top near far])
-
-(IRIS.ORTHO2
-  [LAMBDA (left right bottom top sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND left right bottom top)
-        then (IRIS.GCMD 113 sppStream)
-             (IRIS.SENDF left sppStream)
-             (IRIS.SENDF right sppStream)
-             (IRIS.SENDF bottom sppStream)
-             (IRIS.SENDF top sppStream)
-      else (IRIS\ERROR %'IRIS.ORTHO2 %' (left right bottom top])
-
-(IRIS.PERSPECTIVE
-  [LAMBDA (fovy aspect near far sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND fovy aspect near far)
-        then (IRIS.GCMD 114 sppStream)
-             (IRIS.SENDS fovy sppStream)
-             (IRIS.SENDF aspect sppStream)
-             (IRIS.SENDF near sppStream)
-             (IRIS.SENDF far sppStream)
-      else (IRIS\ERROR %'IRIS.PERSPECTIVE %' (fovy aspect near far])
-
-(IRIS.PICK
-  [LAMBDA (numNames buffer sppStream)                        (* LeL, " 9-Sep-85 04:19")
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND numNames buffer)
-        then (IRIS.GCMD 115 sppStream)
-             (IRIS.SENDSS buffer 0 sppStream)
-             (IRIS.SENDL numNames sppStream)
-      else (IRIS\ERROR %'IRIS.PICK %' (numNames buffer])
-
-(IRIS.PICKSIZE
-  [LAMBDA (deltax deltay sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND deltax deltay)
-        then (IRIS.GCMD 116 sppStream)
-             (IRIS.SENDS deltax sppStream)
-             (IRIS.SENDS deltay sppStream)
-      else (IRIS\ERROR %'IRIS.PICKSIZE %' (deltax deltay])
-
-(IRIS.PNT
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 117 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF z sppStream)
-      else (IRIS\ERROR %'IRIS.PNT %' (x y z])
-
-(IRIS.PNT2
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 118 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-      else (IRIS\ERROR %'IRIS.PNT2 %' (x y])
-
-(IRIS.PNT2I
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 119 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-      else (IRIS\ERROR %'IRIS.PNT2I %' (x y])
-
-(IRIS.PNTI
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 120 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL z sppStream)
-      else (IRIS\ERROR %'IRIS.PNTI %' (x y z])
-
-(IRIS.POLARVIEW
-  [LAMBDA (dist azim inc twist sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dist azim inc twist)
-        then (IRIS.GCMD 121 sppStream)
-             (IRIS.SENDF dist sppStream)
-             (IRIS.SENDS azim sppStream)
-             (IRIS.SENDS inc sppStream)
-             (IRIS.SENDS twist sppStream)
-      else (IRIS\ERROR %'IRIS.POLARVIEW %' (dist azim inc twist])
-
-(IRIS.POLF
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 122 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDFS parray (TIMES 3 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLF %' (n parray])
-
-(IRIS.POLF2
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 123 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDFS parray (TIMES 2 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLF2 %' (n parray])
-
-(IRIS.POLF2I
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 124 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDLS parray (TIMES 2 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLF2I %' (n parray])
-
-(IRIS.POLFI
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 125 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDLS parray (TIMES 3 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLFI %' (n parray])
-
-(IRIS.POLY
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 126 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDFS parray (TIMES 3 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLY %' (n parray])
-
-(IRIS.POLY2
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 127 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDFS parray (TIMES 2 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLY2 %' (n parray])
-
-(IRIS.POLY2I
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 128 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDLS parray (TIMES 2 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLY2I %' (n parray])
-
-(IRIS.POLYI
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 129 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDLS parray (TIMES 3 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLYI %' (n parray])
-
-(IRIS.POPATTRIBUTES
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 130 sppStream])
-
-(IRIS.POPMATRIX
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 131 sppStream])
-
-(IRIS.POPVIEWPORT
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 132 sppStream])
-
-(IRIS.PUSHATTRIBUTES
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 133 sppStream])
-
-(IRIS.PUSHMATRIX
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 134 sppStream])
-
-(IRIS.PUSHVIEWPORT
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 135 sppStream])
-
-(IRIS.QENTER
-  [LAMBDA (qtype val sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND qtype val)
-        then (IRIS.GCMD 137 sppStream)
-             (IRIS.SENDS qtype sppStream)
-             (IRIS.SENDS val sppStream)
-      else (IRIS\ERROR %'IRIS.QENTER %' (qtype val])
-
-(IRIS.QREAD
-  [LAMBDA (data sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if data
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 139 sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECL sppStream))
-                  (SET data (IRIS.RECS sppStream))
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.QREAD %' (data])
-
-(IRIS.QRESET
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 140 sppStream])
-
-(IRIS.QTEST
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 141 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.READPIXELS
-  [LAMBDA (n colors sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n colors)
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 143 sppStream)
-                  (IRIS.SENDS n sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECL sppStream))
-                  (IRIS.RECSS colors sppStream)
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.READPIXELS %' (n colors])
-
-(IRIS.READRGB
-  [LAMBDA (n red green blue sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n red green blue)
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 144 sppStream)
-                  (IRIS.SENDS n sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECL sppStream))
-                  (IRIS.RECBS red sppStream)
-                  (IRIS.RECBS green sppStream)
-                  (IRIS.RECBS blue sppStream)
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.READRGB %' (n red green blue])
-
-(IRIS.RECT
-  [LAMBDA (x1 y1 x2 y2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x1 y1 x2 y2)
-        then (IRIS.GCMD 145 sppStream)
-             (IRIS.SENDF x1 sppStream)
-             (IRIS.SENDF y1 sppStream)
-             (IRIS.SENDF x2 sppStream)
-             (IRIS.SENDF y2 sppStream)
-      else (IRIS\ERROR %'IRIS.RECT %' (x1 y1 x2 y2])
-
-(IRIS.RECTF
-  [LAMBDA (x1 y1 x2 y2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x1 y1 x2 y2)
-        then (IRIS.GCMD 146 sppStream)
-             (IRIS.SENDF x1 sppStream)
-             (IRIS.SENDF y1 sppStream)
-             (IRIS.SENDF x2 sppStream)
-             (IRIS.SENDF y2 sppStream)
-      else (IRIS\ERROR %'IRIS.RECTF %' (x1 y1 x2 y2])
-
-(IRIS.RECTFI
-  [LAMBDA (x1 y1 x2 y2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x1 y1 x2 y2)
-        then (IRIS.GCMD 147 sppStream)
-             (IRIS.SENDL x1 sppStream)
-             (IRIS.SENDL y1 sppStream)
-             (IRIS.SENDL x2 sppStream)
-             (IRIS.SENDL y2 sppStream)
-      else (IRIS\ERROR %'IRIS.RECTFI %' (x1 y1 x2 y2])
-
-(IRIS.RECTI
-  [LAMBDA (x1 y1 x2 y2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x1 y1 x2 y2)
-        then (IRIS.GCMD 148 sppStream)
-             (IRIS.SENDL x1 sppStream)
-             (IRIS.SENDL y1 sppStream)
-             (IRIS.SENDL x2 sppStream)
-             (IRIS.SENDL y2 sppStream)
-      else (IRIS\ERROR %'IRIS.RECTI %' (x1 y1 x2 y2])
-
-(IRIS.RESETLS
-  [LAMBDA (b sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if b
-        then (IRIS.GCMD 150 sppStream)
-             (IRIS.SENDO b sppStream)
-      else (IRIS\ERROR %'IRIS.RESETLS %' (b])
-
-(IRIS.RGBCOLOR
-  [LAMBDA (red green blue sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND red green blue)
-        then (IRIS.GCMD 151 sppStream)
-             (IRIS.SENDS red sppStream)
-             (IRIS.SENDS green sppStream)
-             (IRIS.SENDS blue sppStream)
-      else (IRIS\ERROR %'IRIS.RGBCOLOR %' (red green blue])
-
-(IRIS.RGBCURSOR
-  [LAMBDA (index red green blue redm greenm blum sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND index red green blue redm greenm blum)
-        then (IRIS.GCMD 152 sppStream)
-             (IRIS.SENDS index sppStream)
-             (IRIS.SENDS red sppStream)
-             (IRIS.SENDS green sppStream)
-             (IRIS.SENDS blue sppStream)
-             (IRIS.SENDS redm sppStream)
-             (IRIS.SENDS greenm sppStream)
-             (IRIS.SENDS blum sppStream)
-      else (IRIS\ERROR %'IRIS.RGBCURSOR %' (index red green blue redm greenm blum])
-
-(IRIS.RGBMODE
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 153 sppStream])
-
-(IRIS.RGBWRITEMASK
-  [LAMBDA (red green blue sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND red green blue)
-        then (IRIS.GCMD 154 sppStream)
-             (IRIS.SENDS red sppStream)
-             (IRIS.SENDS green sppStream)
-             (IRIS.SENDS blue sppStream)
-      else (IRIS\ERROR %'IRIS.RGBWRITEMASK %' (red green blue])
-
-(IRIS.ROTATE
-  [LAMBDA (a axis sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND a axis)
-        then (IRIS.GCMD 155 sppStream)
-             (IRIS.SENDS a sppStream)
-             (IRIS.SENDB axis sppStream)
-      else (IRIS\ERROR %'IRIS.ROTATE %' (a axis])
-
-(IRIS.SCALE
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 156 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF z sppStream)
-      else (IRIS\ERROR %'IRIS.SCALE %' (x y z])
-
-(IRIS.SCRMASK
-  [LAMBDA (left right bottom top sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND left right bottom top)
-        then (IRIS.GCMD 158 sppStream)
-             (IRIS.SENDS left sppStream)
-             (IRIS.SENDS right sppStream)
-             (IRIS.SENDS bottom sppStream)
-             (IRIS.SENDS top sppStream)
-      else (IRIS\ERROR %'IRIS.SCRMASK %' (left right bottom top])
-
-(IRIS.SELECT
-  [LAMBDA (numnames buffer sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND numnames buffer)
-        then (IRIS.GCMD 159 sppStream)
-             (IRIS.SENDSS numnames 0 sppStream)
-             (IRIS.SENDL buffer sppStream)
-      else (IRIS\ERROR %'IRIS.SELECT %' (numnames buffer])
-
-(IRIS.SETBUTTON
-  [LAMBDA (b value sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND b value)
-        then (IRIS.GCMD 160 sppStream)
-             (IRIS.SENDS b sppStream)
-             (IRIS.SENDO value sppStream)
-      else (IRIS\ERROR %'IRIS.SETBUTTON %' (b value])
-
-(IRIS.SETCURSOR
-  [LAMBDA (index color wtm sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND index color wtm)
-        then (IRIS.GCMD 161 sppStream)
-             (IRIS.SENDS index sppStream)
-             (IRIS.SENDS color sppStream)
-             (IRIS.SENDS wtm sppStream)
-      else (IRIS\ERROR %'IRIS.SETCURSOR %' (index color wtm])
-
-(IRIS.SETDEPTH
-  [LAMBDA (near far sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND near far)
-        then (IRIS.GCMD 162 sppStream)
-             (IRIS.SENDS near sppStream)
-             (IRIS.SENDS far sppStream)
-      else (IRIS\ERROR %'IRIS.SETDEPTH %' (near far])
-
-(IRIS.SETLINESTYLE
-  [LAMBDA (index sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if index
-        then (IRIS.GCMD 163 sppStream)
-             (IRIS.SENDS index sppStream)
-      else (IRIS\ERROR %'IRIS.SETLINESTYLE %' (index])
-
-(IRIS.SETMAP
-  [LAMBDA (mapnum sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if mapnum
-        then (IRIS.GCMD 164 sppStream)
-             (IRIS.SENDS mapnum sppStream)
-      else (IRIS\ERROR %'IRIS.SETMAP %' (mapnum])
-
-(IRIS.SETVALUATOR
-  [LAMBDA (v init min max sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND v init min max)
-        then (IRIS.GCMD 167 sppStream)
-             (IRIS.SENDS v sppStream)
-             (IRIS.SENDS init sppStream)
-             (IRIS.SENDS min sppStream)
-             (IRIS.SENDS max sppStream)
-      else (IRIS\ERROR %'IRIS.SETVALUATOR %' (v init min max])
-
-(IRIS.SINGLEBUFFER
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 168 sppStream])
-
-(IRIS.STRWIDTH
-  [LAMBDA (str sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if str
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 169 sppStream)
-                  (IRIS.SENDC str sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECL sppStream))
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.STRWIDTH %' (str])
-
-(IRIS.SWAPBUFFERS
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 170 sppStream])
-
-(IRIS.SWAPINTERVAL
-  [LAMBDA (i sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if i
-        then (IRIS.GCMD 171 sppStream)
-             (IRIS.SENDS i sppStream)
-      else (IRIS\ERROR %'IRIS.SWAPINTERVAL %' (i])
-
-(IRIS.GSYNC
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 172 sppStream])
-
-(IRIS.TIE
-  [LAMBDA (b v1 v2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND b v1 v2)
-        then (IRIS.GCMD 173 sppStream)
-             (IRIS.SENDS b sppStream)
-             (IRIS.SENDS v1 sppStream)
-             (IRIS.SENDS v2 sppStream)
-      else (IRIS\ERROR %'IRIS.TIE %' (b v1 v2])
-
-(IRIS.TRANSLATE
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 175 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF z sppStream)
-      else (IRIS\ERROR %'IRIS.TRANSLATE %' (x y z])
-
-(IRIS.VIEWPORT
-  [LAMBDA (left right bottom top sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND left right bottom top)
-        then (IRIS.GCMD 179 sppStream)
-             (IRIS.SENDS left sppStream)
-             (IRIS.SENDS right sppStream)
-             (IRIS.SENDS bottom sppStream)
-             (IRIS.SENDS top sppStream)
-      else (IRIS\ERROR %'IRIS.VIEWPORT %' (left right bottom top])
-
-(IRIS.WINDOW
-  [LAMBDA (left right bottom top near far sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND left right bottom top near far)
-        then (IRIS.GCMD 180 sppStream)
-             (IRIS.SENDF left sppStream)
-             (IRIS.SENDF right sppStream)
-             (IRIS.SENDF bottom sppStream)
-             (IRIS.SENDF top sppStream)
-             (IRIS.SENDF near sppStream)
-             (IRIS.SENDF far sppStream)
-      else (IRIS\ERROR %'IRIS.WINDOW %' (left right bottom top near far])
-
-(IRIS.WRITEMASK
-  [LAMBDA (wtm sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if wtm
-        then (IRIS.GCMD 181 sppStream)
-             (IRIS.SENDS wtm sppStream)
-      else (IRIS\ERROR %'IRIS.WRITEMASK %' (wtm])
-
-(IRIS.WRITEPIXELS
-  [LAMBDA (n colors sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n colors)
-        then (IRIS.GCMD 182 sppStream)
-             (IRIS.SENDS n sppStream)
-             (IRIS.SENDSS colors n sppStream)
-      else (IRIS\ERROR %'IRIS.WRITEPIXELS %' (n colors])
-
-(IRIS.WRITERGB
-  [LAMBDA (n red green blue sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n red green blue)
-        then (IRIS.GCMD 183 sppStream)
-             (IRIS.SENDS n sppStream)
-             (IRIS.SENDBS red n sppStream)
-             (IRIS.SENDBS green n sppStream)
-             (IRIS.SENDBS blue n sppStream)
-      else (IRIS\ERROR %'IRIS.WRITERGB %' (n red green blue])
-
-(IRIS.TPON
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 184 sppStream])
-
-(IRIS.TPOFF
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 185 sppStream])
-
-(IRIS.TEXTWRITEMASK
-  [LAMBDA (tmask sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if tmask
-        then (IRIS.GCMD 187 sppStream)
-             (IRIS.SENDS tmask sppStream)
-      else (IRIS\ERROR %'IRIS.TEXTWRITEMASK %' (tmask])
-
-(IRIS.XGEXIT
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 188 sppStream])
-
-(IRIS.CLKON
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 189 sppStream])
-
-(IRIS.CLKOFF
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 190 sppStream])
-
-(IRIS.LAMPON
-  [LAMBDA (lamps sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if lamps
-        then (IRIS.GCMD 191 sppStream)
-             (IRIS.SENDB lamps sppStream)
-      else (IRIS\ERROR %'IRIS.LAMPON %' (lamps])
-
-(IRIS.LAMPOFF
-  [LAMBDA (lamps sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if lamps
-        then (IRIS.GCMD 192 sppStream)
-             (IRIS.SENDB lamps sppStream)
-      else (IRIS\ERROR %'IRIS.LAMPOFF %' (lamps])
-
-(IRIS.SETBELL
-  [LAMBDA (arg sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if arg
-        then (IRIS.GCMD 193 sppStream)
-             (IRIS.SENDB arg sppStream)
-      else (IRIS\ERROR %'IRIS.SETBELL %' (arg])
-
-(IRIS.RINGBELL
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 194 sppStream])
-
-(IRIS.TADELAY
-  [LAMBDA (arg1 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if arg1
-        then (IRIS.GCMD 195 sppStream)
-             (IRIS.SENDS arg1 sppStream)
-      else (IRIS\ERROR %'IRIS.TADELAY %' (arg1])
-
-(IRIS.ARCFS
-  [LAMBDA (x y radius startang endang sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius startang endang)
-        then (IRIS.GCMD 196 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS radius sppStream)
-             (IRIS.SENDS startang sppStream)
-             (IRIS.SENDS endang sppStream)
-      else (IRIS\ERROR %'IRIS.ARCFS %' (x y radius startang endang])
-
-(IRIS.ARCS
-  [LAMBDA (x y radius startang endang sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius startang endang)
-        then (IRIS.GCMD 197 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS radius sppStream)
-             (IRIS.SENDS startang sppStream)
-             (IRIS.SENDS endang sppStream)
-      else (IRIS\ERROR %'IRIS.ARCS %' (x y radius startang endang])
-
-(IRIS.BBOX2S
-  [LAMBDA (xmin ymin x1 y1 x2 y2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND xmin ymin x1 y1 x2 y2)
-        then (IRIS.GCMD 199 sppStream)
-             (IRIS.SENDS xmin sppStream)
-             (IRIS.SENDS ymin sppStream)
-             (IRIS.SENDS x1 sppStream)
-             (IRIS.SENDS y1 sppStream)
-             (IRIS.SENDS x2 sppStream)
-             (IRIS.SENDS y2 sppStream)
-      else (IRIS\ERROR %'IRIS.BBOX2S %' (xmin ymin x1 y1 x2 y2])
-
-(IRIS.BLANKSCREEN
-  [LAMBDA (bool sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if bool
-        then (IRIS.GCMD 200 sppStream)
-             (IRIS.SENDO bool sppStream)
-      else (IRIS\ERROR %'IRIS.BLANKSCREEN %' (bool])
-
-(IRIS.BLKQREAD
-  [LAMBDA (data n sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND data n)
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 202 sppStream)
-                  (IRIS.SENDS n sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECL sppStream))
-                  (IRIS.RECSS data sppStream)
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.BLKQREAD %' (data n])
-
-(IRIS.GETMCOLOR
-  [LAMBDA (color r g b sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND color r g b)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 203 sppStream)
-             (IRIS.SENDS color sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET r (IRIS.RECS sppStream))
-             (SET g (IRIS.RECS sppStream))
-             (SET b (IRIS.RECS sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GETMCOLOR %' (color r g b])
-
-(IRIS.CALLFUNC
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 204 sppStream])
-
-(IRIS.CHUNKSIZE
-  [LAMBDA (chunk sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if chunk
-        then (IRIS.GCMD 205 sppStream)
-             (IRIS.SENDL chunk sppStream)
-      else (IRIS\ERROR %'IRIS.CHUNKSIZE %' (chunk])
-
-(IRIS.CIRCFS
-  [LAMBDA (x y radius sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius)
-        then (IRIS.GCMD 206 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS radius sppStream)
-      else (IRIS\ERROR %'IRIS.CIRCFS %' (x y radius])
-
-(IRIS.CIRCS
-  [LAMBDA (x y radius sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y radius)
-        then (IRIS.GCMD 207 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS radius sppStream)
-      else (IRIS\ERROR %'IRIS.CIRCS %' (x y radius])
-
-(IRIS.CMOV2S
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 208 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-      else (IRIS\ERROR %'IRIS.CMOV2S %' (x y])
-
-(IRIS.CMOVS
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 209 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS z sppStream)
-      else (IRIS\ERROR %'IRIS.CMOVS %' (x y z])
-
-(IRIS.COMPACTIFY
-  [LAMBDA (obj sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if obj
-        then (IRIS.GCMD 210 sppStream)
-             (IRIS.SENDL obj sppStream)
-      else (IRIS\ERROR %'IRIS.COMPACTIFY %' (obj])
-
-(IRIS.QDEVICE
-  [LAMBDA (v sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if v
-        then (IRIS.GCMD 211 sppStream)
-             (IRIS.SENDS v sppStream)
-      else (IRIS\ERROR %'IRIS.QDEVICE %' (v])
-
-(IRIS.UNQDEVICE
-  [LAMBDA (v sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if v
-        then (IRIS.GCMD 212 sppStream)
-             (IRIS.SENDS v sppStream)
-      else (IRIS\ERROR %'IRIS.UNQDEVICE %' (v])
-
-(IRIS.CURVEBASIS
-  [LAMBDA (basisid sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if basisid
-        then (IRIS.GCMD 213 sppStream)
-             (IRIS.SENDS basisid sppStream)
-      else (IRIS\ERROR %'IRIS.CURVEBASIS %' (basisid])
-
-(IRIS.CURVEPRECISION
-  [LAMBDA (nsegments sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if nsegments
-        then (IRIS.GCMD 214 sppStream)
-             (IRIS.SENDS nsegments sppStream)
-      else (IRIS\ERROR %'IRIS.CURVEPRECISION %' (nsegments])
-
-(IRIS.CRV
-  [LAMBDA (geom sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if geom
-        then (IRIS.GCMD 215 sppStream)
-             (IRIS.SENDFS geom (TIMES 4 3)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.CRV %' (geom])
-
-(IRIS.GETTP
-  [LAMBDA (left right bottom top sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND left right bottom top)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 216 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET left (IRIS.RECS sppStream))
-             (SET right (IRIS.RECS sppStream))
-             (SET bottom (IRIS.RECS sppStream))
-             (SET top (IRIS.RECS sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GETTP %' (left right bottom top])
-
-(IRIS.GBEGIN
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 217 sppStream])
-
-(IRIS.TEXTINIT
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 218 sppStream])
-
-(IRIS.CRVN
-  [LAMBDA (n geom sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n geom)
-        then (IRIS.GCMD 219 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDFS geom (TIMES 3 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.CRVN %' (n geom])
-
-(IRIS.DEFBASIS
-  [LAMBDA (id matrix sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND id matrix)
-        then (IRIS.GCMD 220 sppStream)
-             (IRIS.SENDS id sppStream)
-             (IRIS.SENDFS matrix 16 sppStream)
-      else (IRIS\ERROR %'IRIS.DEFBASIS %' (id matrix])
-
-(IRIS.DELTAG
-  [LAMBDA (t sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if t
-        then (IRIS.GCMD 221 sppStream)
-             (IRIS.SENDL t sppStream)
-      else (IRIS\ERROR %'IRIS.DELTAG %' (t])
-
-(IRIS.DEPTHCUE
-  [LAMBDA (mode sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if mode
-        then (IRIS.GCMD 222 sppStream)
-             (IRIS.SENDO mode sppStream)
-      else (IRIS\ERROR %'IRIS.DEPTHCUE %' (mode])
-
-(IRIS.DRAW2S
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 223 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-      else (IRIS\ERROR %'IRIS.DRAW2S %' (x y])
-
-(IRIS.DRAWS
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 224 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS z sppStream)
-      else (IRIS\ERROR %'IRIS.DRAWS %' (x y z])
-
-(IRIS.ENDFEEDBACK
-  [LAMBDA (buffer sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if buffer
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 225 sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECL sppStream))
-                  (IRIS.RECSS buffer sppStream)
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.ENDFEEDBACK %' (buffer])
-
-(IRIS.FEEDBACK
-  [LAMBDA (buffer size sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND buffer size)
-        then (IRIS.GCMD 226 sppStream)
-             (IRIS.SENDSS buffer 0 sppStream)
-             (IRIS.SENDL size sppStream)
-      else (IRIS\ERROR %'IRIS.FEEDBACK %' (buffer size])
-
-(IRIS.GETCPOS
-  [LAMBDA (ix iy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND ix iy)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 227 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET ix (IRIS.RECS sppStream))
-             (SET iy (IRIS.RECS sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GETCPOS %' (ix iy])
-
-(IRIS.GETDCM
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 228 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECO sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETGPOS
-  [LAMBDA (x y z w sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z w)
-        then (IRIS.ECHOFF sppStream)
-             (IRIS.GCMD 229 sppStream)
-             (IRIS.FLUSHG sppStream)
-             (SET x (IRIS.RECF sppStream))
-             (SET y (IRIS.RECF sppStream))
-             (SET z (IRIS.RECF sppStream))
-             (SET w (IRIS.RECF sppStream))
-             (IRIS.RECCR sppStream)
-             (IRIS.ECHOON sppStream)
-      else (IRIS\ERROR %'IRIS.GETGPOS %' (x y z w])
-
-(IRIS.GETLSREPEAT
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 230 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETMEM
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 231 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETMONITOR
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 232 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETOPENOBJ
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 233 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GETZBUFFER
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 234 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECO sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.GEWRITE
-  [LAMBDA (arg1 arg2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND arg1 arg2)
-        then (IRIS.GCMD 235 sppStream)
-             (IRIS.SENDSS arg1 arg2 sppStream)
-             (IRIS.SENDL arg2 sppStream)
-      else (IRIS\ERROR %'IRIS.GEWRITE %' (arg1 arg2])
-
-(IRIS.INITNAMES
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 236 sppStream])
-
-(IRIS.LOADNAME
-  [LAMBDA (name sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if name
-        then (IRIS.GCMD 237 sppStream)
-             (IRIS.SENDS name sppStream)
-      else (IRIS\ERROR %'IRIS.LOADNAME %' (name])
-
-(IRIS.LSREPEAT
-  [LAMBDA (factor sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if factor
-        then (IRIS.GCMD 238 sppStream)
-             (IRIS.SENDL factor sppStream)
-      else (IRIS\ERROR %'IRIS.LSREPEAT %' (factor])
-
-(IRIS.MOVE2S
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 239 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-      else (IRIS\ERROR %'IRIS.MOVE2S %' (x y])
-
-(IRIS.MOVES
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 240 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS z sppStream)
-      else (IRIS\ERROR %'IRIS.MOVES %' (x y z])
-
-(IRIS.NEWTAG
-  [LAMBDA (newtag oldtag offset sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND newtag oldtag offset)
-        then (IRIS.GCMD 241 sppStream)
-             (IRIS.SENDL newtag sppStream)
-             (IRIS.SENDL oldtag sppStream)
-             (IRIS.SENDL offset sppStream)
-      else (IRIS\ERROR %'IRIS.NEWTAG %' (newtag oldtag offset])
-
-(IRIS.PASSTHROUGH
-  [LAMBDA (token sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if token
-        then (IRIS.GCMD 242 sppStream)
-             (IRIS.SENDS token sppStream)
-      else (IRIS\ERROR %'IRIS.PASSTHROUGH %' (token])
-
-(IRIS.PATCHBASIS
-  [LAMBDA (uid vid sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND uid vid)
-        then (IRIS.GCMD 243 sppStream)
-             (IRIS.SENDL uid sppStream)
-             (IRIS.SENDL vid sppStream)
-      else (IRIS\ERROR %'IRIS.PATCHBASIS %' (uid vid])
-
-(IRIS.PATCHPRECISION
-  [LAMBDA (usegments vsegments sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND usegments vsegments)
-        then (IRIS.GCMD 244 sppStream)
-             (IRIS.SENDL usegments sppStream)
-             (IRIS.SENDL vsegments sppStream)
-      else (IRIS\ERROR %'IRIS.PATCHPRECISION %' (usegments vsegments])
-
-(IRIS.PATCH
-  [LAMBDA (geomx geomy geomz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND geomx geomy geomz)
-        then (IRIS.GCMD 245 sppStream)
-             (IRIS.SENDFS geomx 16 sppStream)
-             (IRIS.SENDFS geomy 16 sppStream)
-             (IRIS.SENDFS geomz 16 sppStream)
-      else (IRIS\ERROR %'IRIS.PATCH %' (geomx geomy geomz])
-
-(IRIS.PCLOS
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 246 sppStream])
-
-(IRIS.PDR
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 247 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF z sppStream)
-      else (IRIS\ERROR %'IRIS.PDR %' (x y z])
-
-(IRIS.PDR2
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 248 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-      else (IRIS\ERROR %'IRIS.PDR2 %' (x y])
-
-(IRIS.PDRI
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 249 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL z sppStream)
-      else (IRIS\ERROR %'IRIS.PDRI %' (x y z])
-
-(IRIS.PDR2I
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 250 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-      else (IRIS\ERROR %'IRIS.PDR2I %' (x y])
-
-(IRIS.PDRS
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 251 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS z sppStream)
-      else (IRIS\ERROR %'IRIS.PDRS %' (x y z])
-
-(IRIS.PDR2S
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 252 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-      else (IRIS\ERROR %'IRIS.PDR2S %' (x y])
-
-(IRIS.POLF2S
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 253 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDSS parray (TIMES 2 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLF2S %' (n parray])
-
-(IRIS.POLFS
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 254 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDSS parray (TIMES 3 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLFS %' (n parray])
-
-(IRIS.POLY2S
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 255 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDSS parray (TIMES 2 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLY2S %' (n parray])
-
-(IRIS.POLYS
-  [LAMBDA (n parray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray)
-        then (IRIS.GCMD 256 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDSS parray (TIMES 3 n)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.POLYS %' (n parray])
-
-(IRIS.PMV
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 257 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF z sppStream)
-      else (IRIS\ERROR %'IRIS.PMV %' (x y z])
-
-(IRIS.PMV2
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 258 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-      else (IRIS\ERROR %'IRIS.PMV2 %' (x y])
-
-(IRIS.PMVI
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 259 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL z sppStream)
-      else (IRIS\ERROR %'IRIS.PMVI %' (x y z])
-
-(IRIS.PMV2I
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 260 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-      else (IRIS\ERROR %'IRIS.PMV2I %' (x y])
-
-(IRIS.PMVS
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 261 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS z sppStream)
-      else (IRIS\ERROR %'IRIS.PMVS %' (x y z])
-
-(IRIS.PMV2S
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 262 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-      else (IRIS\ERROR %'IRIS.PMV2S %' (x y])
-
-(IRIS.PNT2S
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 263 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-      else (IRIS\ERROR %'IRIS.PNT2S %' (x y])
-
-(IRIS.PNTS
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 264 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS z sppStream)
-      else (IRIS\ERROR %'IRIS.PNTS %' (x y z])
-
-(IRIS.POPNAME
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 265 sppStream])
-
-(IRIS.PUSHNAME
-  [LAMBDA (name sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if name
-        then (IRIS.GCMD 266 sppStream)
-             (IRIS.SENDS name sppStream)
-      else (IRIS\ERROR %'IRIS.PUSHNAME %' (name])
-
-(IRIS.RDR
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 267 sppStream)
-             (IRIS.SENDF dx sppStream)
-             (IRIS.SENDF dy sppStream)
-             (IRIS.SENDF dz sppStream)
-      else (IRIS\ERROR %'IRIS.RDR %' (dx dy dz])
-
-(IRIS.RDR2
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 268 sppStream)
-             (IRIS.SENDF dx sppStream)
-             (IRIS.SENDF dy sppStream)
-      else (IRIS\ERROR %'IRIS.RDR2 %' (dx dy])
-
-(IRIS.RDRI
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 269 sppStream)
-             (IRIS.SENDL dx sppStream)
-             (IRIS.SENDL dy sppStream)
-             (IRIS.SENDL dz sppStream)
-      else (IRIS\ERROR %'IRIS.RDRI %' (dx dy dz])
-
-(IRIS.RDR2I
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 270 sppStream)
-             (IRIS.SENDL dx sppStream)
-             (IRIS.SENDL dy sppStream)
-      else (IRIS\ERROR %'IRIS.RDR2I %' (dx dy])
-
-(IRIS.RDRS
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 271 sppStream)
-             (IRIS.SENDS dx sppStream)
-             (IRIS.SENDS dy sppStream)
-             (IRIS.SENDS dz sppStream)
-      else (IRIS\ERROR %'IRIS.RDRS %' (dx dy dz])
-
-(IRIS.RDR2S
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 272 sppStream)
-             (IRIS.SENDS dx sppStream)
-             (IRIS.SENDS dy sppStream)
-      else (IRIS\ERROR %'IRIS.RDR2S %' (dx dy])
-
-(IRIS.RECTCOPY
-  [LAMBDA (left right bottom top newx newy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND left right bottom top newx newy)
-        then (IRIS.GCMD 273 sppStream)
-             (IRIS.SENDS left sppStream)
-             (IRIS.SENDS right sppStream)
-             (IRIS.SENDS bottom sppStream)
-             (IRIS.SENDS top sppStream)
-             (IRIS.SENDS newx sppStream)
-             (IRIS.SENDS newy sppStream)
-      else (IRIS\ERROR %'IRIS.RECTCOPY %' (left right bottom top newx newy])
-
-(IRIS.RMV
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 274 sppStream)
-             (IRIS.SENDF dx sppStream)
-             (IRIS.SENDF dy sppStream)
-             (IRIS.SENDF dz sppStream)
-      else (IRIS\ERROR %'IRIS.RMV %' (dx dy dz])
-
-(IRIS.RMV2
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 275 sppStream)
-             (IRIS.SENDF dx sppStream)
-             (IRIS.SENDF dy sppStream)
-      else (IRIS\ERROR %'IRIS.RMV2 %' (dx dy])
-
-(IRIS.RMVI
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 276 sppStream)
-             (IRIS.SENDL dx sppStream)
-             (IRIS.SENDL dy sppStream)
-             (IRIS.SENDL dz sppStream)
-      else (IRIS\ERROR %'IRIS.RMVI %' (dx dy dz])
-
-(IRIS.RMV2I
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 277 sppStream)
-             (IRIS.SENDL dx sppStream)
-             (IRIS.SENDL dy sppStream)
-      else (IRIS\ERROR %'IRIS.RMV2I %' (dx dy])
-
-(IRIS.RMVS
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 278 sppStream)
-             (IRIS.SENDS dx sppStream)
-             (IRIS.SENDS dy sppStream)
-             (IRIS.SENDS dz sppStream)
-      else (IRIS\ERROR %'IRIS.RMVS %' (dx dy dz])
-
-(IRIS.RMV2S
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 279 sppStream)
-             (IRIS.SENDS dx sppStream)
-             (IRIS.SENDS dy sppStream)
-      else (IRIS\ERROR %'IRIS.RMV2S %' (dx dy])
-
-(IRIS.RPDR
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 280 sppStream)
-             (IRIS.SENDF dx sppStream)
-             (IRIS.SENDF dy sppStream)
-             (IRIS.SENDF dz sppStream)
-      else (IRIS\ERROR %'IRIS.RPDR %' (dx dy dz])
-
-(IRIS.RPDR2
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 281 sppStream)
-             (IRIS.SENDF dx sppStream)
-             (IRIS.SENDF dy sppStream)
-      else (IRIS\ERROR %'IRIS.RPDR2 %' (dx dy])
-
-(IRIS.RPDRI
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 282 sppStream)
-             (IRIS.SENDL dx sppStream)
-             (IRIS.SENDL dy sppStream)
-             (IRIS.SENDL dz sppStream)
-      else (IRIS\ERROR %'IRIS.RPDRI %' (dx dy dz])
-
-(IRIS.RPDR2I
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 283 sppStream)
-             (IRIS.SENDL dx sppStream)
-             (IRIS.SENDL dy sppStream)
-      else (IRIS\ERROR %'IRIS.RPDR2I %' (dx dy])
-
-(IRIS.RPDRS
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 284 sppStream)
-             (IRIS.SENDS dx sppStream)
-             (IRIS.SENDS dy sppStream)
-             (IRIS.SENDS dz sppStream)
-      else (IRIS\ERROR %'IRIS.RPDRS %' (dx dy dz])
-
-(IRIS.RPDR2S
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 285 sppStream)
-             (IRIS.SENDS dx sppStream)
-             (IRIS.SENDS dy sppStream)
-      else (IRIS\ERROR %'IRIS.RPDR2S %' (dx dy])
-
-(IRIS.RPMV
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 286 sppStream)
-             (IRIS.SENDF dx sppStream)
-             (IRIS.SENDF dy sppStream)
-             (IRIS.SENDF dz sppStream)
-      else (IRIS\ERROR %'IRIS.RPMV %' (dx dy dz])
-
-(IRIS.RPMV2
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 287 sppStream)
-             (IRIS.SENDF dx sppStream)
-             (IRIS.SENDF dy sppStream)
-      else (IRIS\ERROR %'IRIS.RPMV2 %' (dx dy])
-
-(IRIS.RPMVI
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 288 sppStream)
-             (IRIS.SENDL dx sppStream)
-             (IRIS.SENDL dy sppStream)
-             (IRIS.SENDL dz sppStream)
-      else (IRIS\ERROR %'IRIS.RPMVI %' (dx dy dz])
-
-(IRIS.RPMV2I
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 289 sppStream)
-             (IRIS.SENDL dx sppStream)
-             (IRIS.SENDL dy sppStream)
-      else (IRIS\ERROR %'IRIS.RPMV2I %' (dx dy])
-
-(IRIS.RPMVS
-  [LAMBDA (dx dy dz sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy dz)
-        then (IRIS.GCMD 290 sppStream)
-             (IRIS.SENDS dx sppStream)
-             (IRIS.SENDS dy sppStream)
-             (IRIS.SENDS dz sppStream)
-      else (IRIS\ERROR %'IRIS.RPMVS %' (dx dy dz])
-
-(IRIS.RPMV2S
-  [LAMBDA (dx dy sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND dx dy)
-        then (IRIS.GCMD 291 sppStream)
-             (IRIS.SENDS dx sppStream)
-             (IRIS.SENDS dy sppStream)
-      else (IRIS\ERROR %'IRIS.RPMV2S %' (dx dy])
-
-(IRIS.SETDBLIGHTS
-  [LAMBDA (mask sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if mask
-        then (IRIS.GCMD 292 sppStream)
-             (IRIS.SENDL mask sppStream)
-      else (IRIS\ERROR %'IRIS.SETDBLIGHTS %' (mask])
-
-(IRIS.SETMONITOR
-  [LAMBDA (type sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if type
-        then (IRIS.GCMD 293 sppStream)
-             (IRIS.SENDS type sppStream)
-      else (IRIS\ERROR %'IRIS.SETMONITOR %' (type])
-
-(IRIS.SETSHADE
-  [LAMBDA (shade sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if shade
-        then (IRIS.GCMD 294 sppStream)
-             (IRIS.SENDS shade sppStream)
-      else (IRIS\ERROR %'IRIS.SETSHADE %' (shade])
-
-(IRIS.SHADERANGE
-  [LAMBDA (lowindex highindex sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND lowindex highindex)
-        then (IRIS.GCMD 295 sppStream)
-             (IRIS.SENDS lowindex sppStream)
-             (IRIS.SENDS highindex sppStream)
-      else (IRIS\ERROR %'IRIS.SHADERANGE %' (lowindex highindex])
-
-(IRIS.SPCLOS
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 296 sppStream])
-
-(IRIS.SPLF
-  [LAMBDA (n parray iarray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray iarray)
-        then (IRIS.GCMD 297 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDFS parray (TIMES 3 n)
-                    sppStream)
-             (IRIS.SENDSS iarray n sppStream)
-      else (IRIS\ERROR %'IRIS.SPLF %' (n parray iarray])
-
-(IRIS.SPLF2
-  [LAMBDA (n parray iarray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray iarray)
-        then (IRIS.GCMD 298 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDFS parray (TIMES 2 n)
-                    sppStream)
-             (IRIS.SENDSS iarray n sppStream)
-      else (IRIS\ERROR %'IRIS.SPLF2 %' (n parray iarray])
-
-(IRIS.SPLFI
-  [LAMBDA (n parray iarray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray iarray)
-        then (IRIS.GCMD 299 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDLS parray (TIMES 3 n)
-                    sppStream)
-             (IRIS.SENDSS iarray n sppStream)
-      else (IRIS\ERROR %'IRIS.SPLFI %' (n parray iarray])
-
-(IRIS.SPLF2I
-  [LAMBDA (n parray iarray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray iarray)
-        then (IRIS.GCMD 300 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDLS parray (TIMES 2 n)
-                    sppStream)
-             (IRIS.SENDSS iarray n sppStream)
-      else (IRIS\ERROR %'IRIS.SPLF2I %' (n parray iarray])
-
-(IRIS.SPLFS
-  [LAMBDA (n parray iarray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray iarray)
-        then (IRIS.GCMD 301 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDSS parray (TIMES 3 n)
-                    sppStream)
-             (IRIS.SENDSS iarray n sppStream)
-      else (IRIS\ERROR %'IRIS.SPLFS %' (n parray iarray])
-
-(IRIS.SPLF2S
-  [LAMBDA (n parray iarray sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n parray iarray)
-        then (IRIS.GCMD 302 sppStream)
-             (IRIS.SENDL n sppStream)
-             (IRIS.SENDSS parray (TIMES 2 n)
-                    sppStream)
-             (IRIS.SENDSS iarray n sppStream)
-      else (IRIS\ERROR %'IRIS.SPLF2S %' (n parray iarray])
-
-(IRIS.XFPT
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 303 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF z sppStream)
-      else (IRIS\ERROR %'IRIS.XFPT %' (x y z])
-
-(IRIS.XFPTI
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 304 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL z sppStream)
-      else (IRIS\ERROR %'IRIS.XFPTI %' (x y z])
-
-(IRIS.XFPTS
-  [LAMBDA (x y z sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z)
-        then (IRIS.GCMD 305 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS z sppStream)
-      else (IRIS\ERROR %'IRIS.XFPTS %' (x y z])
-
-(IRIS.XFPT2
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 306 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-      else (IRIS\ERROR %'IRIS.XFPT2 %' (x y])
-
-(IRIS.XFPT2I
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 307 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-      else (IRIS\ERROR %'IRIS.XFPT2I %' (x y])
-
-(IRIS.XFPT2S
-  [LAMBDA (x y sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y)
-        then (IRIS.GCMD 308 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-      else (IRIS\ERROR %'IRIS.XFPT2S %' (x y])
-
-(IRIS.XFPT4
-  [LAMBDA (x y z w sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z w)
-        then (IRIS.GCMD 309 sppStream)
-             (IRIS.SENDF x sppStream)
-             (IRIS.SENDF y sppStream)
-             (IRIS.SENDF z sppStream)
-             (IRIS.SENDF w sppStream)
-      else (IRIS\ERROR %'IRIS.XFPT4 %' (x y z w])
-
-(IRIS.XFPT4I
-  [LAMBDA (x y z w sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z w)
-        then (IRIS.GCMD 310 sppStream)
-             (IRIS.SENDL x sppStream)
-             (IRIS.SENDL y sppStream)
-             (IRIS.SENDL z sppStream)
-             (IRIS.SENDL w sppStream)
-      else (IRIS\ERROR %'IRIS.XFPT4I %' (x y z w])
-
-(IRIS.XFPT4S
-  [LAMBDA (x y z w sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND x y z w)
-        then (IRIS.GCMD 311 sppStream)
-             (IRIS.SENDS x sppStream)
-             (IRIS.SENDS y sppStream)
-             (IRIS.SENDS z sppStream)
-             (IRIS.SENDS w sppStream)
-      else (IRIS\ERROR %'IRIS.XFPT4S %' (x y z w])
-
-(IRIS.ZBUFFER
-  [LAMBDA (bool sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if bool
-        then (IRIS.GCMD 312 sppStream)
-             (IRIS.SENDO bool sppStream)
-      else (IRIS\ERROR %'IRIS.ZBUFFER %' (bool])
-
-(IRIS.CHARST
-  [LAMBDA (arg1 arg2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND arg1 arg2)
-        then (IRIS.GCMD 313 sppStream)
-             (IRIS.SENDBS arg1 arg2 sppStream)
-             (IRIS.SENDL arg2 sppStream)
-      else (IRIS\ERROR %'IRIS.CHARST %' (arg1 arg2])
-
-(IRIS.STRWID
-  [LAMBDA (arg1 arg2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND arg1 arg2)
-        then (LET (retval)
-                  (IRIS.ECHOFF sppStream)
-                  (IRIS.GCMD 314 sppStream)
-                  (IRIS.SENDBS arg1 arg2 sppStream)
-                  (IRIS.SENDL arg2 sppStream)
-                  (IRIS.FLUSHG sppStream)
-                  (SETQ retval (IRIS.RECL sppStream))
-                  (IRIS.RECCR sppStream)
-                  (IRIS.ECHOON sppStream)
-                  retval)
-      else (IRIS\ERROR %'IRIS.STRWID %' (arg1 arg2])
-
-(IRIS.DEFPATTERN
-  [LAMBDA (n size mask sppStream)                            (* LeL, " 9-Sep-85 04:19")
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n size mask)
-        then (IRIS.GCMD 315 sppStream)
-             (IRIS.SENDS n sppStream)
-             (IRIS.SENDS size sppStream)
-             (IRIS.SENDSS mask (QUOTIENT (TIMES size size)
-                                      16)
-                    sppStream)
-      else (IRIS\ERROR %'IRIS.DEFPATTERN %' (n size mask])
-
-(IRIS.GETPATTERN
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (LET (retval)
-         (IRIS.ECHOFF sppStream)
-         (IRIS.GCMD 316 sppStream)
-         (IRIS.FLUSHG sppStream)
-         (SETQ retval (IRIS.RECL sppStream))
-         (IRIS.RECCR sppStream)
-         (IRIS.ECHOON sppStream)
-         retval])
-
-(IRIS.SETPATTERN
-  [LAMBDA (index sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if index
-        then (IRIS.GCMD 317 sppStream)
-             (IRIS.SENDS index sppStream)
-      else (IRIS\ERROR %'IRIS.SETPATTERN %' (index])
-
-(IRIS.OBJINSERT
-  [LAMBDA (t sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if t
-        then (IRIS.GCMD 318 sppStream)
-             (IRIS.SENDL t sppStream)
-      else (IRIS\ERROR %'IRIS.OBJINSERT %' (t])
-
-(IRIS.OBJDELETE
-  [LAMBDA (tag1 tag2 sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND tag1 tag2)
-        then (IRIS.GCMD 319 sppStream)
-             (IRIS.SENDL tag1 sppStream)
-             (IRIS.SENDL tag2 sppStream)
-      else (IRIS\ERROR %'IRIS.OBJDELETE %' (tag1 tag2])
-
-(IRIS.OBJREPLACE
-  [LAMBDA (t sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if t
-        then (IRIS.GCMD 320 sppStream)
-             (IRIS.SENDL t sppStream)
-      else (IRIS\ERROR %'IRIS.OBJREPLACE %' (t])
-
-(IRIS.ZCLEAR
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 321 sppStream])
-
-(IRIS.CURORIGIN
-  [LAMBDA (n xorigin yorigin sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND n xorigin yorigin)
-        then (IRIS.GCMD 322 sppStream)
-             (IRIS.SENDS n sppStream)
-             (IRIS.SENDS xorigin sppStream)
-             (IRIS.SENDS yorigin sppStream)
-      else (IRIS\ERROR %'IRIS.CURORIGIN %' (n xorigin yorigin])
-
-(IRIS.PAGEWRITEMASK
-  [LAMBDA (arg sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if arg
-        then (IRIS.GCMD 323 sppStream)
-             (IRIS.SENDS arg sppStream)
-      else (IRIS\ERROR %'IRIS.PAGEWRITEMASK %' (arg])
-
-(IRIS.PATCHCURVES
-  [LAMBDA (ucurves vcurves sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if (AND ucurves vcurves)
-        then (IRIS.GCMD 324 sppStream)
-             (IRIS.SENDL ucurves sppStream)
-             (IRIS.SENDL vcurves sppStream)
-      else (IRIS\ERROR %'IRIS.PATCHCURVES %' (ucurves vcurves])
-
-(IRIS.DBTEXT
-  [LAMBDA (str sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (if str
-        then (IRIS.GCMD 325 sppStream)
-             (IRIS.SENDBS str 8 sppStream)
-      else (IRIS\ERROR %'IRIS.DBTEXT %' (str])
-
-(IRIS.LASTONE
-  [LAMBDA (sppStream)
-    (if sppStream
-        then [OR (SPPSTREAM? sppStream)
-                 (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream]
-      else (SETQ sppStream IRISCONN))
-    (IRIS.GCMD 326 sppStream])
-
-(IRIS\ERROR
-  [LAMBDA (FNNAME FNARGS)                                    (* ; "Edited 28-Jan-87 18:57 by gbn")
-
-(* ;;; "This function breaks whenever an IRIS library function gets a null arg")
-
-    (ERROR (CONCAT FNNAME ": some input arg is NIL" "
-")
-           (APPLY 'CONCAT (for ARG in FNARGS join (LIST "	" ARG "	= " (EVAL ARG)
-                                                        "
-"])
-)
-(PUTPROPS IRISLIB COPYRIGHT ("Xerox Corporation" 1985 1987))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (5294 150294 (IRIS.XSETSLOWCOM 5304 . 5586) (IRIS.XSETFASTCOM 5588 . 5870) (
-IRIS.GVERSION 5872 . 6367) (IRIS.GDOWNLOAD 6369 . 6649) (IRIS.PAGECOLOR 6651 . 7069) (IRIS.TEXTCOLOR 
-7071 . 7489) (IRIS.TEXTPORT 7491 . 8085) (IRIS.ARC 8087 . 8727) (IRIS.ARCF 8729 . 9371) (IRIS.ARCFI 
-9373 . 10017) (IRIS.ARCI 10019 . 10662) (IRIS.ATTACHCURSOR 10664 . 11131) (IRIS.BACKBUFFER 11133 . 
-11538) (IRIS.BBOX2 11540 . 12201) (IRIS.BBOX2I 12203 . 12866) (IRIS.BLINK 12868 . 13509) (IRIS.CALLOBJ
- 13511 . 13918) (IRIS.CHARSTR 13920 . 14327) (IRIS.CIRC 14329 . 14836) (IRIS.CIRCF 14838 . 15347) (
-IRIS.CIRCFI 15349 . 15860) (IRIS.CIRCI 15862 . 16371) (IRIS.CLEAR 16373 . 16650) (IRIS.CLEARHITCODE 
-16652 . 16936) (IRIS.CLOSEOBJ 16938 . 17218) (IRIS.CMOV 17220 . 17707) (IRIS.CMOV2 17709 . 18154) (
-IRIS.CMOV2I 18156 . 18603) (IRIS.CMOVI 18605 . 19094) (IRIS.COLOR 19096 . 19507) (IRIS.CURSOFF 19509
- . 19788) (IRIS.CURSON 19790 . 20068) (IRIS.CURVEIT 20070 . 20521) (IRIS.DEFCURSOR 20523 . 20992) (
-IRIS.DEFLINESTYLE 20994 . 21457) (IRIS.DEFRASTERFONT 21459 . 22152) (IRIS.DELOBJ 22154 . 22559) (
-IRIS.DOUBLEBUFFER 22561 . 22845) (IRIS.DRAW 22847 . 23334) (IRIS.DRAW2 23336 . 23781) (IRIS.DRAW2I 
-23783 . 24230) (IRIS.DRAWI 24232 . 24721) (IRIS.EDITOBJ 24723 . 25130) (IRIS.ENDPICK 25132 . 25835) (
-IRIS.ENDSELECT 25837 . 26544) (IRIS.FINISH 26546 . 26824) (IRIS.FONT 26826 . 27239) (IRIS.FRONTBUFFER 
-27241 . 27648) (IRIS.GCONFIG 27650 . 27929) (IRIS.GENOBJ 27931 . 28425) (IRIS.GENTAG 28427 . 28921) (
-IRIS.GETBUFFER 28923 . 29420) (IRIS.GETBUTTON 29422 . 30109) (IRIS.GETCMMODE 30111 . 30608) (
-IRIS.GETCOLOR 30610 . 31106) (IRIS.GETCURSOR 31108 . 31856) (IRIS.GETDEPTH 31858 . 32486) (
-IRIS.GETDISPLAYMODE 32488 . 32990) (IRIS.GETFONT 32992 . 33487) (IRIS.GETHEIGHT 33489 . 33986) (
-IRIS.GETHITCODE 33988 . 34486) (IRIS.GETLSBACKUP 34488 . 34987) (IRIS.GETLSTYLE 34989 . 35486) (
-IRIS.GETLWIDTH 35488 . 35985) (IRIS.GETMAP 35987 . 36481) (IRIS.GETMATRIX 36483 . 37033) (
-IRIS.GETPLANES 37035 . 37532) (IRIS.GETRESETLS 37534 . 38032) (IRIS.GETSCRMASK 38034 . 38800) (
-IRIS.GETVALUATOR 38802 . 39493) (IRIS.GETVIEWPORT 39495 . 40263) (IRIS.GETWRITEMASK 40265 . 40765) (
-IRIS.XGINIT 40767 . 41045) (IRIS.XGRESET 41047 . 41326) (IRIS.GRGBCOLOR 41328 . 42023) (
-IRIS.GRGBCURSOR 42025 . 43027) (IRIS.GRGBMASK 43029 . 43730) (IRIS.ISOBJ 43732 . 44419) (IRIS.ISTAG 
-44421 . 45100) (IRIS.LINEWIDTH 45102 . 45505) (IRIS.LOADMATRIX 45507 . 45916) (IRIS.LOOKAT 45918 . 
-46625) (IRIS.LSBACKUP 46627 . 47028) (IRIS.MAKEOBJ 47030 . 47437) (IRIS.MAKETAG 47439 . 47838) (
-IRIS.MAPCOLOR 47840 . 48431) (IRIS.MAPW 48433 . 49429) (IRIS.MAPW2 49431 . 50194) (IRIS.MOVE 50196 . 
-50684) (IRIS.MOVE2 50686 . 51132) (IRIS.MOVE2I 51134 . 51582) (IRIS.MOVEI 51584 . 52074) (
-IRIS.MULTIMAP 52076 . 52357) (IRIS.MULTMATRIX 52359 . 52769) (IRIS.NOISE 52771 . 53233) (IRIS.ONEMAP 
-53235 . 53514) (IRIS.ORTHO 53516 . 54214) (IRIS.ORTHO2 54216 . 54808) (IRIS.PERSPECTIVE 54810 . 55408)
- (IRIS.PICK 55410 . 55963) (IRIS.PICKSIZE 55965 . 56457) (IRIS.PNT 56459 . 56945) (IRIS.PNT2 56947 . 
-57391) (IRIS.PNT2I 57393 . 57839) (IRIS.PNTI 57841 . 58329) (IRIS.POLARVIEW 58331 . 58921) (IRIS.POLF 
-58923 . 59420) (IRIS.POLF2 59422 . 59921) (IRIS.POLF2I 59923 . 60424) (IRIS.POLFI 60426 . 60925) (
-IRIS.POLY 60927 . 61424) (IRIS.POLY2 61426 . 61925) (IRIS.POLY2I 61927 . 62428) (IRIS.POLYI 62430 . 
-62929) (IRIS.POPATTRIBUTES 62931 . 63217) (IRIS.POPMATRIX 63219 . 63501) (IRIS.POPVIEWPORT 63503 . 
-63787) (IRIS.PUSHATTRIBUTES 63789 . 64076) (IRIS.PUSHMATRIX 64078 . 64361) (IRIS.PUSHVIEWPORT 64363 . 
-64648) (IRIS.QENTER 64650 . 65122) (IRIS.QREAD 65124 . 65821) (IRIS.QRESET 65823 . 66102) (IRIS.QTEST 
-66104 . 66598) (IRIS.READPIXELS 66600 . 67365) (IRIS.READRGB 67367 . 68240) (IRIS.RECT 68242 . 68790) 
-(IRIS.RECTF 68792 . 69342) (IRIS.RECTFI 69344 . 69896) (IRIS.RECTI 69898 . 70448) (IRIS.RESETLS 70450
- . 70850) (IRIS.RGBCOLOR 70852 . 71384) (IRIS.RGBCURSOR 71386 . 72156) (IRIS.RGBMODE 72158 . 72438) (
-IRIS.RGBWRITEMASK 72440 . 72980) (IRIS.ROTATE 72982 . 73442) (IRIS.SCALE 73444 . 73934) (IRIS.SCRMASK 
-73936 . 74530) (IRIS.SELECT 74532 . 75031) (IRIS.SETBUTTON 75033 . 75503) (IRIS.SETCURSOR 75505 . 
-76043) (IRIS.SETDEPTH 76045 . 76517) (IRIS.SETLINESTYLE 76519 . 76945) (IRIS.SETMAP 76947 . 77365) (
-IRIS.SETVALUATOR 77367 . 77941) (IRIS.SINGLEBUFFER 77943 . 78228) (IRIS.STRWIDTH 78230 . 78924) (
-IRIS.SWAPBUFFERS 78926 . 79210) (IRIS.SWAPINTERVAL 79212 . 79622) (IRIS.GSYNC 79624 . 79902) (IRIS.TIE
- 79904 . 80398) (IRIS.TRANSLATE 80400 . 80898) (IRIS.VIEWPORT 80900 . 81496) (IRIS.WINDOW 81498 . 
-82198) (IRIS.WRITEMASK 82200 . 82612) (IRIS.WRITEPIXELS 82614 . 83095) (IRIS.WRITERGB 83097 . 83682) (
-IRIS.TPON 83684 . 83961) (IRIS.TPOFF 83963 . 84241) (IRIS.TEXTWRITEMASK 84243 . 84671) (IRIS.XGEXIT 
-84673 . 84952) (IRIS.CLKON 84954 . 85232) (IRIS.CLKOFF 85234 . 85513) (IRIS.LAMPON 85515 . 85929) (
-IRIS.LAMPOFF 85931 . 86347) (IRIS.SETBELL 86349 . 86757) (IRIS.RINGBELL 86759 . 87040) (IRIS.TADELAY 
-87042 . 87454) (IRIS.ARCFS 87456 . 88102) (IRIS.ARCS 88104 . 88748) (IRIS.BBOX2S 88750 . 89414) (
-IRIS.BLANKSCREEN 89416 . 89836) (IRIS.BLKQREAD 89838 . 90591) (IRIS.GETMCOLOR 90593 . 91313) (
-IRIS.CALLFUNC 91315 . 91596) (IRIS.CHUNKSIZE 91598 . 92018) (IRIS.CIRCFS 92020 . 92532) (IRIS.CIRCS 
-92534 . 93044) (IRIS.CMOV2S 93046 . 93494) (IRIS.CMOVS 93496 . 93986) (IRIS.COMPACTIFY 93988 . 94402) 
-(IRIS.QDEVICE 94404 . 94804) (IRIS.UNQDEVICE 94806 . 95210) (IRIS.CURVEBASIS 95212 . 95642) (
-IRIS.CURVEPRECISION 95644 . 96090) (IRIS.CRV 96092 . 96529) (IRIS.GETTP 96531 . 97288) (IRIS.GBEGIN 
-97290 . 97569) (IRIS.TEXTINIT 97571 . 97852) (IRIS.CRVN 97854 . 98343) (IRIS.DEFBASIS 98345 . 98825) (
-IRIS.DELTAG 98827 . 99225) (IRIS.DEPTHCUE 99227 . 99641) (IRIS.DRAW2S 99643 . 100091) (IRIS.DRAWS 
-100093 . 100583) (IRIS.ENDFEEDBACK 100585 . 101297) (IRIS.FEEDBACK 101299 . 101786) (IRIS.GETCPOS 
-101788 . 102403) (IRIS.GETDCM 102405 . 102900) (IRIS.GETGPOS 102902 . 103607) (IRIS.GETLSREPEAT 103609
- . 104109) (IRIS.GETMEM 104111 . 104606) (IRIS.GETMONITOR 104608 . 105107) (IRIS.GETOPENOBJ 105109 . 
-105608) (IRIS.GETZBUFFER 105610 . 106109) (IRIS.GEWRITE 106111 . 106591) (IRIS.INITNAMES 106593 . 
-106875) (IRIS.LOADNAME 106877 . 107291) (IRIS.LSREPEAT 107293 . 107715) (IRIS.MOVE2S 107717 . 108165) 
-(IRIS.MOVES 108167 . 108657) (IRIS.NEWTAG 108659 . 109211) (IRIS.PASSTHROUGH 109213 . 109637) (
-IRIS.PATCHBASIS 109639 . 110111) (IRIS.PATCHPRECISION 110113 . 110641) (IRIS.PATCH 110643 . 111193) (
-IRIS.PCLOS 111195 . 111473) (IRIS.PDR 111475 . 111961) (IRIS.PDR2 111963 . 112407) (IRIS.PDRI 112409
- . 112897) (IRIS.PDR2I 112899 . 113345) (IRIS.PDRS 113347 . 113835) (IRIS.PDR2S 113837 . 114283) (
-IRIS.POLF2S 114285 . 114786) (IRIS.POLFS 114788 . 115287) (IRIS.POLY2S 115289 . 115790) (IRIS.POLYS 
-115792 . 116291) (IRIS.PMV 116293 . 116779) (IRIS.PMV2 116781 . 117225) (IRIS.PMVI 117227 . 117715) (
-IRIS.PMV2I 117717 . 118163) (IRIS.PMVS 118165 . 118653) (IRIS.PMV2S 118655 . 119101) (IRIS.PNT2S 
-119103 . 119549) (IRIS.PNTS 119551 . 120039) (IRIS.POPNAME 120041 . 120321) (IRIS.PUSHNAME 120323 . 
-120737) (IRIS.RDR 120739 . 121237) (IRIS.RDR2 121239 . 121691) (IRIS.RDRI 121693 . 122193) (IRIS.RDR2I
- 122195 . 122649) (IRIS.RDRS 122651 . 123151) (IRIS.RDR2S 123153 . 123607) (IRIS.RECTCOPY 123609 . 
-124317) (IRIS.RMV 124319 . 124817) (IRIS.RMV2 124819 . 125271) (IRIS.RMVI 125273 . 125773) (IRIS.RMV2I
- 125775 . 126229) (IRIS.RMVS 126231 . 126731) (IRIS.RMV2S 126733 . 127187) (IRIS.RPDR 127189 . 127689)
- (IRIS.RPDR2 127691 . 128145) (IRIS.RPDRI 128147 . 128649) (IRIS.RPDR2I 128651 . 129107) (IRIS.RPDRS 
-129109 . 129611) (IRIS.RPDR2S 129613 . 130069) (IRIS.RPMV 130071 . 130571) (IRIS.RPMV2 130573 . 131027
-) (IRIS.RPMVI 131029 . 131531) (IRIS.RPMV2I 131533 . 131989) (IRIS.RPMVS 131991 . 132493) (IRIS.RPMV2S
- 132495 . 132951) (IRIS.SETDBLIGHTS 132953 . 133373) (IRIS.SETMONITOR 133375 . 133793) (IRIS.SETSHADE 
-133795 . 134213) (IRIS.SHADERANGE 134215 . 134731) (IRIS.SPCLOS 134733 . 135012) (IRIS.SPLF 135014 . 
-135578) (IRIS.SPLF2 135580 . 136146) (IRIS.SPLFI 136148 . 136714) (IRIS.SPLF2I 136716 . 137284) (
-IRIS.SPLFS 137286 . 137852) (IRIS.SPLF2S 137854 . 138422) (IRIS.XFPT 138424 . 138912) (IRIS.XFPTI 
-138914 . 139404) (IRIS.XFPTS 139406 . 139896) (IRIS.XFPT2 139898 . 140344) (IRIS.XFPT2I 140346 . 
-140794) (IRIS.XFPT2S 140796 . 141244) (IRIS.XFPT4 141246 . 141780) (IRIS.XFPT4I 141782 . 142318) (
-IRIS.XFPT4S 142320 . 142856) (IRIS.ZBUFFER 142858 . 143270) (IRIS.CHARST 143272 . 143750) (IRIS.STRWID
- 143752 . 144519) (IRIS.DEFPATTERN 144521 . 145198) (IRIS.GETPATTERN 145200 . 145699) (IRIS.SETPATTERN
- 145701 . 146123) (IRIS.OBJINSERT 146125 . 146529) (IRIS.OBJDELETE 146531 . 147009) (IRIS.OBJREPLACE 
-147011 . 147417) (IRIS.ZCLEAR 147419 . 147698) (IRIS.CURORIGIN 147700 . 148246) (IRIS.PAGEWRITEMASK 
-148248 . 148668) (IRIS.PATCHCURVES 148670 . 149176) (IRIS.DBTEXT 149178 . 149587) (IRIS.LASTONE 149589
- . 149869) (IRIS\ERROR 149871 . 150292)))))
-STOP
diff --git a/obsolete/lispusers/IRISNET b/obsolete/lispusers/IRISNET
deleted file mode 100644
index 0399a862..00000000
--- a/obsolete/lispusers/IRISNET
+++ /dev/null
@@ -1,279 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "10-May-88 00:46:44" {ERINYES}<LISPUSERS>MEDLEY>IRISNET.;1 15482  
-
-      previous date%: " 4-Feb-87 19:47:55" {ERINYES}<LISPUSERS>LYRIC>IRISNET.;1)
-
-
-(* "
-Copyright (c) 1988 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT IRISNETCOMS)
-
-(RPAQQ IRISNETCOMS ([DECLARE%: EVAL@LOAD DONTCOPY (P (LOADCOMP 'LLETHER)
-                                                         (LOADCOMP 'ETHERRECORDS]
-                        (FNS IRIS.RESET IRIS.TRACE IRISBOOTPROCESS SENDIRISPACKET IRISFILTER 
-                             OPEN.IRISCONN IRISBOOTSERVER)
-                        (VARS \IRIS.VERBOSE (PRINTSPPDATAFLG T))
-                        (VARS (IRIS.LOCK (CREATE.MONITORLOCK "iris boot lock")))
-                        (GLOBALVARS IRISNSHOSTNUMBER)
-                        [INITVARS (IRISNET 146)
-                               (IRISBOOTDIRECTORIES '({CORE} {ERIS}<IRIS>gl2>boot>]
-                        (CONSTANTS (IRISSOCKET 37)
-                               (IRIS.PACKETTYPE 32790)
-                               (IRIS.BOOT.STREAM.NAME '|IRIS boot SPP|))
-                        [DECLARE%: EVAL@LOAD DONTCOPY (FILES ETHERRECORDS)
-                               (P (LOADCOMP 'LLETHER]
-                        [P (ACCESSFNS IRISENCAPSULATION [(IRISBASE (LOCF (FETCH (ETHERPACKET 
-                                                                                      EPENCAPSULATION
-                                                                                       )
-                                                                                OF DATUM]
-                                  [BLOCKRECORD IRISBASE ((IRISLENGTH WORD)
-                                                         (IRISDESTHOSTO 3 WORD)
-                                                         (IRISSOURCEHOSTO 3 WORD)
-                                                         (IRISTYPE WORD)
-                                                         (IRISEXCHID WORD)
-                                                         (INFOCHAR1 BYTE)
-                                                         (INFOCHAR2 BYTE))
-                                         [ACCESSFNS IRISDESTHOSTO ((IRISDESTHOST (\LOADNSHOSTNUMBER
-                                                                                  (LOCF DATUM))
-                                                                          (\STORENSHOSTNUMBER
-                                                                           (LOCF DATUM)
-                                                                           NEWVALUE))
-                                                                   (IRISPACKETBASE (LOCF DATUM))
-                                                                   (IRISDESTHOSTBASE (LOCF DATUM]
-                                         (ACCESSFNS IRISSOURCEHOSTO ((IRISSOURCEHOST
-                                                                      (\LOADNSHOSTNUMBER (LOCF DATUM)
-                                                                             )
-                                                                      (\STORENSHOSTNUMBER
-                                                                       (LOCF DATUM)
-                                                                       NEWVALUE))
-                                                                     (IRISSOURCEHOSTBASE (LOCF DATUM]
-                                  (TYPE? (type? ETHERPACKET DATUM]
-                        (MACROS BROADCASTP)))
-(DECLARE%: EVAL@LOAD DONTCOPY 
-(LOADCOMP 'LLETHER)
-(LOADCOMP 'ETHERRECORDS)
-)
-(DEFINEQ
-
-(IRIS.RESET
-  [LAMBDA NIL                                            (* gbn "24-Jun-85 01:31")
-    (PROG (PROC)
-          (CLOSEF? '{DSK}IRISBOOTFILE)
-          (if (SETQ PROC (FIND.PROCESS IRIS.BOOT.STREAM.NAME))
-              then (DEL.PROCESS PROC))
-          (if (SETQ PROC (FIND.PROCESS '|Iris Terminal SPP|))
-              then (DEL.PROCESS PROC))
-          (if (SETQ PROC (FIND.PROCESS 'IRISBOOTPROCESS))
-              then (DEL.PROCESS PROC))
-          (PROCESS.STATUS.WINDOW (CREATEPOSITION 5 5])
-
-(IRIS.TRACE
-  [LAMBDA NIL                                            (* gbn "25-Feb-86 12:24")
-    (SETQ PRINTSPPDATAFLG NIL)
-    (SETQ XIPIGNORETYPES '(1 TRANS))
-    (XIPTRACE T])
-
-(IRISBOOTPROCESS
-  [LAMBDA (IRISPACKET)                                   (* gbn "12-Nov-85 23:16")
-    (DECLARE (GLOBALVARS IRISBOOTDIRECTORIES IRISNSADDRESS IRIS.LOCK IRISNET IRISNSHOSTNUMBER))
-    (COND
-       ((OBTAIN.MONITORLOCK IRIS.LOCK T T)
-        [PROG (DH CHAR NET IRISBOOTFILE INBOOTSTREAM OUTBOOTSTREAM IRISBOOTFILENAME BOOTFILENAME TEMP
-                  )
-              (SETQ DH (fetch (IRISENCAPSULATION IRISSOURCEHOST) of IRISPACKET))
-              (SETQ CHAR (fetch (IRISENCAPSULATION INFOCHAR1) of IRISPACKET))
-              (replace (IRISENCAPSULATION IRISDESTHOST) of IRISPACKET
-                 with (SETQ IRISNSHOSTNUMBER (fetch (IRISENCAPSULATION IRISSOURCEHOST)
-                                                    of IRISPACKET)))
-              (replace (IRISENCAPSULATION IRISSOURCEHOST) of IRISPACKET with 
-                                                                                     \MY.NSHOSTNUMBER
-                     )
-              [COND
-                 (\IRIS.VERBOSE 
-          (* inform the user that a boot attempt is being made)
-                        (FLASHWINDOW PROMPTWINDOW)
-                        (PROMPTPRINT (CONCAT "IRIS boot initiated to: " DH]
-          (* "E" for "reply" to booting and "H" for "hostname" for spp connection)
-              (SETQ NET (fetch (XIP XIPSOURCENET) of IRISPACKET))
-              (SETQ IRISNSADDRESS (create NSADDRESS
-                                         NSNET _ IRISNET
-                                         NSHOSTNUMBER _ IRISNSHOSTNUMBER))
-          (* this should be using the net from the iris, but it can't be trusted.
-        SGI doesn't handle turning around packets properly)
-              (COND
-                 ((EQ CHAR (CHARCODE C))                     (* replace EPSOCKET of IRISPACKET 
-                                                           with 41)
-                  (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE
-                                                                                         E))
-                  (SENDIRISPACKET IRISPACKET)
-          (* just sends back an "E" packet with our host socket
-        (41) filled in)
-                  (SETQ INBOOTSTREAM (SPP.OPEN NIL 41 NIL IRIS.BOOT.STREAM.NAME))
-                  (SETQ OUTBOOTSTREAM (SPPOUTPUTSTREAM INBOOTSTREAM))
-                  (SPP.DSTYPE INBOOTSTREAM 108)              (* returns a connection which is not 
-                                                           yet established)
-                  (BIN INBOOTSTREAM)
-                  [SETQ TEMP (CONCAT (PACKC (while (SPP.READP INBOOTSTREAM)
-                                               collect (BIN INBOOTSTREAM]
-                  [SETQ BOOTFILENAME (L-CASE (SUBSTRING TEMP (STRPOS ":*:" TEMP 1 NIL NIL T)
-                                                    (SUB1 (STRPOS (CONCAT (CHARACTER 0))
-                                                                 TEMP]
-                  [COND
-                     ((STREQUAL BOOTFILENAME (CONSTANT "defaultboot"))
-                      (SETQ BOOTFILENAME (CONSTANT "iris"]   (* This is a packet specifying the 
-                                                           boot file name,)
-                  [SETQ IRISBOOTFILE (OPENSTREAM (SETQ IRISBOOTFILENAME (FINDFILE BOOTFILENAME NIL 
-                                                                               IRISBOOTDIRECTORIES))
-                                            'INPUT NIL '((TYPE BINARY]
-                  [COND
-                     (\IRIS.VERBOSE 
-          (* inform the user that a boot attempt is being made)
-                            (PROMPTPRINT (CONCAT "Booting IRIS from: " IRISBOOTFILENAME]
-                  (COPYBYTES IRISBOOTFILE OUTBOOTSTREAM NIL NIL)
-                  (FORCEOUTPUT OUTBOOTSTREAM)
-                  (CLOSEF IRISBOOTFILE)
-                  (PROMPTPRINT "IRIS boot server complete, closing boot file")
-                  (CLOSEF INBOOTSTREAM))
-                 ((EQ CHAR (CHARCODE A))                     (* replace EPSOCKET of IRISPACKET 
-                                                           with 41)
-                  (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE
-                                                                                         E))
-                  (SENDIRISPACKET IRISPACKET)
-          (* just sends back an "E" packet with our host socket
-        (41) filled in)
-                  (SETQ INBOOTSTREAM (SPP.OPEN NIL 41 NIL IRIS.BOOT.STREAM.NAME))
-                  (SETQ OUTBOOTSTREAM (SPPOUTPUTSTREAM INBOOTSTREAM))
-                  (SPP.DSTYPE INBOOTSTREAM 108)              (* returns a connection which is not 
-                                                           yet established)
-                  (BIN INBOOTSTREAM)
-                  (while (SPP.READP INBOOTSTREAM) collect (BIN INBOOTSTREAM))
-                  (SETQ BOOTFILENAME (CONSTANT "iris"))      (* This is a packet specifying the 
-                                                           boot file name,)
-                  [SETQ IRISBOOTFILE (OPENSTREAM (SETQ IRISBOOTFILENAME (FINDFILE BOOTFILENAME NIL 
-                                                                               IRISBOOTDIRECTORIES))
-                                            'INPUT NIL '((TYPE BINARY]
-                  [COND
-                     (\IRIS.VERBOSE 
-          (* inform the user that a boot attempt is being made)
-                            (PROMPTPRINT (CONCAT "Booting IRIS from: " IRISBOOTFILENAME]
-                  (COPYBYTES IRISBOOTFILE OUTBOOTSTREAM NIL NIL)
-                  (FORCEOUTPUT OUTBOOTSTREAM)
-                  (CLOSEF IRISBOOTFILE)
-                  (PROMPTPRINT "IRIS boot server complete, closing boot file")
-                  (CLOSEF INBOOTSTREAM))
-                 ((EQ CHAR (CHARCODE H))                     (* serv-hostname in SGIspeak)
-                  (PRINT "workstation server connection")    (* replace EPSOCKET of IRISPACKET 
-                                                           with 41)
-                  (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE
-                                                                                         H))
-                  (SETQ INBOOTSTREAM (SPP.OPEN NIL 37))
-                  (SENDIRISPACKET IRISPACKET))
-                 (T (PRINT "Iris connection")                (* replace EPSOCKET of IRISPACKET 
-                                                           with 41)
-                    (PRINTOUT PROMPTWINDOW CHAR "RECEIVED")
-                    (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with
-                                                                                 (CHARCODE H))
-                    (SETQ INBOOTSTREAM (SPP.OPEN NIL 37))
-                    (SENDIRISPACKET IRISPACKET]
-        (RELEASE.MONITORLOCK IRIS.LOCK])
-
-(SENDIRISPACKET
-  [LAMBDA (IRISPACKET)                                   (* gbn "10-Jun-85 16:05")
-          (* * Sends a raw seething IRIS packet)
-    (COND
-       ((fetch (ETHERPACKET EPTRANSMITTING) of IRISPACKET)
-        'AlreadyQueued)
-       (T                                                    (* (\RCLK (LOCF (fetch
-                                                           (ETHERPACKET EPTIMESTAMP) of 
-                                                           IRISPACKET))))
-          (TRANSMIT.ETHERPACKET (fetch (ETHERPACKET EPNETWORK) of IRISPACKET)
-                 IRISPACKET])
-
-(IRISFILTER
-  [LAMBDA (IRISPACKET)                                   (* gbn " 3-Jun-85 22:49")
-    (if (AND (EQ (fetch (ETHERPACKET EPTYPE) of IRISPACKET)
-                     IRIS.PACKETTYPE)
-                 (BROADCASTP IRISPACKET))
-        then (ADD.PROCESS `(IRISBOOTPROCESS %, IRISPACKET))
-              T
-      else                                               (* not an iris packet)
-            NIL])
-
-(OPEN.IRISCONN
-  [LAMBDA (NSADDRESS)                                    (* gbn " 7-Jul-85 14:42")
-    (SETQ IRISCONN (SPP.OPEN (OR NSADDRESS IRISNSADDRESS)
-                          IRISSOCKET T '|Iris Terminal SPP|])
-
-(IRISBOOTSERVER
-  [LAMBDA (ON?)                                          (* gbn " 7-Jul-85 14:54")
-    (if ON?
-        then (PROMPTPRINT "Enabling IRIS boot server")
-              (\ADD.PACKET.FILTER (FUNCTION IRISFILTER))
-      else (PROMPTPRINT "Disabling IRIS boot server")
-            (\DEL.PACKET.FILTER (FUNCTION IRISFILTER])
-)
-
-(RPAQQ \IRIS.VERBOSE T)
-
-(RPAQQ PRINTSPPDATAFLG T)
-
-(RPAQ IRIS.LOCK (CREATE.MONITORLOCK "iris boot lock"))
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS IRISNSHOSTNUMBER)
-)
-
-(RPAQ? IRISNET 146)
-
-(RPAQ? IRISBOOTDIRECTORIES '({CORE} {ERIS}<IRIS>gl2>boot>))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ IRISSOCKET 37)
-
-(RPAQQ IRIS.PACKETTYPE 32790)
-
-(RPAQQ IRIS.BOOT.STREAM.NAME |IRIS boot SPP|)
-
-(CONSTANTS (IRISSOCKET 37)
-       (IRIS.PACKETTYPE 32790)
-       (IRIS.BOOT.STREAM.NAME '|IRIS boot SPP|))
-)
-(DECLARE%: EVAL@LOAD DONTCOPY 
-(FILESLOAD ETHERRECORDS)
-
-(LOADCOMP 'LLETHER)
-)
-(ACCESSFNS IRISENCAPSULATION [(IRISBASE (LOCF (FETCH (ETHERPACKET EPENCAPSULATION)
-                                                     OF DATUM]
-       [BLOCKRECORD IRISBASE ((IRISLENGTH WORD)
-                              (IRISDESTHOSTO 3 WORD)
-                              (IRISSOURCEHOSTO 3 WORD)
-                              (IRISTYPE WORD)
-                              (IRISEXCHID WORD)
-                              (INFOCHAR1 BYTE)
-                              (INFOCHAR2 BYTE))
-              [ACCESSFNS IRISDESTHOSTO ((IRISDESTHOST (\LOADNSHOSTNUMBER (LOCF DATUM))
-                                               (\STORENSHOSTNUMBER (LOCF DATUM)
-                                                      NEWVALUE))
-                                        (IRISPACKETBASE (LOCF DATUM))
-                                        (IRISDESTHOSTBASE (LOCF DATUM]
-              (ACCESSFNS IRISSOURCEHOSTO ((IRISSOURCEHOST (\LOADNSHOSTNUMBER (LOCF DATUM))
-                                                 (\STORENSHOSTNUMBER (LOCF DATUM)
-                                                        NEWVALUE))
-                                          (IRISSOURCEHOSTBASE (LOCF DATUM]
-       (TYPE? (type? ETHERPACKET DATUM)))
-(DECLARE%: EVAL@COMPILE 
-[PUTPROPS BROADCASTP MACRO ((PACKET)
-                            ([LAMBDA (NDB)
-                                    (AND NDB (APPLY* (fetch NDBBROADCASTP of NDB)
-                                                    PACKET NDB]
-                             (fetch EPNETWORK of PACKET]
-)
-(PUTPROPS IRISNET COPYRIGHT ("Xerox Corporation" 1988))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (3679 13267 (IRIS.RESET 3689 . 4230) (IRIS.TRACE 4232 . 4424) (IRISBOOTPROCESS 4426 . 
-11586) (SENDIRISPACKET 11588 . 12227) (IRISFILTER 12229 . 12677) (OPEN.IRISCONN 12679 . 12908) (
-IRISBOOTSERVER 12910 . 13265)))))
-STOP
diff --git a/obsolete/lispusers/IRISSTREAM b/obsolete/lispusers/IRISSTREAM
deleted file mode 100644
index d33b73f7..00000000
--- a/obsolete/lispusers/IRISSTREAM
+++ /dev/null
@@ -1,1314 +0,0 @@
-(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
-(FILECREATED " 4-Feb-87 19:48:57" {ERIS}<IRIS>NEXT>IRISSTREAM.;10 68566  
-
-      changes to%:  (RECORDS IRISDATA)
-                    (FNS OPENIRISSTREAM CLEARIRIS DRAWBITMAP TRYGRAPHER \FONTCREATE.IRIS 
-                         \OUTCHARFN.IRIS \IRISSTREAMINIT \IRIS.ASSURE.COLOR \LOOKUPRGB BOXSCREEN 
-                         IRIS.CONS.OBJNO IRISBITMAP FILLPOLYGON INSTALL.OBJFONT \CLOSEF.IRIS R 
-                         SPPINPUTSTREAM \BACKCOLOR.IRIS \BITBLT.IRIS \BLTSHADE.IRIS 
-                         \FONTSAVAILABLE.IRIS \LEFTMARGIN.IRIS \RESET.IRIS 
-                         \PSPLINE.TO.BEZIER.GEOMETRY \SCALE.IRIS \SCALE.SPLINE.BY.DERIVS 
-                         \STRINGWIDTH.IRIS \TERPRI.IRIS \FONT.IRIS \CREATECHARSET.IRIS 
-                         \IRISSETFONTBASE \IRISFONTBASE \CHANGECHARSET.IRIS \CHARWIDTH.IRIS 
-                         \CLIPPINGREGION.IRIS \CLOSEFN.IRIS \COLOR.IRIS \DRAWCIRCLE.IRIS 
-                         \DRAWCURVE.IRIS \DRAWLINE.IRIS \CONVERTLINESTYLE.IRIS \MOVETO.IRIS 
-                         \XPOSITION.IRIS \YPOSITION.IRIS \FILLCIRCLE.IRIS \DRAWELLIPSE.IRIS 
-                         \FILLPOLYGON.IRIS \IRIS.BITBLT \DRAWPOLYGON.IRIS ALIGN)
-                    (VARS IRISSTREAMCOMS \BEZIERBASIS.IRIS)
-
-      previous date%: "16-Jan-87 18:14:11" {ERIS}<IRIS>NEXT>IRISSTREAM.;5)
-
-
-(PRETTYCOMPRINT IRISSTREAMCOMS)
-
-(RPAQQ IRISSTREAMCOMS 
-       ((FILES SFFONT COLOR IRISLIB IRISIO IRISNET)
-        [ADDVARS (IMAGESTREAMTYPES (IRIS (OPENSTREAM OPENIRISSTREAM)
-                                         (FONTCREATE \FONTCREATE.IRIS)
-                                         (FONTSAVAILABLE \FONTSAVAILABLE.IRIS)
-                                         (CREATECHARSET \CREATECHARSET.IRIS]
-        (GLOBALVARS \IRIS.VERBOSE IRISNSHOSTNUMBER \IRIS.DEBUG \BEZIERBASIS.IRIS \IRISCOLORMAPCACHE 
-               \IRIS.VERSION \IRISSTREAM IRISCONN \IV.HIGHOBJNO \IRIS.BITPLANES)
-        (INITVARS (\IRIS.VERBOSE T)
-               (\IRISSTREAMS NIL)
-               (\IRIS.VERSION 'GL2)
-               (IRISFONTDIRECTORIES '{ERIS}<IRIS>SF>)
-               (\CHARSEGMENTS.IRIS 10)
-               (\IRIS.BITPLANES 4)
-               (IRISFONTFAMILIES '(GACHA TIMESROMAN))
-               (IRISFONTROTATIONS '(0))
-               (IRISFONTSIZES '(8 10 12 14 18 24))
-               (\IRIS.DEBUG NIL)
-               (IRISNSHOSTNUMBER "0#4000.12000.41504#0")
-               (\IV.HIGHOBJNO 100000))
-        (VARS \BEZIERBASIS.IRIS \IRIS.VERBOSE \BEZIERBASIS.IRIS \IRISCOLORMAPCACHE \IRIS.VERSION)
-        (CONSTANTS IRIS.YAXIS IRIS.ZAXIS)
-        (FNS BOXSCREEN CLEARIRIS DRAWBITMAP IRIS.CONS.OBJNO IRISBITMAP INSTALL.OBJFONT OPENIRISSTREAM 
-             \CLOSEF.IRIS R SPPINPUTSTREAM TRYGRAPHER \BACKCOLOR.IRIS \BITBLT.IRIS \BLTSHADE.IRIS 
-             \FONTCREATE.IRIS \FONTSAVAILABLE.IRIS \LEFTMARGIN.IRIS \RESET.IRIS \LOOKUPRGB 
-             \PSPLINE.TO.BEZIER.GEOMETRY \SCALE.IRIS \SCALE.SPLINE.BY.DERIVS \TERPRI.IRIS \FONT.IRIS 
-             \CREATECHARSET.IRIS \IRISSETFONTBASE \IRISFONTBASE \CHANGECHARSET.IRIS \CHARWIDTH.IRIS 
-             \OUTCHARFN.IRIS \CLIPPINGREGION.IRIS \CLOSEFN.IRIS \COLOR.IRIS \IRIS.ASSURE.COLOR 
-             \DRAWCIRCLE.IRIS \DRAWCURVE.IRIS \DRAWLINE.IRIS \CONVERTLINESTYLE.IRIS \IRISSTREAMINIT 
-             \MOVETO.IRIS \XPOSITION.IRIS \YPOSITION.IRIS \FILLCIRCLE.IRIS \DRAWELLIPSE.IRIS 
-             \FILLPOLYGON.IRIS \IRIS.BITBLT \DRAWPOLYGON.IRIS ALIGN)
-        
-
-(* ;;; "test functions")
-
-        (RECORDS BEZIER IRISDATA IRISSTREAM SPLINE)
-        (CONSTANTS (\ALTLINESTYLE.IRIS 1)
-               (\IRIS.ITALICS.ROTATION -100)
-               (\PRIMARYLINESTLE.IRIS 0)
-               (\IRIS.BOLD.LINEWIDTH 2))
-        [P (\IRISSTREAMINIT)
-           (SETFONTCLASSCOMPONENT DEFAULTFONT 'IRIS '(GACHA 12]
-        [ADDVARS (DEFAULTPRINTINGHOST (IRIS Iris))
-               (PRINTERTYPES (IRIS (CANPRINT (IRIS))
-                                   (BITMAPFILE (IRISBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION 
-                                                      TITLE]
-        (P (PUTPROP 'Iris 'PRINTERTYPE 'IRIS))
-        (PROP PRINTERTYPE Iris)
-        (FUNCTIONS WITH.IRIS.ATTR)))
-(FILESLOAD SFFONT COLOR IRISLIB IRISIO IRISNET)
-
-(ADDTOVAR IMAGESTREAMTYPES (IRIS (OPENSTREAM OPENIRISSTREAM)
-                                 (FONTCREATE \FONTCREATE.IRIS)
-                                 (FONTSAVAILABLE \FONTSAVAILABLE.IRIS)
-                                 (CREATECHARSET \CREATECHARSET.IRIS)))
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \IRIS.VERBOSE IRISNSHOSTNUMBER \IRIS.DEBUG \BEZIERBASIS.IRIS \IRISCOLORMAPCACHE 
-       \IRIS.VERSION \IRISSTREAM IRISCONN \IV.HIGHOBJNO \IRIS.BITPLANES)
-)
-
-(RPAQ? \IRIS.VERBOSE T)
-
-(RPAQ? \IRISSTREAMS NIL)
-
-(RPAQ? \IRIS.VERSION 'GL2)
-
-(RPAQ? IRISFONTDIRECTORIES '{ERIS}<IRIS>SF>)
-
-(RPAQ? \CHARSEGMENTS.IRIS 10)
-
-(RPAQ? \IRIS.BITPLANES 4)
-
-(RPAQ? IRISFONTFAMILIES '(GACHA TIMESROMAN))
-
-(RPAQ? IRISFONTROTATIONS '(0))
-
-(RPAQ? IRISFONTSIZES '(8 10 12 14 18 24))
-
-(RPAQ? \IRIS.DEBUG NIL)
-
-(RPAQ? IRISNSHOSTNUMBER "0#4000.12000.41504#0")
-
-(RPAQ? \IV.HIGHOBJNO 100000)
-
-(RPAQQ \BEZIERBASIS.IRIS ((-1.0 3.0 -3.0 1.0)
-                          (3.0 -6.0 3.0 0.0)
-                          (-3.0 3.0 0.0 0.0)
-                          (1.0 0.0 0.0 0.0)))
-
-(RPAQQ \IRIS.VERBOSE T)
-
-(RPAQQ \BEZIERBASIS.IRIS ((-1.0 3.0 -3.0 1.0)
-                          (3.0 -6.0 3.0 0.0)
-                          (-3.0 3.0 0.0 0.0)
-                          (1.0 0.0 0.0 0.0)))
-
-(RPAQQ \IRISCOLORMAPCACHE (((0 0 0) . 0)
-                           ((255 255 255) . 7)
-                           ((0 255 0) . 2)
-                           ((0 0 255) . 4)
-                           ((255 0 0) . 1)
-                           ((255 255 0) . 3)
-                           ((255 0 255) . 5)
-                           ((0 255 255) . 6)))
-
-(RPAQQ \IRIS.VERSION GL2)
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ IRIS.YAXIS 89)
-
-(RPAQQ IRIS.ZAXIS 90)
-
-(CONSTANTS IRIS.YAXIS IRIS.ZAXIS)
-)
-(DEFINEQ
-
-(BOXSCREEN
-  [LAMBDA NIL                                                (* gbn " 8-Nov-85 16:56")
-          
-          (* * draw a box around the screen)
-
-    (DRAWLINE 0 0 (SUB1 SCREENWIDTH)
-           0 NIL NIL \IRISSTREAM)
-    (DRAWTO (SUB1 SCREENWIDTH)
-           (SUB1 SCREENHEIGHT)
-           NIL NIL \IRISSTREAM)
-    (DRAWTO 0 (SUB1 SCREENHEIGHT)
-           NIL NIL \IRISSTREAM)
-    (DRAWTO 0 0 NIL NIL \IRISSTREAM)
-    (FLUSHOUTPUT IRISCONN])
-
-(CLEARIRIS
-  [LAMBDA (IRIS-CONNECTION IRISSTREAM)                       (* ; "Edited  2-Feb-87 23:36 by gbn")
-    (OR IRISSTREAM (SETQ IRISSTREAM \IRISSTREAM))
-    [OR IRIS-CONNECTION (SETQ IRIS-CONNECTION (fetch SPPOUTSTREAM of (fetch IRISDATA of \IRISSTREAM]
-    (IRIS.SINGLEBUFFER IRIS-CONNECTION)
-    (IRIS.GCONFIG IRIS-CONNECTION)
-    (DSPCLIPPINGREGION WHOLESCREEN IRISSTREAM)
-    (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -1000 1000 IRIS-CONNECTION)
-    (DSPCOLOR 'WHITE IRISSTREAM)
-    (IRIS.LINEWIDTH 1 IRIS-CONNECTION)                       (* ; "IRIS.RESETLS 0 IRISCONN")
-                                                             (* ; 
-                                      "make the IRIS not reset the line style between curve segments")
-    (IRIS.CURSOFF IRIS-CONNECTION)
-    (IRIS.CLEAR IRIS-CONNECTION)
-    (DSPCOLOR 'BLUE IRISSTREAM)
-    (SELECTQ \IRIS.VERSION
-        (GL2 (IRIS.CURVEPRECISION \CHARSEGMENTS.IRIS IRIS-CONNECTION)
-             (IRIS.DEFBASIS 1 \BEZIERBASIS.IRIS IRIS-CONNECTION)
-             (IRIS.CURVEBASIS 1 IRIS-CONNECTION))
-        (GL1)
-        (ERROR "Unknown version of IRIS: " \IRIS.VERSION))
-    (DSPRESET IRISSTREAM)
-    (SPP.FORCEOUTPUT IRIS-CONNECTION])
-
-(DRAWBITMAP
-  [LAMBDA (BITMAP SOURCELEFT SOURCEBOTTOM OUTPUTSTREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
-                 )                                           (* ; "Edited  2-Feb-87 23:37 by gbn")
-    (LET ((DESTBOTTOM (OR DESTINATIONBOTTOM (DSPYPOSITION NIL OUTPUTSTREAM)))
-          (DESTLEFT (OR DESTINATIONLEFT (DSPXPOSITION NIL OUTPUTSTREAM)))
-          (WIDTH (OR WIDTH (BITMAPWIDTH BITMAP)))
-          (HEIGHT (OR HEIGHT (BITMAPHEIGHT BITMAP)))
-          (SBOTTOM (OR SOURCEBOTTOM 0))
-          (SLEFT (OR SOURCELEFT 0))
-          ROW)
-         [for Y from SOURCEBOTTOM to (IPLUS SOURCEBOTTOM HEIGHT) as YBASE from 0
-            do (SETQ ROW (IPLUS DESTBOTTOM YBASE)) 
-          
-          (* if there is a pixel set on the row, it is better to set the row outside the 
-          loop)
-
-               (bind (STATE _ 'SKIP0S)
-                     START END for X from SLEFT to (IPLUS SLEFT WIDTH) as BASE from 0
-                  do (SELECTQ STATE
-                         (SKIP0S (if (IEQP 0 (BITMAPBIT BITMAP X Y))
-                                     then                    (* skipping zeros, found a zero, so do 
-                                                             nothing)
-                                          NIL
-                                   else                      (* start a run.)
-                                        (SETQ START BASE)
-                                        (SETQ END BASE)
-                                        (SETQ STATE 'COLLECT1S)))
-                         (COLLECT1S (if (ILESSP END (add END (BITMAPBIT BITMAP X Y)))
-                                        then 
-          
-          (* collecting 1's, found one. The test already incremented END, so do nothing)
-
-                                             NIL
-                                      else (DRAWLINE (IPLUS DESTLEFT START)
-                                                  ROW
-                                                  (IPLUS DESTLEFT END)
-                                                  ROW 1 NIL OUTPUTSTREAM)
-                                           (SETQ STATE 'SKIP0S)))
-                         (SHOULDNT "Unknown state: " STATE))
-                  finally (if (EQ STATE 'COLLECT1S)
-                              then (DRAWLINE (IPLUS DESTLEFT START)
-                                          ROW
-                                          (IPLUS DESTLEFT END)
-                                          ROW 1 NIL OUTPUTSTREAM]
-         (MOVETO DESTLEFT DESTBOTTOM OUTPUTSTREAM])
-
-(IRIS.CONS.OBJNO
-  [LAMBDA NIL                                                (* gbn "15-Nov-85 15:41")
-    (add \IV.HIGHOBJNO 1])
-
-(IRISBITMAP
-  [LAMBDA (FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)    (* gbn "24-Oct-85 16:51")
-    (LET [(IRISSTREAM (OPENIMAGESTREAM '{LPT}Iris.IRIS 'IRIS]
-         (BITBLT BITMAP (fetch (REGION LEFT) of REGION)
-                (fetch (REGION BOTTOM) of REGION)
-                IRISSTREAM
-                (DSPXPOSITION NIL IRISSTREAM)
-                (DSPYPOSITION NIL IRISSTREAM)
-                (fetch (REGION WIDTH) of REGION)
-                (fetch (REGION HEIGHT) of REGION])
-
-(INSTALL.OBJFONT
-  [LAMBDA (FAMILY CHARSET LOWCHARCODE HIGHESTCHARCODE SCALE IRISSTREAM CSINFO)
-                                                             (* gbn "12-Nov-85 19:17")
-          
-          (* * takes a font in SF format that is already in core, ie, part of the value 
-          of \SPLINEFONTSINCORE, and installs it on the iris connected to STREAM.
-          Characters in the font which are nil are not downloaded)
-          
-          (* * note that this fn is called by the fontcreate method for the iris, even 
-          when the font has already been downloaded.
-          This fn looks up in the stream and just returns the old cached info from the 
-          original downloading.)
-
-    (if \IRIS.DEBUG
-        then (SETQ LOWCHARCODE 97)
-             (SETQ HIGHESTCHARCODE 101)
-      else (SETQ LOWCHARCODE (OR LOWCHARCODE 1))
-           (SETQ HIGHESTCHARCODE (OR HIGHESTCHARCODE 255)))
-    (PROG ((FONTARRAY (\LOOKUPSPLINEFONT FAMILY CHARSET))
-           (IRISDATA (fetch IRISDATA of IRISSTREAM))
-           (MAXHEIGHT 0)
-           SPACEWIDTH OBJ# FONTBASE CHARDESC WIDTHARRAY STREAM)
-          (SETQ STREAM (fetch SPPOUTSTREAM of IRISDATA))
-          (if (NOT FONTARRAY)
-              then (ERROR "Charset for spline font not in core:" (LIST FAMILY CHARSET)))
-          (if (SETQ FONTBASE (\IRISFONTBASE FAMILY CHARSET IRISDATA))
-              then 
-          
-          (* the font has already been downloaded, just return the cached info)
-
-                   (if \IRIS.DEBUG
-                       then (SHOULDNT "font being redefined"))
-                   (RETURN FONTBASE)
-            else (SETQ FONTBASE (add (fetch HIFONT# of IRISDATA)
-                                     256))
-                 (SETQ WIDTHARRAY (\CREATECSINFOELEMENT)))
-          (if \IRIS.VERBOSE
-              then (PROMPTPRINT "Installing font on IRIS: " FAMILY))
-          (if (ZEROP (IRIS.ISOBJ 0 STREAM))
-              then (IRIS.MAKEOBJ 0 STREAM)
-                   (IRIS.CURSOFF STREAM)
-                   (IRIS.CLOSEOBJ STREAM))
-          
-          (* character 0 of the font is always defined on the IRIS as the way of telling 
-          if this charset has been downloaded.)
-                                                             (* NOT ANY MORE)
-          [for I from LOWCHARCODE to HIGHESTCHARCODE
-             do (SETQ CHARDESC (ELT FONTARRAY I))
-                (if CHARDESC
-                    then (IRIS.MAKEOBJ (SETQ OBJ# (IPLUS FONTBASE I))
-                                STREAM)
-                         (SFDRAW CHARDESC NIL 0 0 SCALE IRISSTREAM) 
-          
-          (* The scale is always one when called for the iris, because the printchar 
-          method makes the IRIS scale the character anyway)
-
-                         (IRIS.CLOSEOBJ STREAM)
-                         (ALIGN)                             (* CONSISTENCY CHECK)
-                         (if (ZEROP (IRIS.ISOBJ OBJ# STREAM))
-                             then (ERROR '
-                "(OBJECT FONT CHARACTER IS UNDEFINED DIRECTLY AFTER DEFINING INSIDE INSTALL.OBJFONT)"
-                                         )
-                           else (PRINTOUT PROMPTWINDOW (CHARACTER I]
-          (IRIS.GFLUSH STREAM)
-          (ALIGN)
-          (\IRISSETFONTBASE FAMILY CHARSET IRISDATA FONTBASE)
-          (SETQ OBJ# (IPLUS FONTBASE (CHARCODE SPACE)))
-          (if (ZEROP (IRIS.ISOBJ OBJ# STREAM))
-              then                                           (* install a fake space char if there 
-                                                             isn't one)
-                   (SETQ SPACEWIDTH (\FGETWIDTH WIDTHARRAY (OR HIGHESTCHARCODE 127)))
-                   (IRIS.MAKEOBJ OBJ# STREAM)
-                   (MOVETO SPACEWIDTH 0 IRISSTREAM)
-                   (IRIS.CLOSEOBJ STREAM)
-                   (\FSETWIDTH WIDTHARRAY (CHARCODE SPACE)
-                          SPACEWIDTH))
-          (RETURN (LIST FAMILY FONTBASE WIDTHARRAY MAXHEIGHT])
-
-(OPENIRISSTREAM
-  [LAMBDA (NSHOSTNUMBER OPTIONS)                             (* ; "Edited  4-Feb-87 19:05 by gbn")
-          
-          (* * opens a stream to an iris workstation)
-
-    (DECLARE (GLOBALVARS \IRISIMAGEOPS))
-    (PROG ((IRISDATA (create IRISDATA))
-           (HOST (OR NSHOSTNUMBER IRISNSHOSTNUMBER))
-           (IRISSTREAM (OPENSTREAM '{NODIRCORE}IRIS.SCRATCH 'OUTPUT 'NEW 8 'BINARY))
-           TEMPCONN)
-          (if (NOT HOST)
-              then (ERROR "IRISNSHOSTNUMBER must be supplied"))
-          (if [AND (NOT (EQMEMB 'RECONNECT OPTIONS))
-                   (SPP.OPENP IRISCONN)
-                   (OR (NULL HOST)
-                       (SELECTQ (TYPENAME HOST)
-                           (NSADDRESS (EQUAL (fetch (NSADDRESS NSHOSTNUMBER) of HOST)
-                                             (fetch (NSADDRESS NSHOSTNUMBER) of (SPP.DESTADDRESS
-                                                                                 IRISCONN))))
-                           (LISTP (EQUAL HOST (fetch (NSADDRESS NSHOSTNUMBER) of (SPP.DESTADDRESS
-                                                                                  IRISCONN))))
-                           (LITATOM (EQ 'LPT (LISTGET (UNPACKFILENAME HOST)
-                                                    'HOST)))
-                           (NILL]
-              then 
-          
-          (* there is still a stream open to the iris.
-          Just use that, since one can have at most a single stream open to the iris)
-
-                   (RETURN \IRISSTREAM)
-            else (if [AND (TYPENAMEP HOST 'LITATOM)
-                          (EQ 'LPT (LISTGET (UNPACKFILENAME HOST)
-                                          'HOST]
-                     then 
-          
-          (* * This is just a request to hardcopy when there is no open stream)
-
-                          (SETQ HOST NIL))
-                 (if (NOT (SETQ TEMPCONN (OPEN.IRISCONN HOST)))
-                     then (ERROR "Iris did not respond to connection attempt" HOST)))
-                                                             (* replace (STREAM USERCLOSEABLE) of 
-                                                             IRISSTREAM with NIL)
-          (STREAMADDPROP IRISSTREAM 'BEFORECLOSE '\CLOSEF.IRIS)
-          (replace (STREAM OUTCHARFN) of IRISSTREAM with (FUNCTION \OUTCHARFN.IRIS))
-          (replace (IRISSTREAM IMAGEOPS) of IRISSTREAM with \IRISIMAGEOPS)
-          (replace (IRISSTREAM IRISDATA) of IRISSTREAM with IRISDATA)
-          (replace (IRISDATA SPPINSTREAM) of IRISDATA with TEMPCONN)
-          (replace (IRISDATA SPPOUTSTREAM) of IRISDATA with (SPPOUTPUTSTREAM TEMPCONN))
-          (replace (IRISDATA IRISCOLORMAPCACHE) of IRISDATA with \IRISCOLORMAPCACHE)
-                                                             (* replace (IRISDATA IRISCOLORMAP) of 
-                                                             IRISDATA with (COLORMAPCREATE NIL 
-                                                             \IRIS.BITPLANES))
-          (replace (IRISDATA IRISCHARSET) of IRISDATA with -1)
-          (replace (IRISDATA IRISPAGE) of IRISDATA with (COPY WHOLESCREEN))
-          (SETQ IRISCONN (fetch SPPOUTSTREAM of IRISDATA))
-          (IRIS.GINIT IRISCONN)
-          (CLEARIRIS IRISCONN IRISSTREAM)
-          (RETURN (SETQ \IRISSTREAM IRISSTREAM])
-
-(\CLOSEF.IRIS
-  [LAMBDA (IRISSTREAM)                                       (* gbn "25-Oct-85 17:18")
-          
-          (* * this fn is installed on the stream as a streamprop.
-          It flushs the output to the stream, but does not close it)
-
-    (FORCEOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of IRISSTREAM)))
-    (RETFROM 'CLOSEF NIL])
-
-(R
-  [LAMBDA NIL                                                (* gbn "21-Jun-85 03:57")
-    (OPENIRISSTREAM NIL '(DONTCONNECT])
-
-(SPPINPUTSTREAM
-  [LAMBDA (OUTPUTSTREAM)                                     (* gbn "17-Jun-85 17:40")
-    (PROG ((CON (fetch (STREAM F1) of OUTPUTSTREAM)))
-          (if CON
-              then (RETURN (fetch (SPPCON SPPINPUTSTREAM) of CON])
-
-(TRYGRAPHER
-  [LAMBDA (DONTSETUP?)                                       (* ; "Edited  2-Feb-87 23:43 by gbn")
-
-(* ;;; "just a hack to try to draw a grapher graph")
-
-(* ;;; "comment")
-
-    (PROG (G)
-          [SETQ G (LAYOUTSEXPR '(stu (wxy xxx)
-                                     (xyzzy)) NIL NIL (FONTCREATE 'GACHA 20 NIL NIL 'IRIS]
-          (IF (NOT DONTSETUP?)
-              THEN (IRIS.GRESET)
-                   (IRIS.SINGLEBUFFER)                       (* ; "(IRIS.DOUBLEBUFFER)")
-                   (IRIS.GCONFIG)
-                   (IRIS.PERSPECTIVE 120 1 -1000 1000)
-                   (IRIS.LOOKAT 0 0 30000 0 0 0 0)
-                   (IRIS.LINEWIDTH 2)
-                   (CLEAR 'BLUE)
-                   (IRIS.COLOR 'WHITE))
-          (DISPLAYGRAPH G \IRISSTREAM)
-          (RETURN])
-
-(\BACKCOLOR.IRIS
-  [LAMBDA (STREAM COLOR)                                     (* ; "Edited 16-Jan-87 13:58 by gbn")
-    (IF COLOR
-        THEN (REPLACE (IRISDATA BACKCOLOR) OF (FETCH IRISDATA OF STREAM) WITH COLOR)
-      ELSE (FETCH (IRISDATA BACKCOLOR) OF (FETCH IRISDATA OF STREAM])
-
-(\BITBLT.IRIS
-  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH 
-                 HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
-                 CLIPPEDSOURCEBOTTOM)                        (* gbn "12-Nov-85 14:35")
-          
-          (* * produces a |3-d| bitmap composed of lines)
-
-    (if (NOT (EQ (IMAGESTREAMTYPE DESTINATION)
-                 'IRIS))
-        then (ERROR "Destination not IRIS stream: " DESTINATION))
-    (DRAWBITMAP SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM 
-           WIDTH HEIGHT)
-    (FLUSHOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of \IRISSTREAM])
-
-(\BLTSHADE.IRIS
-  [LAMBDA (TEXTURE IRISSTREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION
-                 )                                           (* ; "Edited 16-Jan-87 15:00 by gbn")
-                                                             (* ; 
-                                                      "should not affect anything, so do a with attr")
-    (LET* ((IRISDATA (fetch IRISDATA of IRISSTREAM))
-           (SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA)))
-          (WITH.IRIS.ATTR (IRIS.POLF2 4 (LIST (CREATEPOSITION DESTINATIONLEFT DESTINATIONBOTTOM)
-                                              (CREATEPOSITION (IPLUS DESTINATIONLEFT WIDTH)
-                                                     DESTINATIONBOTTOM)
-                                              (CREATEPOSITION (IPLUS DESTINATIONLEFT WIDTH)
-                                                     (IPLUS DESTINATIONBOTTOM HEIGHT))
-                                              (CREATEPOSITION DESTINATIONLEFT (IPLUS 
-                                                                                    DESTINATIONBOTTOM 
-                                                                                     HEIGHT)))
-                                 SPPOUT)
-                 IRISSTREAM SPPOUT :COLOR TEXTURE)
-          (FORCEOUTPUT SPPOUT])
-
-(\FONTCREATE.IRIS
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)         (* ; "Edited  2-Feb-87 23:44 by gbn")
-
-(* ;;; "This function reads in the spline definition for a font, but does not install it on the iris.  The installation is done on a demand basis on the IRIS, charset by charset.")
-
-    (PROG (WIDTHS (SCALE 1)
-                 FONTDESC CSINFO)
-          
-          (* ;; "since a spline font can be any size, we must guarantee that relative sizes are guaranteed, i.e.  a 10 point font is twice as big as a 5 point font")
-
-          (SETQ SCALE 1)
-
-(* ;;; "the width arrays, the height, ascent, etc are all scaled")
-
-          (SETQ FONTDESC (create FONTDESCRIPTOR
-                                FONTDEVICE _ 'IRIS
-                                FONTFAMILY _ FAMILY
-                                FONTSIZE _ SIZE
-                                FONTFACE _ FACE
-                                ROTATION _ ROTATION))        (* ; "CHECK WHAT FONTSCALE MEANS")
-          (SETQ CSINFO (\GETCHARSETINFO 0 FONTDESC T))
-          (if (NOT CSINFO)
-              then (RETURN NIL))                             (* ; 
-                                               "this will call the createcharset method for the IRIS")
-          [SETQ SCALE (replace OTHERDEVICEFONTPROPS of FONTDESC
-                         with (QUOTIENT (FLOAT SIZE)
-                                     (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
-                                            (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO]
-          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
-          [for I from 0 to \MAXTHINCHAR DO (\FSETWIDTH WIDTHS I (FIX (TIMES (\FGETWIDTH WIDTHS I)
-                                                                            SCALE]
-          (replace \SFHeight of FONTDESC with SIZE)
-          [replace \SFAscent of FONTDESC with (FIX (TIMES SCALE (fetch (CHARSETINFO CHARSETASCENT)
-                                                                   of CSINFO]
-          [replace \SFDescent of FONTDESC with (FIX (TIMES SCALE (fetch (CHARSETINFO CHARSETDESCENT)
-                                                                    of CSINFO]
-                                                             (* ; 
-                             "OTHERDEVICEFONTPROPS is used to hide the scale of the font on the iris")
-          (RETURN FONTDESC])
-
-(\FONTSAVAILABLE.IRIS
-  [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE)                (* gbn "13-Nov-85 12:06")
-          
-          (* * returns a list of the form (family size face rotation IRIS) for any font 
-          matching the specs. * is used as wildcard.)
-
-    (DECLARE (GLOBALVARS IRISFONTDIRECTORIES))               (* Normalize face)
-    (LET [(FAMILIES (if (MEMB FAMILY IRISFONTFAMILIES)
-                        then FAMILY
-                      else NIL))
-          (SIZES (SELECTQ PSIZE
-                     (* IRISFONTSIZES)
-                     (PROG1 PSIZE)))
-          [FACES (SELECTQ FACE
-                     (* '((MEDIUM REGULAR REGULAR)
-                          (MEDIUM ITALIC REGULAR)
-                          (BOLD REGULAR REGULAR)
-                          (BOLD ITALIC REGULAR)))
-                     (PROG1 (LIST (\FONTFACE FACE]
-          (ROTATIONS (SELECTQ ROTATION
-                         (* IRISFONTROTATIONS)
-                         (PROG1 ROTATION]
-         (for FFAMILY inside FAMILIES
-            join (for SSIZE inside SIZES
-                    join (for FFACE in FACES join (for RROTATION inside ROTATIONS
-                                                     collect (LIST FFAMILY SSIZE FFACE RROTATION
-                                                                   'IRIS])
-
-(\LEFTMARGIN.IRIS
-  [LAMBDA (MARGIN STREAM)                                    (* gbn " 8-Nov-85 17:33")
-    (OR 0 (if MARGIN
-              then (replace LEFT of (fetch IRISPAGE OF (fetch IRISDATA of STREAM)) with MARGIN)
-            else (fetch LEFT of (fetch IRISPAGE OF (fetch IRISDATA of STREAM])
-
-(\RESET.IRIS
-  [LAMBDA (IRISSTREAM)                                       (* gbn "13-Nov-85 00:46")
-    (MOVETO (DSPLEFTMARGIN NIL IRISSTREAM)
-           (IDIFFERENCE (fetch TOP of (DSPCLIPPINGREGION NIL IRISSTREAM))
-                  (FONTPROP (DSPFONT NIL IRISSTREAM)
-                         'HEIGHT))
-           IRISSTREAM])
-
-(\LOOKUPRGB
-  [LAMBDA (RGB IRISDATA)                                     (* ; "Edited  2-Feb-87 20:37 by gbn")
-
-(* ;;; 
-"returns the colormap index whose value is RGB.   Returns the closest found and caches that value.")
-
-(* ;;; "Since the colormap code is so flakey, the iris now relies only on the cache in the stream. Not very efficient.")
-
-    (LET* ((CACHE (FETCH IRISCOLORMAPCACHE OF IRISDATA))
-           (INDEX (SASSOC RGB CACHE)))
-          (IF INDEX
-              THEN (CDR INDEX)
-            ELSE 
-          
-          (* ;; "didn't find exactly the right index.  Now look through the cache.  For closeness in the color space, we use cartesian difference of the rgb's.")
-
-                 [SETQ INDEX (CDR (FOR PAIR IN CACHE
-                                     SMALLEST (CL:FLET [(ABSDIF (X Y)
-                                                               (IABS (IDIFFERENCE X Y]
-                                                     (APPLY #'+ (CL:MAPCAR #'ABSDIF RGB (CAR PAIR]
-                 (REPLACE IRISCOLORMAPCACHE OF IRISDATA WITH (CL:ACONS RGB INDEX CACHE))
-                 INDEX])
-
-(\PSPLINE.TO.BEZIER.GEOMETRY
-  [LAMBDA (SPLINE KNOT#)                                     (* gbn " 7-Jul-85 20:49")
-          
-          (* * returns a bezier geometry matrix from the spline for knot KNOT#.
-          (compare with SF.DERIVS.TO.BEZIER which does the same thing for a SF spline 
-          description))
-          
-          (* * the derivatives must already be scaled by the Factorials)
-          
-          (* * should not create the BEZIER)
-
-    (PROG [(BEZ (create BEZIER
-                       B0X _ (ELT (fetch SPLINEX of SPLINE)
-                                  KNOT#)
-                       B0Y _ (ELT (fetch SPLINEY of SPLINE)
-                                  KNOT#]
-          (replace B1X of BEZ with (PLUS (ffetch B0X of BEZ)
-                                         (QUOTIENT (ELT (ffetch SPLINEDX of SPLINE)
-                                                        KNOT#)
-                                                3)))
-          (replace B1Y of BEZ with (PLUS (ffetch B0Y of BEZ)
-                                         (QUOTIENT (ELT (ffetch SPLINEDY of SPLINE)
-                                                        KNOT#)
-                                                3)))
-          (replace B2X of BEZ with (PLUS (ffetch B1X of BEZ)
-                                         (QUOTIENT (PLUS (ELT (ffetch SPLINEDX of SPLINE)
-                                                              KNOT#)
-                                                         (ELT (ffetch SPLINEDDX of SPLINE)
-                                                              KNOT#))
-                                                3)))
-          (replace B2Y of BEZ with (PLUS (ffetch B1Y of BEZ)
-                                         (QUOTIENT (PLUS (ELT (ffetch SPLINEDY of SPLINE)
-                                                              KNOT#)
-                                                         (ELT (ffetch SPLINEDDY of SPLINE)
-                                                              KNOT#))
-                                                3)))
-          (replace B3X of BEZ with (PLUS (ffetch B0X of BEZ)
-                                         (ELT (ffetch SPLINEDX of SPLINE)
-                                              KNOT#)
-                                         (ELT (ffetch SPLINEDDX of SPLINE)
-                                              KNOT#)
-                                         (ELT (ffetch SPLINEDDDX of SPLINE)
-                                              KNOT#)))
-          (replace B3Y of BEZ with (PLUS (ffetch B0Y of BEZ)
-                                         (ELT (fetch SPLINEDY of SPLINE)
-                                              KNOT#)
-                                         (ELT (ffetch SPLINEDDY of SPLINE)
-                                              KNOT#)
-                                         (ELT (ffetch SPLINEDDDY of SPLINE)
-                                              KNOT#)))
-          (RETURN BEZ])
-
-(\SCALE.IRIS
-  [LAMBDA (STREAM SCALE)                                     (* gbn "24-Jun-85 18:50")
-    (if (NOT SCALE)
-        then 1
-      else (ERROR])
-
-(\SCALE.SPLINE.BY.DERIVS
-  [LAMBDA (SPLINE)                                           (* gbn " 8-Jul-85 17:20")
-          
-          (* * For the form used by \PSPLINE.TO.BEZIER.GEOMETRY, the derivs can all be 
-          premultiplied by the factorial coefficients, rather than repeatedly multiplying 
-          them in)
-
-    (bind (DDX _ (fetch SPLINEDDX of SPLINE))
-          (DDY _ (fetch SPLINEDDY of SPLINE))
-          (DDDX _ (fetch SPLINEDDDX of SPLINE))
-          (DDDY _ (fetch SPLINEDDDY of SPLINE)) for I from 1 to (fetch %#KNOTS of SPLINE)
-       do (SETA DDX I (FQUOTIENT (ELT DDX I)
-                             2.0))
-          (SETA DDY I (FQUOTIENT (ELT DDY I)
-                             2.0))
-          (SETA DDDX I (FQUOTIENT (ELT DDDX I)
-                              6.0))
-          (SETA DDDY I (FQUOTIENT (ELT DDDY I)
-                              6.0])
-
-(\TERPRI.IRIS
-  [LAMBDA (STREAM)                                           (* gbn "12-Nov-85 14:37")
-    (MOVETO (DSPLEFTMARGIN NIL STREAM)
-           (IDIFFERENCE (DSPYPOSITION NIL STREAM)
-                  (FONTPROP (DSPFONT NIL STREAM)
-                         'HEIGHT))
-           STREAM)
-    (if (ILESSP (DSPYPOSITION NIL STREAM)
-               0)
-        then (DSPRESET STREAM))
-    (FLUSHOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM])
-
-(\FONT.IRIS
-  [LAMBDA (IRISSTREAM FONTDESC)                              (* gbn "29-Oct-85 15:25")
-    (if FONTDESC
-        then (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM)))
-                  [if [NOT (AND (type? FONTDESCRIPTOR FONTDESC)
-                                (EQ 'IRIS (fetch FONTDEVICE of FONTDESC]
-                      then (SETQ FONTDESC (\COERCEFONTDESC FONTDESC 'IRIS]
-                                                             (* user supplied a font so install it)
-                  (replace (IRISDATA CURRENTFONTDESC) of IRISDATA with FONTDESC)
-                  (\CHANGECHARSET.IRIS IRISSTREAM 0)         (* this validates the caches for 
-                                                             fontbase, current charset, etc.)
-                  FONTDESC)
-      else (fetch CURRENTFONTDESC of (fetch IRISDATA of IRISSTREAM])
-
-(\CREATECHARSET.IRIS
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)
-                                                             (* ; "Edited 16-Jan-87 16:43 by gbn")
-
-(* ;;; "This function reads in the spline definition for a CHARSET but does not install it on the iris.  The installation is done on a demand basis on the IRIS, charset by charset.")
-
-    (PROG ((FONTARRAY (\LOOKUPSPLINEFONT FAMILY CHARSET))
-           (MAXHEIGHT 1)
-           WIDTHS CSINFO FONTARRAY SCALE FILES)
-          (if (NOT FONTARRAY)
-              then                                           (* ; 
-                                                             "we haven't even read this into core.")
-                   (SETQ FILES (DIRECTORY (PACK* IRISFONTDIRECTORIES FAMILY '*.*SF)
-                                      'COLLECT)) 
-          
-          (* ;; "THIS METHOD OF FINDING THE FILES WILL NEED TO BE UPGRADED IF WE GET SPLINE DEFINITIONS FOR NS CHARACTERS")
-
-                   (if (NOT FILES)
-                       then 
-          
-          (* ;; "if you can't find the file then just return NIL to createcharset who will either report the error or build a slug charset")
-
-                            (RETURN (if NOSLUG?
-                                        then                 (* ; 
-         "if you can't find the file then just return NIL to createcharset who will report the error")
-                                             NIL
-                                      else                   (* ; 
-                                 "this will guarantee that all the chars in the charset have 0 width")
-                                           (\BUILDSLUGCSINFO 0 0 0)))
-                     else (if \IRIS.VERBOSE
-                              then (PROMPTPRINT "Reading the following spline font files: " FILES))
-                          (if \IRIS.DEBUG
-                              then (READ.SPLINE.FONT (CAR FILES)
-                                          FAMILY CHARSET)
-                            else (READ.SPLINE.FONT FILES FAMILY CHARSET))) 
-                                                             (* ; "now see if it really worked")
-                   (if (NOT (SETQ FONTARRAY (\LOOKUPSPLINEFONT FAMILY CHARSET)))
-                       then                                  (* ; 
-                                                "we just lost horribly, so die with an inconsistency")
-                            (SHOULDNT "Inside \FONTCREATE.IRIS, some SFFONTS were found, but reading them did not produce an entry in \SPLINEFONTSINCORE"
-                                   )))                       (* ; 
- "we have the FAMILY/CHARSET entries, now see if there is a font descriptor ready made for this size")
-          
-          (* ;; "since a spline font can be any size, we must guarantee that relative sizes are guaranteed, i.e.  a 10 point font is twice as big as a 5 point font")
-
-          (SETQ CSINFO (create CHARSETINFO))
-          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
-          (bind CHARDESC for I from 1 to \MAXTHINCHAR
-             do (SETQ CHARDESC (ELT FONTARRAY I)) 
-          
-          (* ;; "If there is no description for a character, set its width to zero, so that dspprintchar can recognize not to call this character.")
-
-                (if CHARDESC
-                    then (\FSETWIDTH WIDTHS I (fetch XWIDTH of (fetch SF.WIDTH of CHARDESC)))
-                         [SETQ MAXHEIGHT (IMAX MAXHEIGHT (fetch YFIDUCIAL
-                                                            of (fetch FIDUCIAL of CHARDESC]
-                  else (\FSETWIDTH WIDTHS I 0)))
-          (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (FIX (TIMES 0.7 MAXHEIGHT)))
-          (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (FIX (TIMES 0.3 MAXHEIGHT)))
-          
-          (* ;; "It doesn't look like this scale junk is used anymore.  gbn Jan 17/87")
-
-          [if (SETQ SCALE (fetch OTHERDEVICEFONTPROPS of FONTDESC))
-              then 
-          
-          (* ;; "this fontdescriptor has already build character sets, and has determined its scale.  So scale the widths in this character set.  For the first character set, this is done in \fontcreate.iris")
-
-                   (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I
-                                                           (FIX (TIMES (\FGETWIDTH WIDTHS I)
-                                                                       SCALE]
-          (RETURN CSINFO])
-
-(\IRISSETFONTBASE
-  [LAMBDA (FAMILY CHARSET IRISDATA FONTBASE)                 (* gbn "18-Oct-85 16:15")
-    (PUTASSOC (CONS FAMILY CHARSET)
-           FONTBASE
-           (fetch FONTSINIRIS of IRISDATA])
-
-(\IRISFONTBASE
-  [LAMBDA (FAMILY CHARSET IRISDATA)                          (* gbn "18-Oct-85 16:15")
-    (CDR (SASSOC (CONS FAMILY CHARSET)
-                (fetch FONTSINIRIS of IRISDATA])
-
-(\CHANGECHARSET.IRIS
-  [LAMBDA (IRISSTREAM CHARSET)                               (* gbn "18-Oct-85 16:16")
-          
-          (* * called when a character is about to be printed which is in a different 
-          charset than the current one.)
-
-    (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM))
-          CSINFO BASE FONTDESC)
-         (SETQ FONTDESC (fetch CURRENTFONTDESC of IRISDATA))
-         [replace (IRISDATA IRISWIDTHSCACHE) of IRISDATA with (fetch (CHARSETINFO WIDTHS)
-                                                                 of (SETQ CSINFO (\GETCHARSETINFO
-                                                                                  CHARSET FONTDESC]
-         (SETQ BASE (\IRISFONTBASE (fetch FONTFAMILY of FONTDESC)
-                           CHARSET IRISDATA))
-         (if (NOT BASE)
-             then 
-          
-          (* this stream has never seen this charset before so install it on the IRIS.)
-
-                  (INSTALL.OBJFONT (fetch FONTFAMILY of FONTDESC)
-                         CHARSET NIL NIL NIL IRISSTREAM CSINFO)
-                  (SETQ BASE (\IRISFONTBASE (fetch FONTFAMILY of FONTDESC)
-                                    CHARSET IRISDATA)))
-         (replace (IRISDATA CURRENTFONTBASE) of IRISDATA with BASE)
-         (replace (IRISDATA IRISCHARSET) of IRISDATA with CHARSET])
-
-(\CHARWIDTH.IRIS
-  [LAMBDA (CHARCODE FONT)                                    (* gbn "18-Oct-85 19:11")
-    (FIX (TIMES (fetch OTHERDEVICEFONTPROPS of FONT)
-                (\FGETCHARWIDTH FONT CHARCODE])
-
-(\OUTCHARFN.IRIS
-  [LAMBDA (IRISSTREAM CHARCODE)                              (* ; "Edited  2-Feb-87 23:46 by gbn")
-    (LET* ((IRISDATA (fetch IRISDATA of IRISSTREAM))
-           (SPPOUT (fetch SPPOUTSTREAM of IRISDATA))
-           OBJNO
-           (FONTDESC (fetch CURRENTFONTDESC of IRISDATA))
-           PUSHEDATTRIBUTES SCALE)
-          (if (NOT FONTDESC)
-              then                                           (* ; 
-               "this is so that the stream can be opened without the expensive font create operation")
-                   (SETQ FONTDESC (DSPFONT (FONTCREATE 'GACHA 12 NIL NIL 'IRIS)
-                                         IRISSTREAM)))
-          (if (NEQ (fetch (IRISDATA IRISCHARSET) of IRISDATA)
-                   (\CHARSET CHARCODE))
-              then (\CHANGECHARSET.IRIS IRISSTREAM (\CHARSET CHARCODE)))
-          (SETQ OBJNO (IPLUS (fetch CURRENTFONTBASE of IRISDATA)
-                             CHARCODE))
-          (COND
-             ((EQ CHARCODE (CHARCODE EOL))
-              (\TERPRI.IRIS IRISSTREAM))
-             ((NILL)                                         (* ; 
-                                                          "ZEROP (IRIS.ISOBJ CURRENTFONTBASE SPPOUT)")
-          
-          (* ;; "this character set has not been installed on the IRIS.  character zero is defined for every charset that is installed.")
-
-              (SHOULDNT "\CHANGECHARSET.IRIS has not guaranteed that char 0 is defined.  Obj = " 
-                     OBJNO))
-             ((ZEROP (\FGETWIDTH (fetch (IRISDATA IRISWIDTHSCACHE) of IRISDATA)
-                            (\CHAR8CODE CHARCODE)))          (* ; 
-                                                       "the character is not defined.  don't call it")
-              NIL)
-             (T (IRIS.PUSHMATRIX SPPOUT)
-                (IRIS.TRANSLATE (DSPXPOSITION NIL IRISSTREAM)
-                       (DSPYPOSITION NIL IRISSTREAM)
-                       0 SPPOUT)
-                (IRIS.SCALE (SETQ SCALE (fetch OTHERDEVICEFONTPROPS of FONTDESC))
-                       SCALE SCALE SPPOUT)
-                (if (EQ (CAR (fetch FONTFACE of FONTDESC))
-                        'BOLD)
-                    then (SETQ PUSHEDATTRIBUTES T)
-                         (IRIS.PUSHATTRIBUTES SPPOUT)
-                         (IRIS.LINEWIDTH \IRIS.BOLD.LINEWIDTH SPPOUT))
-                (if (EQ (CADR (fetch FONTFACE of FONTDESC))
-                        'ITALIC)
-                    then                                     (* ; "fake italics with a rotation")
-                         (IRIS.ROTATE \IRIS.ITALICS.ROTATION IRIS.ZAXIS SPPOUT))
-                (if PUSHEDATTRIBUTES
-                    then (IRIS.POPATTRIBUTES SPPOUT))
-                (IRIS.CALLOBJ OBJNO SPPOUT)
-                (IRIS.POPMATRIX SPPOUT)
-                (RELMOVETO (FIX (\FGETWIDTH (fetch IRISWIDTHSCACHE of IRISDATA)
-                                       CHARCODE))
-                       0 IRISSTREAM)
-                (FLUSHOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of IRISSTREAM])
-
-(\CLIPPINGREGION.IRIS
-  [LAMBDA (STREAM REGION)                                    (* gbn "30-Jun-85 21:21")
-    (if REGION
-        then (replace IRISCLIPPINGREGION of (fetch IRISDATA of STREAM) with REGION)
-      else (fetch IRISCLIPPINGREGION of (fetch IRISDATA of STREAM])
-
-(\CLOSEFN.IRIS
-  [LAMBDA (STR)                                              (* gbn "12-Nov-85 14:25")
-          
-          (* * (I DONT THINK THAT SGI IMPLEMENTS THE SPP CLOSE PROTOCOL, BUT WE SHOULD 
-          TRY TO CONVINCE THEM))
-
-    (FORCEOUTPUT IRISCONN])
-
-(\COLOR.IRIS
-  [LAMBDA (STREAM COLOR)                                     (* gbn " 8-Nov-85 19:25")
-    (if COLOR
-        then (IRIS.COLOR (\IRIS.ASSURE.COLOR COLOR STREAM)
-                    (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM)))
-      else (IRIS.GETCOLOR (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM])
-
-(\IRIS.ASSURE.COLOR
-  [LAMBDA (COLOR# IRISSTREAM)                                (* ; "Edited 31-Jan-87 20:32 by gbn")
-    (PROG (LEVELS)
-          (AND (COND
-                  ((NULL COLOR#)
-                   NIL)
-                  ((FIXP COLOR#)
-          
-          (* ;; "since Sketch and others call fillpolygon with textures, just return a consistent color from a texture")
-
-                   (RETURN (IMOD COLOR# 7)))
-                  [(LITATOM COLOR#)
-                   (RETURN (COND
-                              ((SETQ LEVELS (\LOOKUPCOLORNAME COLOR#))
-                                                             (* ; "recursively look up color number")
-                               (\IRIS.ASSURE.COLOR (CDR LEVELS)
-                                      IRISSTREAM))
-                              (T (ERROR "Unknown color name" COLOR#]
-                  ((HLSP COLOR#)                             (* ; "HLS form convert to RGB")
-                   (SETQ LEVELS (HLSTORGB COLOR#)))
-                  ((RGBP COLOR#)                             (* ; "check for RGB or HLS")
-                   (SETQ LEVELS COLOR#))
-                  ((AND (LISTP COLOR#)
-                        (RGBP (CADR COLOR#)))                (* ; 
-              "temporarily, handle the case of being given a texture and a color, by using the color")
-                   (RETURN (\IRIS.ASSURE.COLOR (CADR COLOR#)
-                                  IRISSTREAM)))
-                  ((TYPENAMEP COLOR# 'BITMAP)                (* ; "just a hack to not blow up")
-                   (RETURN (IMOD (for I from 1 to (BITMAPWIDTH COLOR#)
-                                    sum (BITMAPBIT COLOR# I 1))
-                                 8)))
-                  (T (\ILLEGAL.ARG COLOR#)))
-               (RETURN (COND
-                          ((\LOOKUPRGB LEVELS (fetch IRISDATA of IRISSTREAM)))
-                          (T (ERROR COLOR# "not available in color map"])
-
-(\DRAWCIRCLE.IRIS
-  [LAMBDA (IRISSTREAM X Y RADIUS BRUSH DASHING)              (* ; "Edited 16-Jan-87 15:18 by gbn")
-    (LET [(SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of (fetch IRISDATA of IRISSTREAM]
-         (WITH.IRIS.ATTR (IRIS.CIRC X Y RADIUS SPPOUT)
-                SPPOUT IRISSTREAM :COLOR (CADDR BRUSH)
-                :WIDTH
-                (if (NOT (EQP (CADR BRUSH)
-                              1))
-                    then (CADR BRUSH)
-                  else NIL)
-                :DASHING DASHING])
-
-(\DRAWCURVE.IRIS
-  [LAMBDA (IRISSTREAM KNOTS CLOSED BRUSH DASHING)            (* ; "Edited 16-Jan-87 16:00 by gbn")
-
-(* ;;; "takes a list of knots.  It must build a set of bezier control points for each knot pair.")
-
-    (LET ((SPPOUT (fetch SPPOUTSTREAM of (fetch IRISDATA of IRISSTREAM)))
-          GEOMETRY SPLINE)
-         (WITH.IRIS.ATTR [PROGN [SETQ SPLINE (PARAMETRICSPLINE KNOTS CLOSED
-                                                    (fetch SCRATCHSPLINE of (fetch IRISDATA
-                                                                               of IRISSTREAM]
-                                                             (* ; 
-                                      "convert the list of knots to a parametric spline description.")
-                                (\SCALE.SPLINE.BY.DERIVS SPLINE)
-                                                             (* ; 
-    "For each knot in the spline, use the knots and the derivatives to compute bezier control points")
-                                (for KNOT# from 1 to (SUB1 (fetch %#KNOTS of SPLINE))
-                                   do (SETQ GEOMETRY (\PSPLINE.TO.BEZIER.GEOMETRY SPLINE KNOT#))
-                                      (SELECTQ \IRIS.VERSION
-                                          (GL1 (IRIS.CURVE 10 \BEZIERBASIS.IRIS GEOMETRY SPPOUT))
-                                          (GL2 (IRIS.CRV GEOMETRY SPPOUT))
-                                          (ERROR "UNKNOWN IRIS VERSION" \IRIS.VERSION]
-                SPPOUT IRISSTREAM :COLOR (CADDR BRUSH)
-                :WIDTH
-                (if (NOT (EQP (CADR BRUSH)
-                              1))
-                    then (CADR BRUSH)
-                  else NIL)
-                :DASHING DASHING)
-         (fetch %#KNOTS of SPLINE])
-
-(\DRAWLINE.IRIS
-  [LAMBDA (IRISSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING)
-                                                             (* ; "Edited 16-Jan-87 15:22 by gbn")
-
-(* ;;; "(check about color and operation) (sets irisx and irisy to x2 and y2 respectively)")
-
-    (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM))
-           PUSHEDATTRIBUTES SPPOUT)
-          (SETQ SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA))
-          (WITH.IRIS.ATTR (PROGN (IRIS.MOVE X1 Y1 (fetch IRISZ of IRISDATA)
-                                        SPPOUT)
-                                 (IRIS.DRAW (replace IRISX of IRISDATA with X2)
-                                        (replace IRISY of IRISDATA with Y2)
-                                        (fetch IRISZ of IRISDATA)
-                                        SPPOUT))
-                 IRISSTREAM SPPOUT :COLOR COLOR :WIDTH WIDTH :DASHING DASHING])
-
-(\CONVERTLINESTYLE.IRIS
-  [LAMBDA (DASHING)                                          (* gbn "12-Nov-85 13:54")
-          
-          (* * takes an Interlisp style dashing description
-          (a list of on then off pixels) and turns it into a 16 bit dashing description, 
-          like the IRIS likes.)
-
-    (bind (RESULT _ 0) for PIX in DASHING as (FLAG _ 1) by (IDIFFERENCE 1 FLAG)
-       do [SETQ RESULT (LOGOR (LLSH RESULT PIX)
-                              (ITIMES FLAG (SUB1 (EXPT 2 PIX]
-       finally (RETURN (LOGAND (SUB1 (EXPT 2 16))
-                              RESULT])
-
-(\IRISSTREAMINIT
-  [LAMBDA NIL                                                (* ; "Edited 31-Jan-87 19:57 by gbn")
-
-(* ;;; "installs the definition of the Iris ImageOps")
-
-    (DECLARE (GLOBALVARS \IRISIMAGEOPS \FACT.IRIS))
-    (SETQ \IRISIMAGEOPS (create IMAGEOPS
-                               IMAGETYPE _ 'IRIS
-                               IMCLOSEFN _ (FUNCTION \CLOSEFN.IRIS)
-                               IMMOVETO _ (FUNCTION \MOVETO.IRIS)
-                               IMXPOSITION _ (FUNCTION \XPOSITION.IRIS)
-                               IMYPOSITION _ (FUNCTION \YPOSITION.IRIS)
-                               IMFONT _ (FUNCTION \FONT.IRIS)
-                               IMFONTCREATE _ (FUNCTION IRIS)
-                               IMDRAWLINE _ (FUNCTION \DRAWLINE.IRIS)
-                               IMLEFTMARGIN _ (FUNCTION \LEFTMARGIN.IRIS)
-                               IMRIGHTMARGIN _ (FUNCTION NILL)
-                               IMLINEFEED _ (FUNCTION HELP)
-                               IMDRAWCURVE _ (FUNCTION \DRAWCURVE.IRIS)
-                               IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.IRIS)
-                               IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.IRIS)
-                               IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.IRIS)
-                               IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.IRIS)
-                               IMCHARWIDTH _ (FUNCTION \CHARWIDTH.IRIS)
-                               IMBLTSHADE _ (FUNCTION \BLTSHADE.IRIS)
-                               IMBITBLT _ (FUNCTION \BITBLT.IRIS)
-                               IMNEWPAGE _ (FUNCTION NILL)
-                               IMSCALE _ (FUNCTION \SCALE.IRIS)
-                               IMTERPRI _ (FUNCTION \TERPRI.IRIS)
-                               IMTOPMARGIN _ (FUNCTION NILL)
-                               IMBOTTOMMARGIN _ (FUNCTION NILL)
-                               IMBACKCOLOR _ (FUNCTION \BACKCOLOR.IRIS)
-                               IMCOLOR _ (FUNCTION \COLOR.IRIS)
-                               IMCLIPPINGREGION _ (FUNCTION \CLIPPINGREGION.IRIS)
-                               IMRESET _ (FUNCTION \RESET.IRIS)
-                               IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.IRIS)
-                               IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.IRIS)))
-    (SETQ \FACT.IRIS (ARRAY 4 0 0.0 0))
-    (SETA \FACT.IRIS 0 1.0)
-    (SETA \FACT.IRIS 1 1.0)
-    (SETA \FACT.IRIS 2 2.0)
-    (SETA \FACT.IRIS 3 6.0)
-    \IRISIMAGEOPS])
-
-(\MOVETO.IRIS
-  [LAMBDA (IRISSTREAM XPOS YPOS)                             (* gbn "12-Nov-85 14:36")
-    (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM)))
-         (IRIS.MOVE (replace IRISX of IRISDATA with XPOS)
-                (replace IRISY of IRISDATA with YPOS)
-                (fetch IRISZ of IRISDATA)
-                (fetch SPPOUTSTREAM of IRISDATA])
-
-(\XPOSITION.IRIS
-  [LAMBDA (IRISSTREAM XPOS)                                  (* gbn "24-Jun-85 01:17")
-          
-          (* * adjust only the xpos)
-
-    (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM)))
-          (RETURN (if XPOS
-                      then (IRIS.MOVE (replace IRISX of IRISDATA with XPOS)
-                                  (fetch IRISY of IRISDATA)
-                                  (fetch IRISZ of IRISDATA)
-                                  (fetch SPPOUTSTREAM of IRISDATA))
-                           XPOS
-                    else (OR (fetch IRISX of IRISDATA)
-                             (replace IRISX of IRISDATA with (CAR (IRIS.GETGPOS NIL NIL NIL NIL 
-                                                                         \IRISSTREAM])
-
-(\YPOSITION.IRIS
-  [LAMBDA (IRISSTREAM YPOS)                                  (* gbn "17-Jun-85 15:05")
-          
-          (* * adjust only the ypos)
-
-    (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM)))
-          (RETURN (if YPOS
-                      then (IRIS.MOVE (fetch IRISX of IRISDATA)
-                                  (replace IRISY of IRISDATA with YPOS)
-                                  (fetch IRISZ of IRISDATA)
-                                  (fetch SPPOUTSTREAM of IRISDATA))
-                           YPOS
-                    else (fetch IRISY of IRISDATA])
-
-(\FILLCIRCLE.IRIS
-  [LAMBDA (IRISSTREAM CENTERX CENTERY RADIUS TEXTURE)        (* ; "Edited 16-Jan-87 15:24 by gbn")
-                                                             (* IRISSTREAM is guaranteed to be an 
-                                                             IRIS stream)
-    (COND
-       ((OR (NOT (NUMBERP RADIUS))
-            (ILESSP (SETQ RADIUS (FIXR RADIUS))
-                   0))
-        (\ILLEGAL.ARG RADIUS))
-       (T (LET* ((IRISDATA (fetch IRISDATA of IRISSTREAM))
-                 (SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA)))
-                (WITH.IRIS.ATTR (IRIS.CIRCF CENTERX CENTERY RADIUS SPPOUT)
-                       IRISSTREAM SPPOUT :COLOR TEXTURE])
-
-(\DRAWELLIPSE.IRIS
-  [LAMBDA (IRISSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING)
-                                                             (* gbn "11-Nov-85 19:07")
-    (PROG [(SINOR (COND
-                     (ORIENTATION (SIN ORIENTATION))
-                     (T 0.0)))
-           (COSOR (COND
-                     (ORIENTATION (COS ORIENTATION))
-                     (T 1.0]
-          (\DRAWCURVE.IRIS IRISSTREAM [LIST (CREATEPOSITION (PLUS CENTERX (FTIMES COSOR 
-                                                                                 SEMIMAJORRADIUS))
-                                                   (PLUS CENTERY (FTIMES SINOR SEMIMAJORRADIUS)))
-                                            (CREATEPOSITION (DIFFERENCE CENTERX (FTIMES SINOR 
-                                                                                      SEMIMINORRADIUS
-                                                                                       ))
-                                                   (PLUS CENTERY (FTIMES COSOR SEMIMINORRADIUS)))
-                                            (CREATEPOSITION (DIFFERENCE CENTERX (FTIMES COSOR 
-                                                                                      SEMIMAJORRADIUS
-                                                                                       ))
-                                                   (DIFFERENCE CENTERY (FTIMES SINOR SEMIMAJORRADIUS)
-                                                          ))
-                                            (CREATEPOSITION (PLUS CENTERX (FTIMES SINOR 
-                                                                                 SEMIMINORRADIUS))
-                                                   (DIFFERENCE CENTERY (FTIMES COSOR SEMIMINORRADIUS]
-                 T BRUSH DASHING)
-          (MOVETO CENTERX CENTERY IRISSTREAM])
-
-(\FILLPOLYGON.IRIS
-  [LAMBDA (IRISSTREAM POINTS TEXTURE CONVEX?)                (* gbn "11-Nov-85 19:30")
-    (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM))
-          COLOR PUSHEDATTRIBUTES SPPOUT)
-         (SETQ COLOR (\IRIS.ASSURE.COLOR TEXTURE IRISSTREAM))
-         (SETQ SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA))
-         (if COLOR
-             then 
-          
-          (* save the current attributes since this fn is to have no side effects)
-
-                  (SETQ PUSHEDATTRIBUTES T)
-                  (IRIS.PUSHATTRIBUTES SPPOUT)
-                  (IRIS.COLOR COLOR SPPOUT))
-         (if (NOT CONVEX?)
-             then 
-          
-          (* break the polygon up into convex hunks, then fill each of those.)
-
-                  (for POLY in (TRAPLOOP POINTS) do (IRIS.POLF2 (LENGTH POLY)
-                                                           (for P in POLY
-                                                              collect (LIST (CAR P)
-                                                                            (CDR P)))
-                                                           SPPOUT))
-           else (IRIS.POLF2 (LENGTH POINTS)
-                       (for P in POINTS collect (LIST (CAR P)
-                                                      (CDR P)))
-                       SPPOUT))
-         (if PUSHEDATTRIBUTES
-             then (IRIS.POPATTRIBUTES SPPOUT])
-
-(\IRIS.BITBLT
-  [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT 
-                 SOURCETYPE OPERATION TEXTURE CLIPPINGREGION)(* gbn " 7-Aug-85 23:36")
-    (PROG ((COLOR (DSPCOLOR NIL DESTINATION))
-           (SPPOUT (fetch SPPOUTSTREAM of (fetch IRISDATA of DESTINATION)))
-           NLONGS)
-          (for Y from DESTINATIONBOTTOM to (IPLUS DESTINATIONBOTTOM HEIGHT)
-             do (IRIS.CMOV2I DESTINATIONLEFT (PLUS DESTINATIONBOTTOM Y)
-                       SPPOUT)                               (* IRIS.WRITEPIXELS WIDTH
-                                                             (for X from SOURCELEFT to
-                                                             (IPLUS SOURCELEFT (SUB1 WIDTH)) 
-                                                             collect (ITIMES (BITMAPBIT SOURCE X Y) 
-                                                             COLOR)) DESTINATION)
-          
-          (* the current character position determines where a write pixels op happens)
-
-                (PROGN 
-          
-          (* * now do an inline IRIS.WRITEPIXELS)
-
-                       (IRIS.GCMD 182 SPPOUT)
-                       (IRIS.SENDS WIDTH SPPOUT)
-                       (SETQ NLONGS (FOLDHI WIDTH 2))
-                       (IRIS.SENDL (LLSH NLONGS 1)
-                              SPPOUT)                        (* Send the number of bytes to be sent)
-                       (bind ALONG for X from SOURCELEFT to (IPLUS SOURCELEFT (SUB1 WIDTH))
-                          by 2 do (SETQ ALONG (LOGOR (LLSH (ITIMES (BITMAPBIT SOURCE X Y)
-                                                                  COLOR)
-                                                           16)
-                                                     (ITIMES (BITMAPBIT SOURCE (ADD1 X)
-                                                                    Y)
-                                                            COLOR)))
-                                  (COND
-                                     ((IRIS.DOSYNC (IQUOTIENT X 2))
-                                      (IRIS.PUTGCHAR IRIS\AESC SPPOUT)))
-                                  (IRIS.SENDL ALONG SPPOUT])
-
-(\DRAWPOLYGON.IRIS
-  [LAMBDA (IRISSTREAM POINTS TEXTURE)                        (* ; "Edited 16-Jan-87 15:33 by gbn")
-    (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM))
-           COLOR SPPOUT)
-          (SETQ SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA))
-          (WITH.IRIS.ATTR (IRIS.POLY2 (LENGTH POINTS)
-                                 POINTS SPPOUT)
-                 IRISSTREAM SPPOUT :COLOR TEXTURE])
-
-(ALIGN
-  [LAMBDA (STREAM)                                           (* gbn "17-Jun-85 15:06")
-          
-          (* * this is a dummy to insure that the IRIS has caught up on the output side.
-          When it returns a value, it has caught up)
-
-    (IRIS.GETCOLOR (OR STREAM (fetch SPPINSTREAM of (fetch IRISDATA of \IRISSTREAM])
-)
-
-
-
-(* ;;; "test functions")
-
-(DECLARE%: EVAL@COMPILE
-
-(RECORD BEZIER ((B0X B0Y B0Z)
-                (B1X B1Y B1Z)
-                (B2X B2Y B2Z)
-                (B3X B3Y B3Z))
-               B0Z _ 0 B1Z _ 0 B2Z _ 0 B3Z _ 0)
-
-(DATATYPE IRISDATA 
-          (IRISX IRISY IRISZ SPPOUTSTREAM SPPINSTREAM SCRATCHSPLINE FONTSINIRIS CURRENTFONTDESC 
-                 HIFONT# CURRENTFONTBASE BACKCOLOR IRISCLIPPINGREGION OBSOLETE-FIELD 
-                 IRISCOLORMAPCACHE IRISCHARSET IRISWIDTHSCACHE IRISPAGE)
-          FONTSINIRIS _ (LIST NIL)
-          IRISX _ 0 IRISY _ 0 IRISZ _ 0 SCRATCHSPLINE _ (create SPLINE)
-          HIFONT# _ -255)
-
-(RECORD IRISSTREAM STREAM (SUBRECORD STREAM)
-                         [ACCESSFNS ((IRISDATA (FETCH (STREAM IMAGEDATA) OF DATUM)
-                                            (REPLACE (STREAM IMAGEDATA) OF DATUM WITH NEWVALUE]
-                         (TYPE? (TYPE? IRISDATA OF (FETCH (STREAM IMAGEDATA) OF DATUM))))
-
-(RECORD SPLINE (%#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX SPLINEDDDY))
-)
-(/DECLAREDATATYPE 'IRISDATA
-       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-               POINTER POINTER POINTER POINTER POINTER POINTER)
-       '((IRISDATA 0 POINTER)
-         (IRISDATA 2 POINTER)
-         (IRISDATA 4 POINTER)
-         (IRISDATA 6 POINTER)
-         (IRISDATA 8 POINTER)
-         (IRISDATA 10 POINTER)
-         (IRISDATA 12 POINTER)
-         (IRISDATA 14 POINTER)
-         (IRISDATA 16 POINTER)
-         (IRISDATA 18 POINTER)
-         (IRISDATA 20 POINTER)
-         (IRISDATA 22 POINTER)
-         (IRISDATA 24 POINTER)
-         (IRISDATA 26 POINTER)
-         (IRISDATA 28 POINTER)
-         (IRISDATA 30 POINTER)
-         (IRISDATA 32 POINTER))
-       '34)
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \ALTLINESTYLE.IRIS 1)
-
-(RPAQQ \IRIS.ITALICS.ROTATION -100)
-
-(RPAQQ \PRIMARYLINESTLE.IRIS 0)
-
-(RPAQQ \IRIS.BOLD.LINEWIDTH 2)
-
-(CONSTANTS (\ALTLINESTYLE.IRIS 1)
-       (\IRIS.ITALICS.ROTATION -100)
-       (\PRIMARYLINESTLE.IRIS 0)
-       (\IRIS.BOLD.LINEWIDTH 2))
-)
-(\IRISSTREAMINIT)
-(SETFONTCLASSCOMPONENT DEFAULTFONT 'IRIS '(GACHA 12))
-
-(ADDTOVAR DEFAULTPRINTINGHOST (IRIS Iris))
-
-(ADDTOVAR PRINTERTYPES (IRIS (CANPRINT (IRIS))
-                             (BITMAPFILE (IRISBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE))))
-(PUTPROP 'Iris 'PRINTERTYPE 'IRIS)
-
-(PUTPROPS Iris PRINTERTYPE IRIS)
-
-(DEFMACRO WITH.IRIS.ATTR (FORM SPPOUT IRISSTREAM &KEY (COLOR NIL COLORSET)
-                               (WIDTH NIL WIDTHSET)
-                               (DASHING NIL DASHINGSET))
-   `(LET [PUSHED ., [if COLORSET
-                        then `((ECOLOR %, COLOR]
-                .,
-                [if WIDTHSET
-                    then `((EWIDTH %, WIDTH]
-                .,
-                (if DASHINGSET
-                    then `((EDASHING %, DASHING]
-         .,
-         [if COLORSET
-             then `((SETQ ECOLOR (AND ECOLOR (\IRIS.ASSURE.COLOR ECOLOR IRISSTREAM]
-         .,
-         [if DASHINGSET
-             then `((SETQ EDASHING (AND EDASHING (\CONVERTLINESTYLE.IRIS EDASHING]
-         [IF [OR ., (if COLORSET
-                        then '(ECOLOR))
-                 .,
-                 (if WIDTHSET
-                     then '(EWIDTH))
-                 .,
-                 (if DASHINGSET
-                     then '(EDASHING]
-             THEN (SETQ PUSHED T)
-                  (IRIS.PUSHATTRIBUTES %, SPPOUT)
-                  .,
-                  [IF COLORSET
-                      THEN `((IF ECOLOR
-                                 THEN (IRIS.COLOR ECOLOR %, SPPOUT]
-                  .,
-                  [IF WIDTHSET
-                      THEN `((IF EWIDTH
-                                 THEN (SELECTQ \IRIS.VERSION
-                                          (GL2 (IRIS.LINEWIDTH EWIDTH %, SPPOUT))
-                                          (GL1 (if (IGREATERP EWIDTH 2)
-                                                   then NIL
-                                                 else (IRIS.LINEWIDTH 2 %, SPPOUT)))
-                                          (ERROR "UNKNOWN VERSION" \IRIS.VERSION]
-                  .,
-                  (IF DASHINGSET
-                      THEN `((IF EDASHING
-                                 THEN (IRIS.DEFLINESTYLE \ALTLINESTYLE.IRIS EDASHING %, SPPOUT)
-                                      (IRIS.SETLINESTYLE \ALTLINESTYLE.IRIS SPPOUT)
-                                      (IRIS.RESETLS 0 SPPOUT]
-         %, FORM (IF PUSHED
-                     THEN (IRIS.POPATTRIBUTES %, SPPOUT))))
-
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (6112 63745 (BOXSCREEN 6122 . 6588) (CLEARIRIS 6590 . 7831) (DRAWBITMAP 7833 . 10506) (
-IRIS.CONS.OBJNO 10508 . 10654) (IRISBITMAP 10656 . 11185) (INSTALL.OBJFONT 11187 . 15363) (
-OPENIRISSTREAM 15365 . 18920) (\CLOSEF.IRIS 18922 . 19306) (R 19308 . 19453) (SPPINPUTSTREAM 19455 . 
-19732) (TRYGRAPHER 19734 . 20565) (\BACKCOLOR.IRIS 20567 . 20911) (\BITBLT.IRIS 20913 . 21651) (
-\BLTSHADE.IRIS 21653 . 23041) (\FONTCREATE.IRIS 23043 . 25581) (\FONTSAVAILABLE.IRIS 25583 . 26989) (
-\LEFTMARGIN.IRIS 26991 . 27367) (\RESET.IRIS 27369 . 27717) (\LOOKUPRGB 27719 . 28896) (
-\PSPLINE.TO.BEZIER.GEOMETRY 28898 . 32164) (\SCALE.IRIS 32166 . 32344) (\SCALE.SPLINE.BY.DERIVS 32346
- . 33307) (\TERPRI.IRIS 33309 . 33797) (\FONT.IRIS 33799 . 34751) (\CREATECHARSET.IRIS 34753 . 39537) 
-(\IRISSETFONTBASE 39539 . 39763) (\IRISFONTBASE 39765 . 39974) (\CHANGECHARSET.IRIS 39976 . 41436) (
-\CHARWIDTH.IRIS 41438 . 41662) (\OUTCHARFN.IRIS 41664 . 44891) (\CLIPPINGREGION.IRIS 44893 . 45228) (
-\CLOSEFN.IRIS 45230 . 45512) (\COLOR.IRIS 45514 . 45895) (\IRIS.ASSURE.COLOR 45897 . 47915) (
-\DRAWCIRCLE.IRIS 47917 . 48467) (\DRAWCURVE.IRIS 48469 . 50364) (\DRAWLINE.IRIS 50366 . 51344) (
-\CONVERTLINESTYLE.IRIS 51346 . 51981) (\IRISSTREAMINIT 51983 . 54492) (\MOVETO.IRIS 54494 . 54911) (
-\XPOSITION.IRIS 54913 . 55773) (\YPOSITION.IRIS 55775 . 56436) (\FILLCIRCLE.IRIS 56438 . 57173) (
-\DRAWELLIPSE.IRIS 57175 . 59099) (\FILLPOLYGON.IRIS 59101 . 60607) (\IRIS.BITBLT 60609 . 62926) (
-\DRAWPOLYGON.IRIS 62928 . 63373) (ALIGN 63375 . 63743)))))
-STOP
diff --git a/obsolete/lispusers/IRISVIEW b/obsolete/lispusers/IRISVIEW
deleted file mode 100644
index 1e076c69..00000000
--- a/obsolete/lispusers/IRISVIEW
+++ /dev/null
@@ -1,1274 +0,0 @@
-(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10)
-(FILECREATED " 4-Feb-87 19:32:44" {ERIS}<IRIS>NEXT>IRISVIEW.;18 65298  
-
-      changes to%:  (VARS IRISVIEWCOMS)
-                    (FNS IV.SET.CURRENT.SCENE IV.SCENE.SETUP IV.INIT IV.VIEW.CHANGED IRIS.DEGREES 
-                         IV.ENSURE.SCENE IV.REDEFINE.SCENE IV.DOUBLEBUFFER IV.AXES IV.NEWSTREAM 
-                         IV.BACKGROUND IV.DSPCOLOR IV.RIGHT IV.UP IV.TOWARD IV.PHOME.AUX IV.PHOME 
-                         IV.2D.HOME)
-                    (VARIABLES *IV-COMMANDS-MENUDESC* *IV-FILLINS-MENUDESC* 
-                           *IV-POSITIONING-MENU-DESC* *IV-MENUDESC*)
-
-      previous date%: "27-Jan-87 01:16:23" {ERIS}<IRIS>NEXT>IRISVIEW.;10)
-
-
-(* "
-Copyright (c) 1985, 1987 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT IRISVIEWCOMS)
-
-(RPAQQ IRISVIEWCOMS 
-       [(FILES IRISCONSTANTS COLOROBJ)
-        (GLOBALVARS IV.CURRENT.SCENE IV.SCENES IV.SCENES.MENU IV.VIEW.MENU IV.PROMPTWINDOW AXES.SCENE 
-               SKULL.SCENE \IV.DRAW.AXES iV.BACKGROUND IV.MODE IV.THETA IV.DXLATE)
-        (INITVARS (IV.SCENES NIL)
-               (IV.CURRENT.SCENE)
-               (IV.SCENES.MENU)
-               (IV.VIEW.MENU))
-        (BITMAPS IV.LEFT IV.POS IV.RIGHT IV.RIGHT.HIGHLIGHT IV.DOWN IV.UP IV.UP.HIGHLIGHT 
-               BACKGROUNDBITMAP IV.ROTX IV.ROTX.HIGHLIGHT IV.ROTY IV.ROTY.HIGHLIGHT IV.ROTZ 
-               IV.ROTZ.HIGHLIGHT IV.ROTATE IV.DELTA.LABEL IV.THETA.LABEL IV.TOWARD 
-               IV.TOWARD.HIGHLIGHT IV.AWAY)
-                                                             (* ; "fns for co-ordinating scenes")
-        (FNS IV.PROOF.SCENE IV.ENSURE.SCENE IV.NEW.SCENE.FROM.USER IV.REDEFINE.SCENE IV.CHOOSE.SCENE 
-             IV.BUILD.SCENES.MENU IV.FORGET.SCENE IV.DRAW.SCENE IV.SET.CURRENT.SCENE IV.SCENE.SETUP)
-        (FNS DRAW.AXES F IV.CLEARIRIS IV.DOWN IV.GETINPUT IV.READ IV.HOME IV.2D.HOME IV.PHOME 
-             IV.PHOME.AUX IV.VIEW IV.LEFT IV.RIGHT IV.ROTX IV.DOUBLEBUFFER IV.ROTY IV.ROTZ 
-             IV.SWAPBUFFERS IV.UP IV.THETA IV.AXES IV.BACKGROUND IV.TOWARD IV.AWAY IV.DSPCOLOR 
-             IV.DELTA IV.VIEW.CHANGED IV.NEWSTREAM IV.PROMPTPRINT IV.PROOF.SKETCH IV.INIT \CLEAR.IRIS 
-             IRIS.DEGREES)
-        (FNS IV.ITEMMAPFN IV.DISPLAY.FMITEM)
-        (RECORDS IRISSCENE IVPOS)
-        (VARS HANDWIDTH IRIS.XAXIS IRIS.ZAXIS IV.DXLATE IV.MODE IV.OBJPT IV.THETA IV.TRACE.FNS 
-              IV.TWIST IV.VIEWPT LASTIV.OBJPT LASTIV.VIEWPT (\IV.DRAW.AXES)
-              (\IV.BACKGROUND))
-        (P (IV.SCENE.SETUP)
-           (IV.BUILD.SCENES.MENU))
-        (FNS SKULLO)
-          
-          (* ;; "The order of these variables is important.")
-
-        (VARIABLES *IV-SCENES-MENUDESC* *IV-FILLINS-MENUDESC* *IV-COMMANDS-MENUDESC* 
-               *IV-POSITIONING-MENU-DESC* *IV-MENUDESC*)
-        (PROP FILETYPE IRISVIEW)
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA IV.PROMPTPRINT])
-(FILESLOAD IRISCONSTANTS COLOROBJ)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS IV.CURRENT.SCENE IV.SCENES IV.SCENES.MENU IV.VIEW.MENU IV.PROMPTWINDOW AXES.SCENE 
-       SKULL.SCENE \IV.DRAW.AXES iV.BACKGROUND IV.MODE IV.THETA IV.DXLATE)
-)
-
-(RPAQ? IV.SCENES NIL)
-
-(RPAQ? IV.CURRENT.SCENE )
-
-(RPAQ? IV.SCENES.MENU )
-
-(RPAQ? IV.VIEW.MENU )
-
-(RPAQQ IV.LEFT #*(48 24)@@@L@@@@@@@@@@ACH@@@@@@@@@A@F@@@@@@@@@@HAH@@@@@@@@@F@F@@@@@@@@@ALAH@@@@@@@@@B@L@@@@@GOOOO@GH@@@@H@@@@@@F@@@@H@@@@@@ACO@@H@@@@@@@N@@@GOOO@@@@B@@@@@D@@@@@B@@@@@H@@@@@B@@@@@H@@@@@B@@@@@GOH@@@B@@@@@B@@@@@B@@@@@D@@@@@B@@@@@D@@@@@B@@@@@CON@@@B@@@@@A@@@@@B@@@@@B@@@@AN@@@@@B@@@@NAH@@@@AOOOO@@G@@
-)
-
-(RPAQQ IV.POS (275 . 200))
-
-(RPAQQ IV.RIGHT #*(48 24)@@@@@@@@C@@@@@@@@@@ALH@@@@@@@@@F@H@@@@@@@@AHA@@@@@@@@@F@F@@@@@@@@AHCH@@@@@@@@C@D@@@@@@@@AN@OOOON@@@@F@@@@@@A@@OLH@@@@@@A@@@G@@@@@@@A@@@D@@@@OOON@@@D@@@@@B@@@@@D@@@@@A@@@@@D@@@@@A@@@@@D@@@AON@@@@@D@@@@@D@@@@@D@@@@@B@@@@@D@@@@@B@@@@@D@@@GOL@@@@@D@@@@@H@@@@@GH@@@@D@@@@AHG@@@@D@@@@N@@OOOOH@@
-)
-
-(RPAQQ IV.RIGHT.HIGHLIGHT #*(48 24)@@@@@@@@C@@@@@@@@@@AOH@@@@@@@@@GOH@@@@@@@@AOO@@@@@@@@@GON@@@@@@@@AOOH@@@@@@@@GOL@@@@@@@@AOOOOOON@@@@GOOOOOOO@@OLOOOOOOOO@@@GOOOOOOOO@@@GOOOOOOON@@@GOOOOON@@@@@GOOOOOO@@@@@GOOOOOO@@@@@GOOOOON@@@@@GOOOOOL@@@@@GOOOOON@@@@@GOOOOON@@@@@GOOOOOL@@@@@GOOOOOH@@@@@GOOOOOL@@@@AHGOOOOL@@@@N@@OOOOH@@
-)
-
-(RPAQQ IV.DOWN #*(24 48)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@A@@@@D@@A@@@@D@@A@@@@D@@B@@@@D@@B@@@@GOOL@@@@B@@D@@@@B@@D@@@@D@@D@@@@H@@B@@@@H@@B@@@A@@@B@@@A@@@A@@@A@@@A@@@C@@@A@@@F@@@A@@@D@@@A@@@H@@@A@@@H@@@A@@A@@@@A@@AA@@@A@@BC@@AA@@BE@@AA@@DE@AAA@@DEAAAA@@DIAAAA@@HIAAAA@@IAAAAA@@FAAAAI@@@AAAIF@@@AAIF@@@@AAF@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@@N@@@@@
-)
-
-(RPAQQ IV.UP #*(24 48)@@N@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AAF@@@@@AAIF@@@@AAAIF@@FAAAAI@@IAAAAA@@HIAAAA@@DIAAAA@@DEAAAA@@DE@AAA@@BE@@AA@@BC@@AA@@AA@@@A@@A@@@@A@@@H@@@A@@@H@@@A@@@D@@@A@@@F@@@A@@@C@@@A@@@A@@@A@@@A@@@A@@@A@@@B@@@@H@@B@@@@H@@B@@@@D@@D@@@@B@@D@@@@B@@D@@@@GOOL@@@@D@@B@@@@D@@B@@@@D@@A@@@@D@@A@@@@D@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IV.UP.HIGHLIGHT #*(24 48)@@N@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AOF@@@@@AOOF@@@@AOOOF@@FAOOOO@@OAOOOO@@OIOOOO@@GIOOOO@@GMOOOO@@GMOOOO@@CMOOOO@@COOOOO@@AOOOOO@@AOOOOO@@@OOOOO@@@OOOOO@@@GOOOO@@@GOOOO@@@COOOO@@@AOOOO@@@AOOOO@@@AOOON@@@@OOON@@@@OOON@@@@GOOL@@@@COOL@@@@COOL@@@@GOOL@@@@D@@B@@@@D@@B@@@@D@@A@@@@D@@A@@@@D@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ BACKGROUNDBITMAP #*(12 15)@@@@CKN@EOB@IFH@JFH@BF@@BD@@@D@@@D@@@B@@@CF@@CN@@ON@AON@@@@@)
-
-(RPAQQ IV.ROTX #*(28 47)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@@@AHL@@@@@B@B@@@@@D@A@@@@@D@A@@@@@H@@H@@@@H@@H@@@A@@@D@@@A@@@D@@@A@@@D@@@A@@@D@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@BB@@@B@@CBF@@B@@AJL@@B@@@OH@@A@@@F@@@A@@@D@@@A@@@D@@@A@@@D@@@@H@@H@@@@H@@H@@@@D@A@@@@@D@A@@@@@B@B@@@@@AHL@@@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IV.ROTX.HIGHLIGHT #*(28 47)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@@@AOL@@@@@CON@@@@@GOO@@@@@GOO@@@@@OOOH@@@@OOOH@@@AOOOL@@@AOOOL@@@AOOOL@@@AOOOL@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOONF@@COOONL@@COOOOH@@AOOON@@@AOOOL@@@AOOOL@@@AOOOL@@@@OOOH@@@@OOOH@@@@GOO@@@@@GOO@@@@@CON@@@@@AOL@@@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IV.ROTY #*(42 30)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OON@@@@@@@@O@@AN@@@@@@C@@@@AH@@@@@L@@@@@F@@@@A@@@@@@A@@@@B@@@@@@@H@@@B@@@@@@@H@@@D@@@@@@@D@@@D@@@@@@@D@@@D@@@@@@@D@@@B@@@@@@@H@@@B@@@@H@@H@@@A@@@AH@A@@@@@L@@C@@F@@@@@C@@F@AH@@@@@@O@LAN@@@@@@@@OON@@@@@@@@@@L@@@@@@@@@@@F@@@@@@@@@@@C@@@@@@@@@@@AH@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IV.ROTY.HIGHLIGHT #*(42 30)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OON@@@@@@@@OOOON@@@@@@COOOOOH@@@@@OOOOOON@@@@AOOOOOOO@@@@COOOOOOOH@@@COOOOOOOH@@@GOOOOOOOL@@@GOOOOOOOL@@@GOOOOOOOL@@@COOOOOOOH@@@COOOOOOOH@@@AOOOOOOO@@@@@OOOOOON@@@@@COOOOOH@@@@@@OOOON@@@@@@@@OON@@@@@@@@@@L@@@@@@@@@@@F@@@@@@@@@@@C@@@@@@@@@@@AH@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IV.ROTZ #*(45 38)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@AL@O@@@@@@@@F@@@N@@@@@@@H@@@AH@@@@@A@@@@@F@@@@@A@@@@@AOO@@@A@@@@@AL@@@@B@@@@@AB@@@@B@@@@@AA@@@@B@@@@@A@H@@@B@@@@@A@D@@@A@@@@@A@D@@@A@@@@@A@B@@@A@@@@@A@A@@@@H@@@@@@A@@@@D@@@@@@A@@@@D@@@@@@@H@@@B@@@@@@@H@@@A@@@@@@@H@@@@H@@@@@@H@@@@F@@@@@A@@@@@A@@@@@A@@@@@@L@@@@A@@@@@@C@@@@B@@@@@@@N@@@L@@@@@@@AN@G@@@@@@@@@AOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IV.ROTZ.HIGHLIGHT #*(45 38)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@AOOO@@@@@@@@GOOON@@@@@@@OOOOOH@@@@@AOOOOON@@@@@AOOOOOOOO@@@AOOOOOOL@@@@COOOOOON@@@@COOOOOOO@@@@COOOOOOOH@@@COOOOOOOL@@@AOOOOOOOL@@@AOOOOOOON@@@AOOOOOOOO@@@@OOOOOOOO@@@@GOOOOOOO@@@@GOOOOOOOH@@@COOOOOOOH@@@AOOOOOOOH@@@@OOOOOOOH@@@@GOOOOOO@@@@@AOOOOOO@@@@@@OOOOOO@@@@@@COOOON@@@@@@@OOOOL@@@@@@@AOOO@@@@@@@@@AOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IV.ROTATE #*(74 77)@@@@@@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AL@@@@@@@@@@@@@@@@@@AL@@@@@@@@@@@@@@@@@@BJ@@@@@@@@@@@@@@@@@@BJ@@@@@@@@@@@@@@@@@@DI@@@@@@@@@@@@@@@@@@DI@@@@@@@@@@@@@@@@@@HI@@@@@@@@@@@@@@@@@@HHH@@@@@@@@@@@@@@@@@HHH@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@IB@@@@@@@@@@@@@@@@@@HJ@@@@@@@@@@@@@@@@@@HF@@@@@@@@@@@@@@@@@@HB@@@@@@@@@@@@@@@@@@IB@@@@@@@@@@@@@@@@@@HL@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@HH@@@@@@@@@@@H@@@@@@E@@@@@@@@@@@@H@@@@@@B@N@@@@@@@@@@H@@@@@@E@AH@@@@@@@@@H@@@@@@HH@F@@@@@@@@@H@@@@@@@@@AL@@@@@@@@OOOOOOOOOOOO@@@@@@@A@@@@@@@@@@AL@@@@@@@A@@@@@@@@@@F@@@@@@@@B@@@@@@@@@AH@@@@@@@@D@@@@@@@@@N@@@@@@@@@D@@@@@@@@@@@@@@@AN@@H@@@@@@@@@@@@@@@@B@A@@@@@@@@@@@@@@@@@D@A@@@@@@@@@@@@@@@@@H@B@@@@@@@@@@@@@@@@AN@D@@@@@@@@@@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@AA@@@@@@@@@@@@@@@@@@AA@@@@@@@@@@@@@@@@@@AB@@@@@@@@@@@@@@@@@@BD@@@@@@@@@@@@@@@@@@BDD@@@@@@@@@@@@@@@@@BHH@@@@@@@@@@@@@@@@@EA@@@@@@@@@@@@@@@@@@EF@@@@@@@@@@@@@@@@@@FH@@@@@@@@@@@@@@@@@@M@@@@@@@@@@@@@@@@@@@N@@@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IV.DELTA.LABEL #*(9 13)@@@@@H@@@H@@AD@@AD@@BB@@BB@@DA@@DA@@GO@@@@@@@@@@@@@@)
-
-(RPAQQ IV.THETA.LABEL #*(7 13)@@@@CH@@DD@@DD@@DD@@GL@@DD@@DD@@DD@@CH@@@@@@@@@@@@@@)
-
-(RPAQQ IV.TOWARD #*(35 38)@@@@@@H@@@@@@@@@@A@@@@@@@@@@@B@@@@@@@G@@@L@@@@@@@DN@CD@@@@@@@FAONF@@@@@@@B@@@B@@@@@@@A@@@C@@@@@@@@L@@A@@@@@@@@CO@@H@@@@@@@@F@@D@@@@@@@@D@@B@@@@@@@@H@@A@@@@@@@A@@@@IB@@@@@B@@@@EN@@@@@D@@@@C@@@@@@HB@@@F@@@@@A@D@@@H@@@@@B@H@@@H@@@@@DA@D@A@@@@@@HB@H@B@@@@@A@DA@HD@@@@@B@JBA@H@@@@@DAALBA@@@@@@HB@DDB@@@@@@HD@GHD@@@@@@GH@@HH@@@@@@@@@@I@@@@@@@@@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IV.TOWARD.HIGHLIGHT #*(35 38)@@@@@@H@@@@@@@@@@A@@@@@@@@@@@B@@@@@@@G@@@L@@@@@@@GN@CL@@@@@@@GOOON@@@@@@@COOON@@@@@@@AOOOO@@@@@@@@OOOO@@@@@@@@COOOH@@@@@@@@GOOL@@@@@@@@GOON@@@@@@@@OOOO@@@@@@@AOOOOHB@@@@@COOOOMN@@@@@GOOOOO@@@@@@OOOOON@@@@@AOOOOOH@@@@@COOOOOH@@@@@GOOOOO@@@@@@OOOOON@@@@@AOOOOOL@@@@@COKOOOH@@@@@GOAOOO@@@@@@ON@GON@@@@@@OL@GOL@@@@@@GH@@OH@@@@@@@@@@O@@@@@@@@@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IV.AWAY #*(36 34)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@C@@@@@@@@@@@G@@@@@@@@@@@K@@@@@@@@@@AE@@@@@@@@@@BE@@@@@@@@@@@E@@@@@@@@@@@I@@@@@@@@@@@H@@@@@@@@@@@H@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@B@@@@@@@@@@@B@@@@@@@@@@@B@@@@@@@@@@@D@@@@@@@@@@@D@@@@@@@@@@@D@@@@@@@@@@@H@@@@@@@@@@@H@@@@@@@@@@@H@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-
-
-(* ; "fns for co-ordinating scenes")
-
-(DEFINEQ
-
-(IV.PROOF.SCENE
-  [LAMBDA (ITEM)                                             (* gbn "21-Nov-85 01:14")
-    (LET ((OBJNO (fetch (IRISSCENE OBJNO) of IV.CURRENT.SCENE)))
-         (IV.ENSURE.SCENE IV.CURRENT.SCENE)                  (* makes sure the object is defined)
-         (IRIS.CALLOBJ OBJNO \IRISSTREAM)
-         (IRIS.SWAPBUFFERS \IRISSTREAM)
-         (ALIGN \IRISSTREAM)
-         (SPP.FORCEOUTPUT IRISCONN])
-
-(IV.ENSURE.SCENE
-  [LAMBDA (SCENE)                                            (* ; "Edited 29-Jan-87 01:22 by gbn")
-                                                             (* ; 
-                                                        "makes sure that a scene's objno is defined.")
-    (LET ((OBJNO (fetch (IRISSCENE OBJNO) of SCENE)))
-         (if (ZEROP (IRIS.ISOBJ OBJNO \IRISSTREAM))
-             then (IV.PROMPTPRINT "Creating object for " (fetch (IRISSCENE NAME) of SCENE))
-                  (RESETLST (RESETSAVE NIL (LIST 'IRIS.CLOSEOBJ \IRISSTREAM))
-                         (IRIS.MAKEOBJ OBJNO \IRISSTREAM)
-                         (if (SETQ DRAWFN (fetch (IRISSCENE DRAWFN) of SCENE))
-                             then (EVAL DRAWFN)
-                           else (IV.GETINPUT (CONCAT "Please remake " (fetch (IRISSCENE NAME)
-                                                                         of SCENE)
-                                                    " then hit RETURN")))
-                         (IRIS.CLOSEOBJ \IRISSTREAM))
-                  (PRINTOUT IV.PROMPTWINDOW "...done" T])
-
-(IV.NEW.SCENE.FROM.USER
-  [LAMBDA NIL                                                (* gbn "20-Nov-85 23:21")
-          
-          (* * Reads a new scene from the user. Returns NIL if the scene is not 
-          completed. Sets the scene menu to nil to cause it to be rebuilt when a new 
-          scene is successfully read)
-
-    (PROG (NAME DRAWFN OBJNO SCENE)
-          (SETQ NAME (IV.GETINPUT "Scene Name?"))
-          (if (NOT NAME)
-              then (RETURN))
-          (SETQ SCENE (create IRISSCENE
-                             NAME _ NAME
-                             OBJNO _ (IRIS.CONS.OBJNO)))
-          (replace (IRISSCENE DRAWFN) of SCENE with (SETQ DRAWFN (IV.READ 
-                                                                     "Form to eval to create scene? "
-                                                                        )))
-          (if (NOT DRAWFN)
-              then (IRIS.MAKEOBJ (fetch (IRISSCENE OBJNO) of SCENE)
-                          \IRISSTREAM)
-                   (IV.GETINPUT "Make object, then type RETURN")
-                   (IRIS.CLOSEOBJ \IRISSTREAM))
-          (push IV.SCENES SCENE)
-          (SETQ IV.SCENES.MENU NIL)
-          (RETURN SCENE])
-
-(IV.REDEFINE.SCENE
-  [LAMBDA (ITEM BUTTONS WINDOW)                              (* ; "Edited 29-Jan-87 01:20 by gbn")
-    (LET ((SCENE (IV.CHOOSE.SCENE)))
-         (if (MOUSECONFIRM (CONCAT "Redefine " (fetch NAME of SCENE))
-                    NIL IV.PROMPTWINDOW)
-             then (IRIS.DELOBJ (fetch OBJNO of SCENE)
-                         \IRISSTREAM)
-                  (REPLACE OBJNO OF SCENE WITH (IRIS.CONS.OBJNO))
-                  (IV.ENSURE.SCENE SCENE])
-
-(IV.CHOOSE.SCENE
-  [LAMBDA NIL                                                (* edited%: "12-Dec-85 20:58")
-    (MENU (OR IV.SCENES.MENU (IV.BUILD.SCENES.MENU])
-
-(IV.BUILD.SCENES.MENU
-  [LAMBDA NIL                                                (* ; "Edited 23-Jan-87 20:23 by gbn")
-
-(* ;;; "builds the menu used to prompt the user for scenes that can be loaded on the iris.")
-
-    (SETQ IV.SCENES.MENU (create MENU
-                                ITEMS _ (CONS '(New% Scene? (IV.NEW.SCENE.FROM.USER)
-                                                      "allows specification of a new scene")
-                                              (for ENTRY in IV.SCENES
-                                                 collect (LIST (fetch (IRISSCENE NAME) of ENTRY)
-                                                               (KWOTE ENTRY])
-
-(IV.FORGET.SCENE
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* edited%: "12-Dec-85 20:58")
-    (PROG ((NEWSCENE (IV.CHOOSE.SCENE))
-           OBJNO)
-          (if NEWSCENE
-              then (DREMOVE NEWSCENE IV.SCENES)
-                   (if (SETQ OBJNO (fetch (IRISSCENE OBJNO) of NEWSCENE))
-                       then (IRIS.DELOBJ OBJNO \IRISSTREAM))
-                   (SETQ IV.SCENES.MENU NIL])
-
-(IV.DRAW.SCENE
-  [LAMBDA NIL                                                (* gbn "21-Nov-85 02:09")
-    (OR IV.CURRENT.SCENE (ERROR "CAN'T DRAW NULL SCENE"))
-    (SELECTQ IV.MODE
-        (POLAR (IRIS.POLARVIEW IV.DIST IV.AZIM IV.INC IV.TWIST \IRISSTREAM))
-        (XLATE NIL)
-        (LOOKAT (if (NOT (AND (EQUAL IV.OBJPT LASTIV.OBJPT)
-                              (EQUAL IV.VIEWPT LASTIV.VIEWPT)))
-                    then                                     (* setup the viewing transformation, 
-                                                             since it has changed)
-                         (IRIS.LOOKAT (fetch IVX of IV.VIEWPT)
-                                (fetch IVX of IV.VIEWPT)
-                                (fetch IVY of IV.VIEWPT)
-                                (fetch IVZ of IV.OBJPT)
-                                (fetch IVY of IV.OBJPT)
-                                (fetch IVZ of IV.OBJPT)
-                                IV.TWIST \IRISSTREAM)
-                         (SETQ LASTIV.OBJPT IV.OBJPT)
-                         (SETQ LASTIV.VIEWPT IV.VIEWPT)))
-        (ERROR "UNKNOWN IV.MODE"))
-    (if \IV.BACKGROUND
-        then (\CLEAR.IRIS \IV.BACKGROUND))
-    (IRIS.CALLOBJ (fetch (IRISSCENE OBJNO) of IV.CURRENT.SCENE)
-           \IRISSTREAM)
-    (if \IV.DRAW.AXES
-        then (IRIS.CALLOBJ (fetch (IRISSCENE OBJNO) of AXES.SCENE)
-                    \IRISSTREAM))
-    (IRIS.SWAPBUFFERS \IRISSTREAM)
-    (ALIGN \IRISSTREAM])
-
-(IV.SET.CURRENT.SCENE
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited  4-Feb-87 19:28 by gbn")
-    (PROG ([NEWSCENE (MENU (OR IV.SCENES.MENU (IV.BUILD.SCENES.MENU]
-           SCENEITEM)
-          (if NEWSCENE
-              then (SETQ IV.CURRENT.SCENE NEWSCENE)
-                   (SETQ SCENEITEM (FM.GETITEM 'CURRENTSCENE 'FILL-INS WINDOW))
-                   (OR SCENEITEM (ERROR "SCENE ITEM NOT FOUND"))
-                   (FM.CHANGESTATE SCENEITEM (fetch (IRISSCENE NAME) of NEWSCENE)
-                          WINDOW)                            (* IV.DISPLAY.FMITEM SCENEITEM WINDOW)
-                   (IV.PROOF.SCENE SCENEITEM])
-
-(IV.SCENE.SETUP
-  [LAMBDA NIL                                                (* ; "Edited  4-Feb-87 19:22 by gbn")
-    [IF (NOT (BOUNDP 'AXES.SCENE))
-        THEN (SETQ AXES.SCENE (CREATE IRISSCENE
-                                     NAME _ 'Axes
-                                     OBJNO _ (IRIS.CONS.OBJNO)
-                                     DRAWFN _ '(DRAW.AXES 2]
-    [IF (NOT (BOUNDP 'SKULL.SCENE))
-        THEN (SETQ SKULL.SCENE (CREATE IRISSCENE
-                                      NAME _ 'Skull
-                                      OBJNO _ (IRIS.CONS.OBJNO)
-                                      DRAWFN _ '(SKULLO \IRISSTREAM]
-    (PUSHNEW IV.SCENES AXES.SCENE)
-    (PUSHNEW IV.SCENES SKULL.SCENE)
-    (SETQ IV.CURRENT.SCENE AXES.SCENE])
-)
-(DEFINEQ
-
-(DRAW.AXES
-  [LAMBDA (WIDTH COLOR)                                      (* edited%: "17-Dec-85 18:39")
-          
-          (* * draws tri-color axes with each axis being 200 in length in the positive 
-          direction)
-
-    (IRIS.PUSHATTRIBUTES \IRISSTREAM)
-    (IRIS.LINEWIDTH (OR WIDTH 5)
-           \IRISSTREAM)
-    (IRIS.COLOR (OR COLOR 1)
-           \IRISSTREAM)
-    (IRIS.MOVE 0 0 0 \IRISSTREAM)
-    (IRIS.DRAW 0 0 200 \IRISSTREAM)
-    (IRIS.CMOV 0 0 210 \IRISSTREAM)
-    (IRIS.CHARSTR "z" \IRISSTREAM)
-    (IRIS.COLOR (OR COLOR 2)
-           \IRISSTREAM)
-    (IRIS.MOVE 0 0 0 \IRISSTREAM)
-    (IRIS.DRAW 0 200 0 \IRISSTREAM)
-    (IRIS.CMOV 0 210 0 \IRISSTREAM)
-    (IRIS.CHARSTR "y" \IRISSTREAM)
-    (IRIS.COLOR (OR COLOR 3)
-           \IRISSTREAM)
-    (IRIS.MOVE 0 0 0 \IRISSTREAM)
-    (IRIS.DRAW 200 0 0 \IRISSTREAM)
-    (IRIS.CMOV 210 0 0 \IRISSTREAM)
-    (IRIS.CHARSTR "x" \IRISSTREAM)
-    (IRIS.POPATTRIBUTES \IRISSTREAM)
-    (F])
-
-(F
-  [LAMBDA NIL                                                (* edited%: "13-Dec-85 18:35")
-    (SPP.FORCEOUTPUT IRISCONN])
-
-(IV.CLEARIRIS
-  [LAMBDA NIL                                                (* gbn "21-Nov-85 00:51")
-    (DSPCOLOR (DICOLOR.FROM.USER T)
-           \IRISSTREAM)
-    (IRIS.CLEAR \IRISSTREAM)
-    (IRIS.SWAPBUFFERS \IRISSTREAM)
-    (F])
-
-(IV.DOWN
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* edited%: "17-Dec-85 16:01")
-    (LET NIL (SELECTQ IV.MODE
-                 (POLAR (add IV.AZIM IV.THETA))
-                 (XLATE (IRIS.TRANSLATE 0 (IMINUS IV.DXLATE)
-                               0 \IRISSTREAM))
-                 (PROGN (add (fetch IVX of IV.OBJPT)
-                             IV.DXLATE)))
-         (IV.DRAW.SCENE])
-
-(IV.GETINPUT
-  [LAMBDA (MSG)                                              (* edited%: "21-Aug-85 04:10")
-    (CLEARW IV.PROMPTWINDOW)
-    (PROG1 (PROMPTFORWORD MSG NIL NIL IV.PROMPTWINDOW NIL 'TTY NIL NIL)
-           (WINDOWPROP IV.PROMPTWINDOW 'PROCESS NIL)         (* some random process circularity fix)
-           ])
-
-(IV.READ
-  [LAMBDA (PROMPT)                                           (* gbn "20-Nov-85 23:19")
-    (CLEARW IV.PROMPTWINDOW)
-    (PRINTOUT IV.PROMPTWINDOW PROMPT)
-    (RESETFORM (TTYDISPLAYSTREAM IV.PROMPTWINDOW)
-           (LISPXREAD T T])
-
-(IV.HOME
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* edited%: "17-Dec-85 18:31")
-    (PROG [(R (FM.ITEMPROP ITEM 'REGION]
-          (\FM.HIGHLIGHTITEM ITEM WINDOW)
-          (SELECTQ IV.MODE
-              (XLATE (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -5000 5000 IRISCONN)
-                     (IV.VIEW))
-              (POLAR (IRIS.POLARVIEW 500 0 0 0 \IRISSTREAM))
-              (LOOKAT NIL)
-              (ERROR "UNKNOWN MODE"))
-          (IV.DRAW.SCENE)
-          (F])
-
-(IV.2D.HOME
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 27-Jan-87 18:43 by gbn")
-    (PROG [(R (FM.ITEMPROP ITEM 'REGION]
-          (\FM.HIGHLIGHTITEM ITEM WINDOW)
-          (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -1000 1000 IRISCONN)
-          (IV.DRAW.SCENE)
-          (F])
-
-(IV.PHOME
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 27-Jan-87 18:43 by gbn")
-    (PROG [(R (FM.ITEMPROP ITEM 'REGION]
-          (\FM.HIGHLIGHTITEM ITEM WINDOW)
-          (IV.PHOME.AUX)
-          (F])
-
-(IV.PHOME.AUX
-  [LAMBDA NIL                                                (* ; "Edited 27-Jan-87 18:31 by gbn")
-    (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -5000 5000 IRISCONN)
-    (IRIS.VIEWPORT 0 IRIS.XMAXSCREEN 0 IRIS.YMAXSCREEN IRISCONN)
-    (IRIS.PERSPECTIVE (IRIS.DEGREES 45)
-           (IQUOTIENT IRIS.XMAXSCREEN IRIS.YMAXSCREEN)
-           0 10000 IRISCONN)                                 (* ; 
-                                           "The projection (world-space -> eye-space) transformation")
-    (IRIS.POLARVIEW 500 (IRIS.DEGREES 45)
-           (IRIS.DEGREES 45)
-           0 IRISCONN)                                       (* ; 
-                                      "the viewing (placing eye-space in world-space) transformation")
-    (IV.DRAW.SCENE])
-
-(IV.VIEW
-  [LAMBDA (Z)                                                (* edited%: "17-Dec-85 18:32")
-    (IRIS.PERSPECTIVE (IRIS.DEGREES 45)
-           (IQUOTIENT IRIS.XMAXSCREEN IRIS.YMAXSCREEN)
-           0 10000 IRISCONN)
-    (IRIS.POLARVIEW (OR Z 1000)
-           (IRIS.DEGREES 90)
-           (IRIS.DEGREES 90)
-           0 IRISCONN])
-
-(IV.LEFT
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* edited%: "17-Dec-85 15:59")
-    (LET NIL (SELECTQ IV.MODE
-                 (POLAR (add IV.AZIM IV.THETA))
-                 (XLATE (IRIS.TRANSLATE (IMINUS IV.DXLATE)
-                               0 0 \IRISSTREAM))
-                 (PROGN (add (fetch IVX of IV.OBJPT)
-                             IV.DXLATE)))
-         (IV.DRAW.SCENE])
-
-(IV.RIGHT
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 27-Jan-87 17:55 by gbn")
-    (LET ((MOVE (IF (SHIFTDOWNP 'SHIFT)
-                    THEN (IMINUS IV.DXLATE)
-                  ELSE IV.DXLATE)))
-         (IRIS.TRANSLATE MOVE 0 0 \IRISSTREAM)
-         (IV.DRAW.SCENE])
-
-(IV.ROTX
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* edited%: "17-Dec-85 16:03")
-    (IRIS.ROTATE (if (SHIFTDOWNP 'SHIFT)
-                     then (MINUS IV.THETA)
-                   else IV.THETA)
-           IRIS.XAXIS \IRISSTREAM)
-    (IV.DRAW.SCENE])
-
-(IV.DOUBLEBUFFER
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 29-Jan-87 00:03 by gbn")
-    (PROG [(STATE (FM.ITEMPROP ITEM 'STATE]
-          (if STATE
-              then (IRIS.DOUBLEBUFFER \IRISSTREAM)
-                   (IRIS.FRONTBUFFER 0)
-                   (IRIS.BACKBUFFER 1)
-                   (IV.PROMPTPRINT "Double buffering.")
-            else (IRIS.SINGLEBUFFER \IRISSTREAM)
-                 (IRIS.FRONTBUFFER 1)
-                 (IRIS.BACKBUFFER 0)
-                 (IV.PROMPTPRINT "Single buffering."))
-          (IRIS.GCONFIG IRISCONN])
-
-(IV.ROTY
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* edited%: "17-Dec-85 16:04")
-    (IRIS.ROTATE (if (SHIFTDOWNP 'SHIFT)
-                     then (MINUS IV.THETA)
-                   else IV.THETA)
-           IRIS.YAXIS \IRISSTREAM)
-    (IV.DRAW.SCENE])
-
-(IV.ROTZ
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* edited%: "17-Dec-85 16:02")
-    (IRIS.ROTATE (if (SHIFTDOWNP 'SHIFT)
-                     then (MINUS IV.THETA)
-                   else IV.THETA)
-           IRIS.ZAXIS \IRISSTREAM)
-    (IV.DRAW.SCENE])
-
-(IV.SWAPBUFFERS
-  [LAMBDA NIL                                                (* gbn "14-Nov-85 18:27")
-    (IRIS.SWAPBUFFERS \IRISSTREAM)
-    (SPP.FORCEOUTPUT IRISCONN])
-
-(IV.UP
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 27-Jan-87 17:55 by gbn")
-    (LET ((MOVE (IF (SHIFTDOWNP 'SHIFT)
-                    THEN (IMINUS IV.DXLATE)
-                  ELSE IV.DXLATE)))
-         (IRIS.TRANSLATE 0 MOVE 0 \IRISSTREAM)
-         (IV.DRAW.SCENE])
-
-(IV.THETA
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 27-Jan-87 01:13 by gbn")
-          
-          (* controls whether or not the background is cleared before drawing a scene)
-
-    (LET ((NEW (RNUMBER "Enter new rotation in degrees")))
-         (if NEW
-             then (SETQ IV.THETA (ITIMES 10 NEW))
-                  (FM.CHANGESTATE (FM.GETITEM 'THETA 'FILL-INS WINDOW)
-                         NEW WINDOW])
-
-(IV.AXES
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 29-Jan-87 00:17 by gbn")
-                                                             (* ; 
-                                               "controls whether or not axes are drawn in the scene.")
-    (if (FM.ITEMPROP ITEM 'STATE)
-        then (SETQ \IV.DRAW.AXES T)
-             (IV.ENSURE.SCENE AXES.SCENE)
-      else (SETQ \IV.DRAW.AXES))
-    (IV.DRAW.SCENE])
-
-(IV.BACKGROUND
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 28-Jan-87 17:01 by gbn")
-                                                             (* ; 
-                           "controls whether or not the background is cleared before drawing a scene")
-    (LET ((NAME-OR-RGB (DICOLOR.FROM.USER T)))
-         (SETQ \IV.BACKGROUND (if NAME-OR-RGB
-                                  then (\IRIS.ASSURE.COLOR NAME-OR-RGB \IRISSTREAM)
-                                else NIL))
-         (FM.CHANGELABEL (FM.GETITEM 'BACKGROUND 'FILL-INS WINDOW)
-                (if NAME-OR-RGB
-                    then (L-CASE (MKSTRING NAME-OR-RGB))
-                  else "none")
-                WINDOW)
-         (IV.DRAW.SCENE])
-
-(IV.TOWARD
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 27-Jan-87 17:55 by gbn")
-    (LET ((MOVE (IF (SHIFTDOWNP 'SHIFT)
-                    THEN (IMINUS IV.DXLATE)
-                  ELSE IV.DXLATE)))
-         (IRIS.TRANSLATE 0 0 MOVE \IRISSTREAM)
-         (IV.DRAW.SCENE])
-
-(IV.AWAY
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* edited%: "17-Dec-85 15:39")
-    (LET NIL (SELECTQ IV.MODE
-                 (POLAR (add IV.AZIM IV.THETA))
-                 (XLATE (IRIS.TRANSLATE 0 0 (MINUS IV.DXLATE)
-                               \IRISSTREAM))
-                 (PROGN (add (fetch IVX of IV.OBJPT)
-                             IV.DXLATE)))
-         (IV.DRAW.SCENE])
-
-(IV.DSPCOLOR
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 28-Jan-87 17:02 by gbn")
-
-(* ;;; "sets the dspcolor for the stream (foreground color)")
-
-    (LET ((RGB (DICOLOR.FROM.USER T)))
-         (if RGB
-             then (DSPCOLOR RGB \IRISSTREAM)
-                  (FM.CHANGESTATE (FM.GETITEM 'DSPCOLOR 'FILL-INS WINDOW)
-                         (if RGB
-                             then (L-CASE (MKSTRING RGB))
-                           else "none")
-                         WINDOW)
-           else NIL])
-
-(IV.DELTA
-  [LAMBDA (ITEM WINDOW BUTTONS)                              (* ; "Edited 27-Jan-87 01:13 by gbn")
-    (LET ((NEW (RNUMBER "Enter new translation value")))
-         (if NEW
-             then (FM.CHANGESTATE (FM.GETITEM 'DELTA 'FILL-INS WINDOW)
-                         (SETQ IV.DXLATE NEW)
-                         WINDOW])
-
-(IV.VIEW.CHANGED
-  [LAMBDA NIL                                                (* ; "Edited  3-Feb-87 00:00 by gbn")
-    'JUNK])
-
-(IV.NEWSTREAM
-  [LAMBDA (ITEM BUTTONS WINDOW)                              (* ; "Edited 29-Jan-87 00:59 by gbn")
-    (IF (MOUSECONFIRM "kill old stream?  (lose fonts, etc.)" "left to confirm" IV.PROMPTWINDOW)
-        THEN (SETQ IRISCONN NIL)
-             (OPENIRISSTREAM IRISNSHOSTNUMBER])
-
-(IV.PROMPTPRINT
-  [LAMBDA ARGS                                               (* edited%: "21-Aug-85 06:10")
-    (CLEARW IV.PROMPTWINDOW)
-    (for F from 1 to ARGS do (PRIN1 (ARG ARGS F)
-                                    IV.PROMPTWINDOW])
-
-(IV.PROOF.SKETCH
-  [LAMBDA (ARGS |...|)                                       (* edited%: "21-Aug-85 10:39")
-    (IV.PROMPTPRINT "SKETCHing...")
-    (IRIS.SKETCH (PROG1 NIL (GETPOSITION)))
-    (ALIGN \IRISSTREAM)
-    (IV.PROMPTPRINT "done"])
-
-(IV.INIT
-  [LAMBDA (MENU-POSITION)                                    (* ; "Edited  4-Feb-87 19:23 by gbn")
-
-(* ;;; "uses freemenu to build the view controller menu ")
-
-    (LET NIL (if (BOUNDP 'IV.DEMOW)
-                 then (CLOSEW IV.DEMOW))
-         (MOVEW (SETQ IV.DEMOW (FREEMENU *IV-MENUDESC*))
-                MENU-POSITION)
-         (SETQ IV.PROMPTWINDOW (GETPROMPTWINDOW IV.DEMOW 2))
-         (IV.NEWSTREAM NIL NIL NIL)                          (* ; "INIT LOOKAT PARAMS")
-         (SETQ LASTIV.OBJPT (create IVPOS
-                                   IVX _ 0
-                                   IVY _ 0
-                                   IVZ _ 1))
-         (SETQ IV.OBJPT (create IVPOS
-                               IVX _ 0
-                               IVY _ 0
-                               IVZ _ 0))
-         (SETQ IV.VIEWPT (create IVPOS
-                                IVX _ 0
-                                IVY _ 0
-                                IVZ _ -1000))
-         (SETQ LASTIV.VIEWPT (create IVPOS
-                                    IVX _ 0
-                                    IVY _ 0
-                                    IVZ _ -1001))            (* ; 
-                                                            "The amount that a translate should move")
-         (SETQ IV.DXLATE 10)                                 (* ; "INIT POLAR PARAMS")
-         (SETQ IV.DIST 500)
-         (SETQ IV.AZIM (SETQ IV.INC (SETQ IV.TWIST 0)))
-         (SETQ IV.MODE 'XLATE)
-         (IRIS.DOUBLEBUFFER \IRISSTREAM)
-         (IV.SCENE.SETUP)
-         (IV.ENSURE.SCENE AXES.SCENE)
-         (IV.PHOME.AUX)
-         (IV.DRAW.SCENE)
-         (IV.DRAW.SCENE)
-         (IRIS.GCONFIG \IRISSTREAM])
-
-(\CLEAR.IRIS
-  [LAMBDA (COLOR)                                            (* gbn "21-Nov-85 02:10")
-    (IRIS.PUSHATTRIBUTES \IRISSTREAM)
-    (IRIS.COLOR (\IRIS.ASSURE.COLOR COLOR \IRISSTREAM))
-    (IRIS.CLEAR \IRISSTREAM)
-    (IRIS.POPATTRIBUTES])
-
-(IRIS.DEGREES
-  [LAMBDA (DEGREES)                                          (* edited%: "13-Dec-85 18:32")
-          
-          (* Takes an angle in degrees and returns an angle as the iris likes it
-          (tenths))
-
-    (FIX (TIMES DEGREES 10])
-)
-(DEFINEQ
-
-(IV.ITEMMAPFN
-  [LAMBDA (ITEM)                                             (* edited%: "21-Aug-85 02:05")
-    (if (EQUAL (FM.ITEMPROP ITEM 'NAME%:)
-               NAME)
-        then (SETQ RESULT ITEM])
-
-(IV.DISPLAY.FMITEM
-  [LAMBDA (ITEM WINDOW)                                      (* gbn "15-Nov-85 12:25")
-    (HELP)(* PROG ((STREAM (fetch (FREEMENU STREAM) of
-          (WINDOWPROP WINDOW (QUOTE FREEMENU)))) (FONT
-          (FM.ITEMPROP ITEM (QUOTE FONT%:))) (REGION
-          (FM.ITEMPROP ITEM (QUOTE REGION))) (LABEL
-          (FM.ITEMPROP ITEM (QUOTE LABEL)))) (DSPDESTINATION
-          (FM.ITEMPROP ITEM (QUOTE BITMAP)) STREAM)
-          (DSPXPOSITION 0 STREAM) (DSPYPOSITION (FONTPROP FONT
-          (QUOTE DESCENT)) STREAM) (DSPFONT FONT STREAM)
-          (PRIN1 LABEL STREAM) (replace (REGION WIDTH) of REGION with
-          (STRINGWIDTH LABEL FONT)) (FM.DISPLAYITEM ITEM WINDOW)
-          (BLTSHADE WHITESHADE WINDOW (IPLUS (fetch
-          (REGION LEFT) of REGION) (fetch (REGION WIDTH) of REGION))
-          (fetch (REGION BOTTOM) of REGION) (IDIFFERENCE
-          (BITMAPWIDTH (FM.ITEMPROP ITEM (QUOTE BITMAP)))
-          (fetch (REGION WIDTH) of REGION)) (BITMAPHEIGHT
-          (FM.ITEMPROP ITEM (QUOTE BITMAP)))))
-    ])
-)
-(DECLARE%: EVAL@COMPILE
-
-(RECORD IRISSCENE (NAME DRAWFN OBJNO)
-                  OBJNO _ (IRIS.CONS.OBJNO))
-
-(RECORD IVPOS (IVX IVY IVZ))
-)
-
-(RPAQQ HANDWIDTH 48)
-
-(RPAQQ IRIS.XAXIS 88)
-
-(RPAQQ IRIS.ZAXIS 90)
-
-(RPAQQ IV.DXLATE 10)
-
-(RPAQQ IV.MODE XLATE)
-
-(RPAQQ IV.OBJPT (0 0 0))
-
-(RPAQQ IV.THETA 50)
-
-(RPAQQ IV.TRACE.FNS (IRIS.POPMATRIX IRIS.ROTATE IRIS.TRANSLATE))
-
-(RPAQQ IV.TWIST 0)
-
-(RPAQQ IV.VIEWPT (0 0 -1000))
-
-(RPAQQ LASTIV.OBJPT (0 0 1))
-
-(RPAQQ LASTIV.VIEWPT (0 0 -1001))
-
-(RPAQQ \IV.DRAW.AXES NIL)
-
-(RPAQQ \IV.BACKGROUND NIL)
-(IV.SCENE.SETUP)
-(IV.BUILD.SCENES.MENU)
-(DEFINEQ
-
-(SKULLO
-  [LAMBDA (*STREAM*)
-    (FILLCIRCLE 529 377 192.0 '(NIL (255 0 0)) *STREAM*)
-    (DRAWCIRCLE 529 377 192.0 '(ROUND 1 (0 255 255)) 'NIL *STREAM*)
-    (FILLPOLYGON '((530 . 568)
-                   (476 . 562)
-                   (426 . 540)
-                   (380 . 500)
-                   (349 . 445)
-                   (337 . 386)
-                   (344 . 323)
-                   (383 . 250)
-                   (436 . 208)
-                   (484 . 190)
-                   (530 . 184)) '(NIL (0 0 255)) *STREAM*)
-    (DRAWLINE 530 568 476 562 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (DRAWLINE 476 562 426 540 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (DRAWLINE 426 540 380 500 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (DRAWLINE 380 500 349 445 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (DRAWLINE 349 445 337 386 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (DRAWLINE 337 386 344 323 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (DRAWLINE 344 323 383 250 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (DRAWLINE 383 250 436 208 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (DRAWLINE 436 208 484 190 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (DRAWLINE 484 190 530 184 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (DRAWLINE 530 184 530 568 '1 'NIL *STREAM* '(0 255 255) 'NIL)
-    (FILLCIRCLE 529 417 152.0526 '(NIL (255 255 255)) *STREAM*)
-    (DRAWCIRCLE 529 417 152.0526 '(ROUND 1 (255 255 255)) 'NIL *STREAM*)
-    (FILLPOLYGON '((639 . 312)
-                   (642 . 301)
-                   (642 . 291)
-                   (640 . 283)
-                   (635 . 276)
-                   (629 . 273)
-                   (620 . 272)
-                   (611 . 294)) '(NIL (255 255 255)) *STREAM*)
-    (DRAWLINE 639 312 642 301 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 642 301 642 291 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 642 291 640 283 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 640 283 635 276 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 635 276 629 273 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 629 273 620 272 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 620 272 611 294 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 611 294 639 312 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (FILLPOLYGON '((446 . 300)
-                   (439 . 271)
-                   (439 . 254)
-                   (440 . 245)
-                   (446 . 236)
-                   (455 . 231)
-                   (465 . 227)
-                   (529 . 220)
-                   (602 . 227)
-                   (611 . 229)
-                   (618 . 236)
-                   (622 . 245)
-                   (622 . 256)
-                   (620 . 271)
-                   (615 . 302)) '(NIL (255 255 255)) *STREAM*)
-    (DRAWLINE 446 300 439 271 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 439 271 439 254 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 439 254 440 245 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 440 245 446 236 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 446 236 455 231 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 455 231 465 227 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 465 227 529 220 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 529 220 602 227 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 602 227 611 229 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 611 229 618 236 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 618 236 622 245 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 622 245 622 256 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 622 256 620 271 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 620 271 615 302 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 615 302 446 300 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (FILLPOLYGON '((468 . 228)
-                   (466 . 222)
-                   (468 . 216)
-                   (474 . 218)
-                   (478 . 212)
-                   (481 . 213)
-                   (486 . 202)
-                   (493 . 205)
-                   (499 . 194)
-                   (505 . 198)
-                   (514 . 186)
-                   (522 . 191)
-                   (530 . 187)
-                   (538 . 192)
-                   (546 . 186)
-                   (554 . 192)
-                   (559 . 190)
-                   (566 . 196)
-                   (572 . 194)
-                   (578 . 202)
-                   (584 . 201)
-                   (589 . 210)
-                   (593 . 209)
-                   (598 . 214)
-                   (601 . 214)
-                   (604 . 219)
-                   (600 . 226)) '(NIL (255 255 255)) *STREAM*)
-    (DRAWLINE 468 228 466 222 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 466 222 468 216 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 468 216 474 218 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 474 218 478 212 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 478 212 481 213 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 481 213 486 202 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 486 202 493 205 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 493 205 499 194 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 499 194 505 198 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 505 198 514 186 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 514 186 522 191 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 522 191 530 187 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 530 187 538 192 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 538 192 546 186 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 546 186 554 192 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 554 192 559 190 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 559 190 566 196 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 566 196 572 194 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 572 194 578 202 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 578 202 584 201 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 584 201 589 210 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 589 210 593 209 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 593 209 598 214 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 598 214 601 214 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 601 214 604 219 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 604 219 600 226 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 600 226 468 228 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (FILLPOLYGON '((422 . 310)
-                   (419 . 298)
-                   (419 . 283)
-                   (420 . 278)
-                   (424 . 274)
-                   (431 . 272)
-                   (439 . 271)
-                   (451 . 292)) '(NIL (255 255 255)) *STREAM*)
-    (DRAWLINE 422 310 419 298 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 419 298 419 283 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 419 283 420 278 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 420 278 424 274 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 424 274 431 272 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 431 272 439 271 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 439 271 451 292 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 451 292 422 310 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (FILLCIRCLE 527 419 136.0 '(NIL (255 0 0)) *STREAM*)
-    (DRAWCIRCLE 527 419 136.0 '(ROUND 2 (255 255 255)) 'NIL *STREAM*)
-    (FILLPOLYGON '((564 . 550)
-                   (582 . 544)
-                   (609 . 527)
-                   (632 . 506)
-                   (650 . 478)
-                   (662 . 441)
-                   (664 . 404)
-                   (654 . 369)
-                   (638 . 340)
-                   (616 . 316)
-                   (591 . 299)
-                   (565 . 286)
-                   (532 . 280)
-                   (490 . 286)) '(NIL (0 0 255)) *STREAM*)
-    (DRAWLINE 564 550 582 544 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 582 544 609 527 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 609 527 632 506 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 632 506 650 478 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 650 478 662 441 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 662 441 664 404 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 664 404 654 369 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 654 369 638 340 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 638 340 616 316 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 616 316 591 299 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 591 299 565 286 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 565 286 532 280 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 532 280 490 286 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 490 286 564 550 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (FILLPOLYGON '((564 . 550)
-                   (560 . 532)
-                   (568 . 530)
-                   (548 . 492)
-                   (574 . 492)
-                   (536 . 432)
-                   (572 . 433)
-                   (522 . 378)
-                   (559 . 378)
-                   (492 . 286)
-                   (510 . 362)
-                   (482 . 363)
-                   (518 . 418)
-                   (496 . 418)
-                   (542 . 480)
-                   (520 . 480)
-                   (554 . 525)
-                   (545 . 524)) '(NIL (255 255 255)) *STREAM*)
-    (DRAWLINE 564 550 560 532 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 560 532 568 530 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 568 530 548 492 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 548 492 574 492 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 574 492 536 432 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 536 432 572 433 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 572 433 522 378 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 522 378 559 378 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 559 378 492 286 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 492 286 510 362 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 510 362 482 363 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 482 363 518 418 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 518 418 496 418 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 496 418 542 480 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 542 480 520 480 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 520 480 554 525 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 554 525 545 524 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWLINE 545 524 564 550 '1 'NIL *STREAM* '(255 255 255) 'NIL)
-    (DRAWCIRCLE 529 417 136.0 '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((420 . 311)
-                 (390 . 354)
-                 (377 . 415)
-                 (387 . 470)
-                 (409 . 511)
-                 (444 . 542)
-                 (488 . 563)
-                 (528 . 569)
-                 (581 . 559)
-                 (630 . 531)
-                 (657 . 498)
-                 (677 . 453)
-                 (679 . 392)
-                 (662 . 342)
-                 (640 . 312)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((565 . 547)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 565 547 547 522 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((547 . 522)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 547 522 555 522 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((555 . 522)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 555 522 522 478 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((522 . 478)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 522 478 545 479 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((545 . 479)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 545 479 499 416 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((499 . 416)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 499 416 521 416 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((521 . 416)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 521 416 483 362 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((483 . 362)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 483 362 512 360 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((512 . 360)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 512 360 493 285 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((493 . 285)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((566 . 548)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 566 548 562 529 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((562 . 529)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 562 529 570 529 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((570 . 529)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 570 529 550 490 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((550 . 490)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 550 490 575 490 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((575 . 490)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 575 490 538 430 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((538 . 430)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 538 430 573 431 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((573 . 431)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 573 431 526 377 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((526 . 377)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 526 377 561 376 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((561 . 376)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWLINE 561 376 493 285 '2 'NIL *STREAM* '(0 0 0) 'NIL)
-    (DRAWCURVE '((493 . 285)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCIRCLE 529 377 192.0 '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((478 . 260)
-                 (471 . 258)
-                 (462 . 256)
-                 (459 . 268)
-                 (462 . 283)
-                 (457 . 289)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((513 . 256)
-                 (520 . 260)
-                 (508 . 266)
-                 (490 . 267)
-                 (481 . 264)
-                 (478 . 260)
-                 (486 . 258)
-                 (499 . 253)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((589 . 261)
-                 (593 . 261)
-                 (605 . 265)
-                 (605 . 273)
-                 (605 . 285)
-                 (605 . 293)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((549 . 253)
-                 (545 . 257)
-                 (545 . 265)
-                 (561 . 267)
-                 (569 . 267)
-                 (577 . 265)
-                 (585 . 261)
-                 (589 . 261)
-                 (581 . 257)
-                 (573 . 257)
-                 (561 . 253)
-                 (553 . 253)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((638 . 312)
-                 (640 . 302)
-                 (641 . 291)
-                 (639 . 280)
-                 (629 . 273)
-                 (617 . 271)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((619 . 271)
-                 (621 . 256)
-                 (620 . 240)
-                 (611 . 230)
-                 (602 . 226)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((438 . 271)
-                 (438 . 253)
-                 (442 . 240)
-                 (453 . 231)
-                 (465 . 227)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((421 . 310)
-                 (418 . 294)
-                 (420 . 276)
-                 (431 . 271)
-                 (436 . 271)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((534 . 240)
-                 (533 . 234)
-                 (534 . 230)
-                 (539 . 226)
-                 (543 . 232)
-                 (540 . 235)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((527 . 242)
-                 (528 . 236)
-                 (527 . 229)
-                 (520 . 227)
-                 (521 . 234)
-                 (524 . 238)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((465 . 226)
-                 (466 . 219)
-                 (469 . 215)
-                 (472 . 218)
-                 (473 . 223)
-                 (470 . 228)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((474 . 222)
-                 (475 . 215)
-                 (478 . 211)
-                 (481 . 214)
-                 (482 . 219)
-                 (479 . 224)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((483 . 219)
-                 (486 . 222)
-                 (493 . 219)
-                 (493 . 213)
-                 (493 . 206)
-                 (486 . 203)
-                 (482 . 209)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((494 . 216)
-                 (496 . 219)
-                 (501 . 218)
-                 (505 . 213)
-                 (505 . 203)
-                 (505 . 199)
-                 (502 . 195)
-                 (497 . 195)
-                 (495 . 200)
-                 (494 . 205)
-                 (494 . 210)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((507 . 209)
-                 (510 . 213)
-                 (517 . 212)
-                 (520 . 206)
-                 (521 . 199)
-                 (521 . 193)
-                 (519 . 189)
-                 (513 . 186)
-                 (509 . 190)
-                 (506 . 196)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((523 . 208)
-                 (526 . 212)
-                 (533 . 211)
-                 (536 . 205)
-                 (537 . 198)
-                 (537 . 192)
-                 (535 . 188)
-                 (529 . 185)
-                 (525 . 189)
-                 (522 . 195)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((539 . 208)
-                 (542 . 212)
-                 (549 . 211)
-                 (552 . 205)
-                 (553 . 198)
-                 (553 . 192)
-                 (551 . 188)
-                 (545 . 185)
-                 (541 . 189)
-                 (538 . 195)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((553 . 212)
-                 (555 . 215)
-                 (560 . 214)
-                 (564 . 209)
-                 (564 . 199)
-                 (564 . 195)
-                 (561 . 191)
-                 (556 . 191)
-                 (554 . 196)
-                 (553 . 201)
-                 (553 . 206)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((565 . 215)
-                 (567 . 218)
-                 (572 . 217)
-                 (576 . 212)
-                 (576 . 202)
-                 (576 . 198)
-                 (573 . 194)
-                 (568 . 194)
-                 (566 . 199)
-                 (565 . 204)
-                 (565 . 209)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((578 . 217)
-                 (581 . 220)
-                 (588 . 217)
-                 (588 . 211)
-                 (588 . 204)
-                 (581 . 201)
-                 (577 . 207)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((588 . 220)
-                 (589 . 213)
-                 (592 . 209)
-                 (595 . 212)
-                 (596 . 217)
-                 (593 . 222)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*)
-    (DRAWCURVE '((596 . 224)
-                 (597 . 217)
-                 (600 . 213)
-                 (603 . 216)
-                 (604 . 221)
-                 (601 . 226)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*])
-)
-
-
-
-(* ;; "The order of these variables is important.")
-
-
-(CL:DEFPARAMETER *IV-SCENES-MENUDESC* `(NIL ((LABEL "Draw Scene" SELECTEDFN IV.PROOF.SCENE HJUSTIFY 
-                                                    CENTER))
-                                            ((LABEL "Forget Scene" SELECTEDFN IV.FORGET.SCENE 
-                                                    HJUSTIFY CENTER))
-                                            ((LABEL "Redefine Scene" SELECTEDFN IV.REDEFINE.SCENE 
-                                                    HJUSTIFY CENTER))) )
-
-
-(CL:DEFPARAMETER *IV-FILLINS-MENUDESC* `[(GROUP (PROPS FORMAT TABLE ID FILL-INS)
-                                                ((LABEL "Change Scene" SELECTEDFN 
-                                                        IV.SET.CURRENT.SCENE)
-                                                 (TYPE EDIT ID CURRENTSCENE LABEL "axes" MAXWIDTH 55)
-                                                 )
-                                                ((LABEL "" TYPE DISPLAY)
-                                                 (LABEL "" TYPE DISPLAY))
-                                                [(LABEL "Background:" SELECTEDFN IV.BACKGROUND)
-                                                 (TYPE EDIT ID BACKGROUND LABEL "black" SELECTEDFN 
-                                                       IV.BACKGROUND MAXWIDTH ,(STRINGWIDTH 
-                                                                                      ">background<"]
-                                                [(LABEL "Foreground:" SELECTEDFN IV.DSPCOLOR)
-                                                 (TYPE EDIT ID DSPCOLOR LABEL "red" SELECTEDFN 
-                                                       IV.DSPCOLOR MAXWIDTH ,(STRINGWIDTH 
-                                                                                    ">background<"]
-                                                [(LABEL ,IV.DELTA.LABEL SELECTEDFN IV.DELTA)
-                                                 (TYPE EDIT ID DELTA LABEL ,(MKSTRING IV.DXLATE]
-                                                ((LABEL ,IV.THETA.LABEL SELECTEDFN IV.THETA)
-                                                 (TYPE EDIT ID THETA LABEL ,(MKSTRING IV.THETA]
-   )
-
-
-(CL:DEFPARAMETER *IV-COMMANDS-MENUDESC* `[(GROUP (PROPS FORMAT ROW)
-                                                 ((LABEL "New Stream" SELECTEDFN IV.NEWSTREAM 
-                                                         HJUSTIFY CENTER))
-                                                 ((TYPE TOGGLE LABEL "Axes" SELECTEDFN IV.AXES 
-                                                        HJUSTIFY CENTER INITSTATE NIL))
-                                                 ((TYPE TOGGLE LABEL "Double Buffer" SELECTEDFN 
-                                                        IV.DOUBLEBUFFER HJUSTIFY CENTER INITSTATE T))
-                                                 ((TYPE MOMENTARY LABEL "Swap buffers" SELECTEDFN 
-                                                        IV.SWAPBUFFERS HJUSTIFY CENTER))
-                                                 ((TYPE MOMENTARY LABEL "Clear IRIS" SELECTEDFN 
-                                                        IV.CLEARIRIS HJUSTIFY CENTER))
-                                                 ((TYPE DISPLAY LABEL ""))
-                                                 ,@*IV-SCENES-MENUDESC*
-                                                 (,@*IV-FILLINS-MENUDESC*] )
-
-
-(CL:DEFPARAMETER *IV-POSITIONING-MENU-DESC* `((GROUP (PROPS FORMAT EXPLICIT COORDINATES GROUP BOX 0)
-                                                     (LABEL ,IV.TOWARD HIGHLIGHT ,IV.TOWARD.HIGHLIGHT 
-                                                            LEFT 0 BOTTOM 0 HELDFN IV.TOWARD)
-                                                     (LABEL ,IV.ROTZ HIGHLIGHT ,IV.ROTZ.HIGHLIGHT 
-                                                            LEFT ,(IPLUS -10 (BITMAPWIDTH IV.TOWARD)) 
-                                                            BOTTOM ,(BITMAPHEIGHT IV.TOWARD) HELDFN 
-                                                            IV.ROTZ)
-                                                     [TYPE DISPLAY LABEL ,IV.ROTATE LEFT
-                                                           ,(IPLUS (BITMAPWIDTH IV.TOWARD)
-                                                                   (IQUOTIENT (BITMAPWIDTH IV.ROTZ)
-                                                                          2)) BOTTOM
-                                                           ,(IPLUS (BITMAPHEIGHT IV.ROTZ)
-                                                                   (BITMAPHEIGHT IV.TOWARD]
-                                                     (LABEL ,IV.RIGHT HIGHLIGHT ,IV.RIGHT.HIGHLIGHT 
-                                                            LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD)
-                                                                         (IQUOTIENT (BITMAPWIDTH
-                                                                                     IV.ROTZ)
-                                                                                2)
-                                                                         (BITMAPWIDTH IV.ROTATE)
-                                                                         (BITMAPWIDTH IV.ROTX)) 
-                                                            BOTTOM ,(IPLUS (BITMAPHEIGHT IV.ROTZ)
-                                                                           (BITMAPHEIGHT IV.TOWARD)
-                                                                           20) HELDFN IV.RIGHT)
-                                                     (LABEL ,IV.ROTX HIGHLIGHT ,IV.ROTX.HIGHLIGHT 
-                                                            LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD)
-                                                                         (IQUOTIENT (BITMAPWIDTH
-                                                                                     IV.ROTZ)
-                                                                                2)
-                                                                         (BITMAPWIDTH IV.ROTATE)) 
-                                                            BOTTOM ,(IPLUS (BITMAPHEIGHT IV.ROTZ)
-                                                                           (BITMAPHEIGHT IV.TOWARD)) 
-                                                            HELDFN IV.ROTX)
-                                                     (LABEL ,IV.UP HIGHLIGHT ,IV.UP.HIGHLIGHT LEFT
-                                                            ,(IPLUS (BITMAPWIDTH IV.TOWARD)
-                                                                    (IQUOTIENT (BITMAPWIDTH IV.ROTZ)
-                                                                           2)
-                                                                    10) BOTTOM
-                                                            ,(IPLUS (BITMAPHEIGHT IV.TOWARD)
-                                                                    (BITMAPHEIGHT IV.ROTZ)
-                                                                    (BITMAPHEIGHT IV.ROTATE)
-                                                                    (BITMAPHEIGHT IV.ROTY)
-                                                                    -5) HELDFN IV.UP)
-                                                     (LABEL "2D-Home" DOWNFN IV.2D.HOME LEFT
-                                                            ,(FIX (TIMES 2.5 (BITMAPWIDTH IV.ROTZ))) 
-                                                            BOTTOM ,(BITMAPHEIGHT IV.TOWARD))
-                                                     [LABEL "Home" DOWNFN IV.HOME LEFT
-                                                            ,(FIX (TIMES 2.5 (BITMAPWIDTH IV.ROTZ))) 
-                                                            BOTTOM ,(IPLUS -15 (BITMAPHEIGHT 
-                                                                                      IV.TOWARD]
-                                                     [LABEL "Acute-Home" DOWNFN IV.PHOME LEFT
-                                                            ,(FIX (TIMES 2.5 (BITMAPWIDTH IV.ROTZ))) 
-                                                            BOTTOM ,(IPLUS -30 (BITMAPHEIGHT 
-                                                                                      IV.TOWARD]
-                                                     (LABEL ,IV.ROTY HIGHLIGHT ,IV.ROTY.HIGHLIGHT 
-                                                            LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD)
-                                                                         (IQUOTIENT (BITMAPWIDTH
-                                                                                     IV.ROTZ)
-                                                                                2)
-                                                                         5) BOTTOM
-                                                            ,(IPLUS (BITMAPHEIGHT IV.TOWARD)
-                                                                    (BITMAPHEIGHT IV.ROTZ)
-                                                                    (BITMAPHEIGHT IV.ROTATE)) HELDFN 
-                                                            IV.ROTY))) )
-
-
-(CL:DEFPARAMETER *IV-MENUDESC* `[(PROPS FORMAT ROW BOX 4)
-                                 ((TYPE DISPLAY LABEL "IRIS View Controller" HJUSTIFY CENTER FONT
-                                        (MODERN 10 BOLD)))
-                                 (,@*IV-POSITIONING-MENU-DESC* (GROUP (PROPS FORMAT COLUMN)
-                                                                      (,@*IV-COMMANDS-MENUDESC*]
-   )
-
-
-(PUTPROPS IRISVIEW FILETYPE :FAKE-COMPILE-FILE)
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA )
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA IV.PROMPTPRINT)
-)
-(PUTPROPS IRISVIEW COPYRIGHT ("Xerox Corporation" 1985 1987))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (11707 19606 (IV.PROOF.SCENE 11717 . 12158) (IV.ENSURE.SCENE 12160 . 13349) (
-IV.NEW.SCENE.FROM.USER 13351 . 14631) (IV.REDEFINE.SCENE 14633 . 15155) (IV.CHOOSE.SCENE 15157 . 15334
-) (IV.BUILD.SCENES.MENU 15336 . 16056) (IV.FORGET.SCENE 16058 . 16516) (IV.DRAW.SCENE 16518 . 18096) (
-IV.SET.CURRENT.SCENE 18098 . 18798) (IV.SCENE.SETUP 18800 . 19604)) (19607 33829 (DRAW.AXES 19617 . 
-20587) (F 20589 . 20727) (IV.CLEARIRIS 20729 . 20978) (IV.DOWN 20980 . 21419) (IV.GETINPUT 21421 . 
-21757) (IV.READ 21759 . 22011) (IV.HOME 22013 . 22529) (IV.2D.HOME 22531 . 22857) (IV.PHOME 22859 . 
-23110) (IV.PHOME.AUX 23112 . 23926) (IV.VIEW 23928 . 24278) (IV.LEFT 24280 . 24719) (IV.RIGHT 24721 . 
-25050) (IV.ROTX 25052 . 25354) (IV.DOUBLEBUFFER 25356 . 25967) (IV.ROTY 25969 . 26271) (IV.ROTZ 26273
- . 26575) (IV.SWAPBUFFERS 26577 . 26758) (IV.UP 26760 . 27086) (IV.THETA 27088 . 27554) (IV.AXES 27556
- . 28039) (IV.BACKGROUND 28041 . 28829) (IV.TOWARD 28831 . 29161) (IV.AWAY 29163 . 29601) (IV.DSPCOLOR
- 29603 . 30179) (IV.DELTA 30181 . 30534) (IV.VIEW.CHANGED 30536 . 30675) (IV.NEWSTREAM 30677 . 30986) 
-(IV.PROMPTPRINT 30988 . 31255) (IV.PROOF.SKETCH 31257 . 31518) (IV.INIT 31520 . 33296) (\CLEAR.IRIS 
-33298 . 33558) (IRIS.DEGREES 33560 . 33827)) (33830 35177 (IV.ITEMMAPFN 33840 . 34061) (
-IV.DISPLAY.FMITEM 34063 . 35175)) (35819 55207 (SKULLO 35829 . 55205)))))
-STOP
diff --git a/obsolete/lispusers/KOTOLOGO b/obsolete/lispusers/KOTOLOGO
deleted file mode 100644
index 3e73f0e5..00000000
--- a/obsolete/lispusers/KOTOLOGO
+++ /dev/null
@@ -1,70 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-(filecreated "17-Aug-88 03:42:15" {erinyes}<lispusers>medley>kotologo.\;1 3467   
-
-      |changes| |to:|  (vars kotologocoms)
-                       (fns kotologow))
-
-
-; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.
-
-(prettycomprint kotologocoms)
-
-(rpaqq kotologocoms ((fns kotologow \\drawlogowindowimage)))
-(defineq
-
-(kotologow
-  (lambda (string where title angledelta)                (* |edited:| " 1-AUG-83 22:55")
-                                                             (* |creates| \a |logo| |window.|)
-    (prog ((circlesize 60)
-           (logoxcenter 70)
-           (logoycenter 65)
-           (logowindowheight 180)
-           w logowindowwidth wimagewidth wimageheight (string (or string "Interlisp-D")))
-          (or angledelta (setq angledelta 23))
-          (setq wimagewidth (fix (ftimes circlesize 0.62)))
-          (setq wimageheight (fix (ftimes circlesize 0.5)))
-          (setq logowindowwidth (iplus logoxcenter 30 wimagewidth (stringwidth string
-                                                                         '(timesromand 36))))
-          (setq w (cond
-                     ((typenamep where 'window)
-                      where)
-                     (t (createw (cond
-                                    ((positionp where)
-                                     (|create| region
-                                            left _ (|fetch| (position xcoord) |of| where)
-                                            bottom _ (|fetch| (position ycoord) |of| where)
-                                            width _ logowindowwidth
-                                            height _ logowindowheight))
-                                    (t (getboxregion logowindowwidth logowindowheight nil nil nil 
-                                              "Specify location for logo window.")))
-                               (or title (concat "Copyright (c) by Xerox Corporation" "             "
-                                                (or makesysdate (date))))))))
-          (|for| angle |from| 0 |to| 270 |by| angledelta
-             |do| (\\drawlogowindowimage (iplus logoxcenter (ftimes circlesize (cos angle)))
-                             (iplus logoycenter (ftimes circlesize (sin angle)))
-                             wimagewidth wimageheight 2 w))
-          (moveto (iplus logoxcenter 10 wimagewidth)
-                 (iplus 2 (idifference logoycenter circlesize))
-                 w)
-          (dspfont '(timesromand 36)
-                 w)
-          (prin3 string w)
-          (return w))))
-
-(\\drawlogowindowimage
-  (lambda (xpos ypos width height border w)              (* |rrb| "22-FEB-82 18:04")
-                                                             (* |makes| \a |window| |image.|
-                                                           |This| |is| |part| |of| |the| |logo| 
-                                                           |drawing.|)
-    (bitblt nil nil nil w xpos ypos width height 'texture 'replace blackshade)
-    (bitblt nil nil nil w (iplus border xpos)
-           (iplus border ypos)
-           (idifference width (itimes border 2))
-           (idifference height (itimes border 3))
-           'texture
-           'replace whiteshade)))
-)
-(putprops kotologo copyright ("Xerox Corporation" 1988))
-(declare\: dontcopy
-  (filemap (nil (393 3387 (kotologow 403 . 2682) (\\drawlogowindowimage 2684 . 3385)))))
-stop
diff --git a/obsolete/lispusers/KOTOLOGO.TEDIT b/obsolete/lispusers/KOTOLOGO.TEDIT
deleted file mode 100644
index ecb4ce39..00000000
Binary files a/obsolete/lispusers/KOTOLOGO.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/LISPNERD b/obsolete/lispusers/LISPNERD
deleted file mode 100644
index b633b3ea..00000000
--- a/obsolete/lispusers/LISPNERD
+++ /dev/null
@@ -1,223 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED "30-Aug-2020 20:52:22" 
-{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>LISPNERD.;2 10365  
-
-      changes to%:  (VARS LISPNERDCOMS LISPNERDDEPENDENCIES)
-                    (PROPS (LISPNERD DEPENDENCIES))
-
-      previous date%: " 3-Aug-88 16:16:39" 
-{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>LISPNERD.;1)
-
-
-(PRETTYCOMPRINT LISPNERDCOMS)
-
-(RPAQQ LISPNERDCOMS
-       ((COMS * LISPNERDDEPENDENCIES)
-        (* must come before any FILES)
-        (FILES ANALYZER DINFO HELPSYS DICTCLIENT)
-        (FNS LISPNERD.INIT IRMNERD.PRINTSEARCH)
-        (INITVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST (IRMNERD.MAXWORDS 50))
-        (GLOBALVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST IRMNERD.MAXWORDS)
-        (FNS IRMDICT.PRINTENTRY)
-        (P (LISPNERD.INIT))))
-
-(RPAQQ LISPNERDDEPENDENCIES
-       [(* * code to make sure that the right versions of everything are loaded. The P must be 
-           executed before any FILES commands.)
-        [E (PUTPROP 'LISPNERD 'DEPENDENCIES (for FILE in (FILECOMSLST 'LISPNERD 'FILES)
-                                                 collect
-                                                 (CONS FILE (CAAR (GETPROP FILE 'FILEDATES]
-        (PROP DEPENDENCIES LISPNERD)
-        (P (for FILE FILEDATE in (GETPROP 'LISPNERD 'DEPENDENCIES)
-                do
-                [SETQ FILEDATE (CAAR (GETPROP (CAR FILE)
-                                            'FILEDATES]
-                (COND ([AND FILEDATE (CDR FILE)
-                            (ILESSP (IDATE FILEDATE)
-                                   (IDATE (CDR FILE]
-                       (* clear FILEDATES to force FILESLOAD to reload the file.)
-                       (PUTPROP (CAR FILE)
-                              'FILEDATES NIL])
-(* * code to make sure that the right versions of everything are loaded. The P must be executed 
-before any FILES commands.)
-
-
-(PUTPROPS LISPNERD DEPENDENCIES ((ANALYZER . " 9-Mar-89 15:24:58")
-                                         (DINFO . " 1-Oct-87 10:11:04")
-                                         (HELPSYS . " 1-Oct-87 13:40:16")
-                                         (DICTCLIENT)))
-
-[for FILE FILEDATE in (GETPROP 'LISPNERD 'DEPENDENCIES)
-   do [SETQ FILEDATE (CAAR (GETPROP (CAR FILE)
-                                      'FILEDATES]
-         (COND
-            ([AND FILEDATE (CDR FILE)
-                  (ILESSP (IDATE FILEDATE)
-                         (IDATE (CDR FILE]                   (* clear FILEDATES to force 
-                                                           FILESLOAD to reload the file.)
-             (PUTPROP (CAR FILE)
-                    'FILEDATES NIL]
-
-
-
-(* must come before any FILES)
-
-
-(FILESLOAD ANALYZER DINFO HELPSYS DICTCLIENT)
-(DEFINEQ
-
-(LISPNERD.INIT
-  [LAMBDA NIL                                                (* jtm%: "18-Nov-87 14:36")
-    (COND
-       ((NULL IRMDICT)
-        [Dict.Establish (SETQ IRMDICT (create Dict
-                                             dictName _ 'IRMDict
-                                             printEntryFn _ (FUNCTION IRMDICT.PRINTENTRY]
-        (PUTASSOC 'Search% IRM '((IRMNERD.PRINTSEARCH)
-                                 
-                      "Searches the Interlisp Reference Manual for entries given a list of keywords."
-                                 ) BackgroundMenuCommands)
-        (SETQ BackgroundMenu NIL])
-
-(IRMNERD.PRINTSEARCH
-  [LAMBDA (SYNONYMCLASSES)                                   (* jtm%: " 7-Apr-87 12:33")
-    (PROG (VENNDIAGRAM SELECTION MENUITEMS (MINWORD 0)
-                 (MAXWORD IRMNERD.MAXWORDS))
-          [COND
-             ((NULL SYNONYMCLASSES)
-              (CLRPROMPT)
-              (PROMPTPRINT (CHARACTER (CHARCODE CR)))
-              (SETQ SYNONYMCLASSES (PROMPTFORWORD "keywords to search on:" IRMNERD.LASTREQUEST NIL 
-                                          PROMPTWINDOW NIL NIL (CHARCODE EOL ESCAPE LF)))
-              (COND
-                 ((NULL SYNONYMCLASSES)
-                  (PROMPTPRINT "Aborted")
-                  (RETURN))
-                 (T (CLRPROMPT)))
-              (COND
-                 ((NOT (STREQUAL SYNONYMCLASSES IRMNERD.LASTREQUEST))
-                  (SETQ IRMNERD.LASTREQUEST SYNONYMCLASSES)
-                  (SETQ IRMNERD.LASTSEARCH NIL]
-          [do [SETQ VENNDIAGRAM (COND
-                                   ((AND IRMNERD.LASTSEARCH (EQ MINWORD 0))
-                                    IRMNERD.LASTSEARCH)
-                                   (T (PROMPTPRINT "
-Searching . . . ")
-                                      (DICTCLIENT.SEARCHFORWORD SYNONYMCLASSES 2 MINWORD MAXWORD
-                                             'IRMNerd]
-              (COND
-                 ((EQ MINWORD 0)                             (* cache the results in case the use 
-                                                             calls again.)
-                  (SETQ IRMNERD.LASTSEARCH VENNDIAGRAM)))
-              [COND
-                 ((NULL VENNDIAGRAM)
-                  (PROMPTPRINT "Sorry, no results.")
-                  (FLASHWINDOW PROMPTWINDOW)
-                  (RETURN))
-                 ((NULL (CDR VENNDIAGRAM))
-                  (SETQ MENUITEMS (CADAR VENNDIAGRAM)))
-                 (T (SETQ MENUITEMS (for SET in VENNDIAGRAM
-                                       collect (LIST [CONCATLIST (for ELEMENT
-                                                                    on (CAR SET)
-                                                                    collect (COND
-                                                                               ((CDR ELEMENT)
-                                                                                (CONCAT (CAR ELEMENT)
-                                                                                       " "))
-                                                                               (T (CAR ELEMENT]
-                                                     (LIST 'QUOTE (CAR SET))
-                                                     NIL
-                                                     (CONS 'SUBITEMS (CADR SET]
-              (CLRPROMPT)
-              (SETQ SELECTION (MENU (create MENU
-                                           TITLE _ "IRM Entries"
-                                           ITEMS _ MENUITEMS
-                                           CENTERFLG _ T)))
-              (COND
-                 ((NULL SELECTION)
-                  (PROMPTPRINT "
-No selection made.")
-                  (RETURN))
-                 ((LISTP SELECTION)
-                  [for TAIL CLASSNAME on SELECTION
-                     do (COND
-                           ((EQ (NTHCHARCODE (CAR TAIL)
-                                       -1)
-                                (CHARCODE +))
-                            (SETQ CLASSNAME (SUBSTRING (CAR TAIL)
-                                                   1 -2))
-                            (RPLACA TAIL (for CLASS in SYNONYMCLASSES
-                                            thereis (STREQUAL (CAR CLASS)
-                                                           CLASSNAME]
-                  (SETQ SYNONYMCLASSES SELECTION)
-                  (PROMPTPRINT "Seaching for: " SYNONYMCLASSES)
-                  (SETQ MINWORD 0)
-                  (SETQ MAXWORD IRMNERD.MAXWORDS))
-                 ((AND (EQ 1 (STRPOS ". . .+" SELECTION))
-                       (STRPOS "more" SELECTION))            (* the user asked for the next chunk.)
-                  (SETQ MINWORD (ADD1 MAXWORD))
-                  (SETQ MAXWORD (IPLUS MAXWORD IRMNERD.MAXWORDS)))
-                 ((EQ 1 (STRPOS "No more" SELECTION))
-                  (RETURN))
-                 (T (PROMPTPRINT "
-Fetching definition . . . ")
-                    (IRMDICT.PRINTENTRY NIL SELECTION)
-                    (CLRPROMPT)
-                    (RETURN]
-          (RETURN T])
-)
-
-(RPAQ? IRMDICT NIL)
-
-(RPAQ? IRMNERD.LASTSEARCH NIL)
-
-(RPAQ? IRMNERD.LASTREQUEST NIL)
-
-(RPAQ? IRMNERD.MAXWORDS 50)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS IRMDICT IRMNERD.LASTSEARCH IRMNERD.LASTREQUEST IRMNERD.MAXWORDS)
-)
-(DEFINEQ
-
-(IRMDICT.PRINTENTRY
-  [LAMBDA (DICT LEMMA)                                       (* ; "Edited 25-Jan-88 11:10 by jtm:")
-
-    (LET (FIRSTCHAR SECTION# GRAPH NODE)
-         (SETQ FIRSTCHAR (NTHCHAR LEMMA 1))
-         [COND
-            ((NUMBERP FIRSTCHAR)
-             [SETQ SECTION# (SUBSTRING LEMMA 1 (SUB1 (OR (STRPOS " " LEMMA)
-                                                         0]
-             [COND
-                ((EQ (NTHCHARCODE SECTION# -1)
-                     (CHARCODE %.))                          (* sometimes there is a trailing 
-                                                             period.)
-                 (SETQ SECTION# (SUBSTRING SECTION# 1 -2]
-             [for I from 1 to (NCHARS SECTION#) do (COND
-                                                      ((EQ (NTHCHARCODE SECTION# I)
-                                                           (CHARCODE %.))
-                                                             (* DINFO uses dashes instead of 
-                                                             periods)
-                                                       (RPLCHARCODE SECTION# I (CHARCODE -]
-             (SETQ SECTION# (MKATOM SECTION#))
-             (SETQ GRAPH (GETWINDOWUSERPROP DINFOW 'CURRENT.GRAPH))
-             [COND
-                ((NULL GRAPH)
-                 (DINFO.INIT)
-                 (SETQ GRAPH (GETWINDOWUSERPROP DINFOW 'CURRENT.GRAPH]
-             (SETQ NODE (FASSOC SECTION# (fetch (DINFOGRAPH NODELST) of GRAPH)))
-             (AND NODE (DINFO.UPDATE NODE)))
-            (T (IRM.SMART.LOOKUP (SUBSTRING LEMMA (COND
-                                                     ((EQ FIRSTCHAR '%()
-                                                      2)
-                                                     (T 1))
-                                        (SUB1 (OR (STRPOS " " LEMMA)
-                                                  0]
-         T])
-)
-
-(LISPNERD.INIT)
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (2864 8085 (LISPNERD.INIT 2874 . 3521) (IRMNERD.PRINTSEARCH 3523 . 8083)) (8332 10321 (
-IRMDICT.PRINTENTRY 8342 . 10319)))))
-STOP
diff --git a/obsolete/lispusers/LISPNERD.TEDIT b/obsolete/lispusers/LISPNERD.TEDIT
deleted file mode 100644
index a0c733ba..00000000
Binary files a/obsolete/lispusers/LISPNERD.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/LOADIRIS b/obsolete/lispusers/LOADIRIS
deleted file mode 100644
index 72a4f502..00000000
--- a/obsolete/lispusers/LOADIRIS
+++ /dev/null
@@ -1,246 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "10-May-88 00:44:06" {ERINYES}<LISPUSERS>MEDLEY>LOADIRIS.;1 15990  
-
-      previous date%: " 4-Feb-87 20:09:38" {ERINYES}<LISPUSERS>LYRIC>LOADIRIS.;1)
-
-
-(* "
-Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT LOADIRISCOMS)
-
-(RPAQQ LOADIRISCOMS ((FILES FREEMENU)
-                         (FNS LI.CIRCLES LI.LOAD LI.MAKEMENU LI.SETUP IRIS.CREATE.ICON IRIS.DOMENU 
-                              IRIS.TRY LOADIRIS INSTALLIRIS LI.TRAVEL)
-                         (VARS (IRIS.DIRECTORY '{ERIS}<IRIS>NEXT>)
-                               IRIS.MENU.COMMANDS IRISFILES LI.SETUP.ALL LI.SETUP.CLEAR 
-                               LI.SETUP.DEBUG LI.SETUP.STANDARD LI.SHADE LOCATED.IRISFILES 
-                               LOCATED.IRISPATCHFILE (LI.MENU))
-                         (BITMAPS LI.DOIT LI.IRISLOGO IRIS.ICON IRIS.ICON.MASK)
-                         (P (IRIS.CREATE.ICON)
-                            (printout T 
-                        "Boot the IRIS, then choose 'create IRISview Panel' from the IRIS icon menu." 
-                                   T))))
-(FILESLOAD FREEMENU)
-(DEFINEQ
-
-(LI.CIRCLES
-  [LAMBDA (X)                                            (* gbn " 5-Aug-85 15:25")
-    (for F to (OR X 100) do (IRIS.COLOR (RAND 0 7))
-                                       (IRIS.CIRCF (RAND 0 1000)
-                                              (RAND 0 800)
-                                              (RAND 50 200)))
-    (IRIS.GFLUSH])
-
-(LI.LOAD
-  [LAMBDA (item window button)                           (* ; "Edited  9-Jan-87 15:28 by gbn")
-    (printout PROMPTWINDOW T "[Loading Iris Files]")
-    (RESETLST [RESETSAVE (BITBLT NIL NIL NIL window NIL NIL NIL NIL 'TEXTURE 'INVERT LI.SHADE)
-                     `(BITBLT NIL NIL NIL ,window NIL NIL NIL NIL TEXTURE INVERT ,LI.SHADE]
-                                                             (* (QUOTE LIST) (QUOTE REDISPLAYW) 
-                                                           window)
-          (* ;; "This cruft seems to count on the fact that the only the buttons that are selected are in fm.getstate.  (so the list looks like (file1 t file2 t), and not (file1 t file2 nil file3 t))")
-
-           (FOR FILENAME IN (FM.GETSTATE WINDOW) WHEN (NEQ FILENAME T)
-              DO (SETQ FILENAME (PACKFILENAME 'DIRECTORY IRIS.DIRECTORY 'BODY FILENAME))
-                    (IF (FILENAMEFIELD FILENAME 'EXTENSION)
-                        THEN (LOAD FILENAME)
-                      ELSE (LOAD FILENAME 'PROP])
-
-(LI.MAKEMENU
-  [LAMBDA NIL                                            (* ; "Edited  9-Jan-87 15:30 by gbn")
-    (if (WINDOWP LI.MENU)
-        then (CLOSEW LI.MENU))
-    (SETQ LI.MENU
-     (FREEMENU `(((LABEL Setup%: TYPE DISPLAY FONT (HELVETICA 10 BOLD))
-                  (LABEL CLEAR TYPE MOMENTARY SELECTEDFN LI.SETUP)
-                  (LABEL Standard TYPE MOMENTARY SELECTEDFN LI.SETUP)
-                  (LABEL Debug TYPE MOMENTARY SELECTEDFN LI.SETUP)
-                  (LABEL ALL TYPE MOMENTARY SELECTEDFN LI.SETUP))
-                 ,@[LET* ([strLength (ADD1 (APPLY (FUNCTION MAX)
-                                                  (MAPCAR IRISFILES (FUNCTION NCHARS]
-                          (spaces (ALLOCSTRING strLength " ")))
-                         (MAPCAR IRISFILES (FUNCTION (LAMBDA (FILENAME)
-                                                       `((LABEL ,(SUBSTRING (CONCAT FILENAME ":" 
-                                                                                   spaces)
-                                                                        1 strLength) TYPE DISPLAY 
-                                                                FONT (GACHA 8 BOLD))
-                                                         (LABEL ,COMPILE.EXT ID
-                                                                ,(PACKFILENAME 'NAME FILENAME
-                                                                        'EXTENSION COMPILE.EXT) TYPE 
-                                                                TOGGLE FONT (GACHA 8 STANDARD))
-                                                         (LABEL Source ID ,FILENAME TYPE TOGGLE FONT
-                                                                (GACHA 8 STANDARD]
-                 ((LABEL "Load --" TYPE DISPLAY FONT (HELVETICA 12 BOLD))
-                  (LABEL ,LI.IRISLOGO TYPE MOMENTARY SELECTEDFN LI.LOAD MESSAGE 
-                         "Loads the selected Iris files"))) "Iris Loadup Panel"))
-    (for setup in LI.SETUP.STANDARD when (CDR setup)
-       do (FM.CHANGESTATE (FM.GETITEM (CAR setup)
-                                     NIL LI.MENU)
-                     (CDR setup)
-                     LI.MENU))
-    (printout PROMPTWINDOW T "Please put the LoadIris menu somewhere")
-    (MOVEW LI.MENU LASTMOUSEX LASTMOUSEY)
-    (MOVEW LI.MENU)
-    LI.MENU])
-
-(LI.SETUP
-  [LAMBDA (ITEM WINDOW BUTTON)                           (* ; "Edited 24-Dec-86 14:29 by gbn")
-    (FOR SETUP IN [EVALV (PACK* 'LI.SETUP. (U-CASE (FM.ITEMPROP ITEM 'LABEL]
-       DO                                                (* ; "THIS IS RIDICULOUS...")
-             (IF (EQ (FM.CHANGESTATE (FM.GETITEM (CAR SETUP)
-                                                NIL WINDOW)
-                                (CDR SETUP)
-                                WINDOW)
-                         (CDR SETUP))
-                 THEN (FM.CHANGESTATE (FM.GETITEM (CAR SETUP)
-                                                 NIL WINDOW)
-                                 (CDR SETUP)
-                                 WINDOW])
-
-(IRIS.CREATE.ICON
-  [LAMBDA (position)                                     (* ; "Edited  2-Feb-87 23:34 by gbn")
-    (if (NOT position)
-        then (printout PROMPTWINDOW T "Please position the Iris icon somewhere"))
-    (LET ((window (ICONW IRIS.ICON IRIS.ICON.MASK position)))
-         (WINDOWPROP window 'SHRINKFN 'DON'T)
-         (WINDOWPROP window 'BUTTONEVENTFN 'IRIS.DOMENU])
-
-(IRIS.DOMENU
-  [LAMBDA (window)                                       (* LeL, " 9-Sep-85 01:36")
-    (if (NOT (WINDOWPROP window 'MENU))
-        then (WINDOWPROP window 'MENU (create MENU
-                                                 ITEMS _ IRIS.MENU.COMMANDS)))
-    (MENU (WINDOWPROP window 'MENU])
-
-(IRIS.TRY
-  [LAMBDA NIL                                            (* LeL, " 4-Sep-85 15:42")
-                                                             (* opens a connection and runs two 
-                                                           dumb demos)
-    (OPEN.IRISCONN)                                          (* this defaults to the value of 
-                                                           IRISNSHOSTNUMBER)
-    (IRIS.GINIT)
-          (* must be executed before the iris is ready to accept graphic commands)
-    (for I to 5 do (LI.CIRCLES)
-                              (LI.TRAVEL])
-
-(LOADIRIS
-  [LAMBDA (options)                                      (* LeL, " 3-Sep-85 11:55")
-          (* * loads the files necessary to open a connection to the iris and use the 
-        graphics library)
-    [if (FMEMB %'DCOMS options)
-        then (MAPC LOCATED.IRISFILES (FUNCTION (LAMBDA (file)
-                                                     (LOAD? (PACK* file %'.DCOM]
-    [if (FMEMB %'SOURCES options)
-        then (MAPC LOCATED.IRISFILES (FUNCTION (LAMBDA (file)
-                                                     (LOAD? file %'PROP]
-    (if (FMEMB %'PATCHES options)
-        then (LOAD LOCATED.IRISPATCHFILE])
-
-(INSTALLIRIS
-  [LAMBDA (NODCOMS NOSOURCES)                            (* BDV "19-Jul-85 19:08")
-          (* * moves the iris files from my working dir to {eris}<iris>current>)
-    (COPYFILES IRISFILES %'{ERIS}<IRIS>CURRENT>)
-    (COPYFILES (for F in IRISFILES collect (PACK* F ".DCOM"))
-           %'{ERIS}<IRIS>CURRENT>)
-    (COPYFILES %'IRISIO.DCOM %'{ERIS}<IRIS>CURRENT>])
-
-(LI.TRAVEL
-  [LAMBDA (COLOR)                                        (* gbn " 5-Aug-85 21:33")
-                                                             (* dumb demo to try double buffering)
-    (IRIS.DOUBLEBUFFER)
-    (IRIS.GCONFIG)
-    (if (NOT COLOR)
-        then (SETQ COLOR (RAND 0 6)))
-    (for I from 5 to 1000 by 10 do (IRIS.COLOR 8)
-                                                      (IRIS.CLEAR)
-                                                      (IRIS.COLOR COLOR)
-                                                      (IRIS.CIRCF I (IQUOTIENT I 2)
-                                                             (IQUOTIENT I 5))
-                                                      (IRIS.SWAPBUFFERS))
-    (IRIS.GFLUSH)
-    (IRIS.SINGLEBUFFER)
-    (IRIS.GCONFIG])
-)
-
-(RPAQQ IRIS.DIRECTORY {ERIS}<IRIS>NEXT>)
-
-(RPAQQ IRIS.MENU.COMMANDS (("Clear IRIS" (CLEARIRIS))
-                               ("Open IRIS stream" (if (MOUSECONFIRM 
-                                                    "New stream? (lose fonts, etc.)  Left to confirm"
-                                                              )
-                                                       then
-                                                       (SETQ IRISCONN)
-                                                       (OPENIRISSTREAM)))
-                               ("Create IRISview panel" (IV.INIT))
-                               ("Enable bootserver" (if (GETD 'IRISBOOTSERVER)
-                                                        then
-                                                        (IRISBOOTSERVER T)
-                                                        else
-                                                        (PROMPTPRINT 
-                                                      "IRISNET must be loaded to use the boot server"
-                                                               ))
-                                      "Allows the Lisp Machine to boot the IRIS")
-                               ("Disable bootserver" (if (GETD 'IRISBOOTSERVER)
-                                                         then
-                                                         (IRISBOOTSERVER NIL)
-                                                         else
-                                                         (PROMPTPRINT 
-                                                      "IRISNET must be loaded to use the boot server"
-                                                                ))
-                                      "Prevents the Lisp Machine from booting the IRIS")))
-
-(RPAQQ IRISFILES (IRISSTREAM IRISNET IRISVIEW))
-
-(RPAQQ LI.SETUP.ALL ((IRISSTREAM . T)
-                         (IRISSTREAM.LCOM . T)
-                         (IRISNET . T)
-                         (IRISNET.LCOM . T)
-                         (IRISVIEW.LCOM T)
-                         (IRISVIEW T)))
-
-(RPAQQ LI.SETUP.CLEAR ((IRISSTREAM)
-                           (IRISSTREAM.LCOM)
-                           (IRISNET)
-                           (IRISNET.LCOM)
-                           (IRISVIEW)
-                           (IRISVIEW.LCOM)))
-
-(RPAQQ LI.SETUP.DEBUG ((IRISSTREAM . T)
-                           (IRISSTREAM.LCOM . T)
-                           (IRISVIEW . T)
-                           (IRISVIEW.LCOM . T)
-                           (IRISNET.LCOM . T)))
-
-(RPAQQ LI.SETUP.STANDARD ((IRISSTREAM.LCOM . T)
-                              (IRISNET.LCOM . T)
-                              (IRISVIEW.LCOM . T)))
-
-(RPAQQ LI.SHADE 18432)
-
-(RPAQQ LOCATED.IRISFILES ({QV}<PSYCH>IRIS>GL2>IRISLIB {ERIS}<IRIS>IRISSTREAM {ERIS}<IRIS>IRISNET 
-                                    {QV}<PSYCH>IRIS>GL2>IRISIO {ERIS}<IRIS>IRISDIGDEMO))
-
-(RPAQQ LOCATED.IRISPATCHFILE {QV}<PSYCH>IRIS>GL2>IRISPATCH)
-
-(RPAQQ LI.MENU NIL)
-
-(RPAQQ LI.DOIT #*(20 12)@@@@@@@@GOOOL@@@D@@@D@@@EHIGD@@@EEEBD@@@EEEBD@@@EEEBD@@@EHIBD@@@D@@@D@@@GOOOL@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ LI.IRISLOGO #*(16 16)@NG@CJELFBDFCHAL@NG@NCLGKHAMHNGAHBDAKJEMNBDGHJEACJELFBDFCJEL@NG@)
-
-(RPAQQ IRIS.ICON #*(75 82)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@N@@@@@@@@@@@@@@@@COAOH@@@@@@@@@@@@@@@OOAON@@@@@@@@@@@@@@COOAOOH@@@@@@@@@@@@@OOOAOON@@@@@@@@@@@@COOOAOOOH@@@@@@@@@@@OOLOANGON@@@@@@@@@@COO@OANAOOH@@@@@@@@@OOL@OAN@GON@@@@@@@@COO@@OAN@AOOH@@@@@@@OOL@@OAN@@GON@@@@@@COO@@@OAN@@AOOH@@@@@OOL@@@OAN@@@GON@@@@COO@@@@OAN@@@AOOH@@@OOL@@@@OAN@@@@GON@@AOO@@@@@OAN@@@@AOO@@COL@@@@@OAN@@@@@GOH@COH@@@@@OAN@@@@@COH@CON@@@@@OAN@@@@@OOH@AOOH@@@@OAN@@@@COO@@@OON@@@@OAN@@@@OON@@@COOH@@@OAN@@@COOH@@@@OON@@@OAN@@@OON@@@A@COOH@@OAN@@COOHA@@CL@OON@@OAN@@OON@GH@CO@COOH@OAN@COOHAOH@COL@OON@OAN@OON@GOH@COO@COOHOANCOOHAOOH@COOL@OONCAHOON@GOOH@COOO@COOH@COOHAOOOH@CLOOL@OON@OON@GONGH@CLCOO@COOKOOHAOOHGH@CL@OOL@OOOON@GON@GH@CL@COO@COOOHAOOH@GH@CL@@OOL@OON@GON@@GH@CL@@COO@COHAOOH@@GH@CL@@@OOL@N@GON@@@GH@CL@@@COO@@AOOH@@@GH@CL@@@@OOL@GON@@@@GH@CL@@@@CON@OOH@@@@GH@CL@@@@@OOAON@@@@@GH@CL@@@@BCOAOHH@@@@GH@CL@@@@OHOANCN@@@@GH@CL@@@COLOANGOH@@@GH@CL@@@OOLOANGON@@@GH@CL@@COO@OANAOOH@@GH@CL@@OOL@OAN@GON@@GH@CL@COO@BOANHAOOH@GH@CL@OOL@NOANN@GON@GH@CLCOO@CNOANOHAOOHGH@CLOOL@ONOANON@GONGH@COOO@CONOANOOHAOOOH@COOL@OOLOANGON@GOOH@COO@COO@OANAOOHAOOH@COL@OOL@OAN@GON@GOH@CO@COO@@OAN@AOOHAOH@CL@OOL@@OAN@@GON@GH@A@COO@@@OAN@@AOOHA@@@@OOL@@@OAN@@@GON@@@@COO@@@@OAN@@@AOOH@@@GOL@@@@OAN@@@@GOL@@@OO@@@@@OAN@@@@AON@@@OL@@@@@OAN@@@@@GN@@@OO@@@@@OAN@@@@AON@@@OOL@@@@OAN@@@@GOL@@@COO@@@@OAN@@@AOOH@@@@OOL@@@OAN@@@GON@@@@@COO@@@OAN@@AOOH@@@@@@OOL@@OAN@@GON@@@@@@@COO@@OAN@AOOH@@@@@@@@OOL@OAN@GON@@@@@@@@@COO@OANAOOH@@@@@@@@@@OOLOANGON@@@@@@@@@@@COOOAOOOH@@@@@@@@@@@@OOOAOON@@@@@@@@@@@@@COOAOOH@@@@@@@@@@@@@@OOAON@@@@@@@@@@@@@@@CN@OH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-)
-
-(RPAQQ IRIS.ICON.MASK #*(75 82)@@@@@@@COKOH@@@@@@@@@@@@@@@OOOON@@@@@@@@@@@@@@COOOOOH@@@@@@@@@@@@@OOOOOON@@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@OOOOOOOON@@@@@@@@@@COOOOOOOOOH@@@@@@@@@OOOOOOOOOON@@@@@@@@COOOOOOOOOOOH@@@@@@@OOOOOOOOOOOON@@@@@@COOOOOOOOOOOOOH@@@@@OOOOOOOOOOOOOON@@@@COOOOOCOOOIOOOOOH@@@OOOOOLCOOOHGOOOON@@COOOOO@COOOHAOOOOOH@GOOOOL@COOOH@GOOOOL@OOOOO@@COOOH@AOOOON@OOOOL@@COOOH@@GOOON@OOOO@@@COOOH@@AOOON@OOON@@@COOOH@@@GOON@OOOOH@@COOOH@@AOOON@OOOON@@COOOH@@GOOON@OOOOOH@COOOH@AOOOON@GOOOON@COOOH@OOOOOL@OOOOOOHCOOOHCOOOOON@OOOOOONCOOOHOOOOOON@OOOOOOOKOOOKOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOCOOOOOOOOOOOOOION@OO@OOOOOOOOOOOONAON@OO@COOOOOOOOOOOHAON@OO@@OOOOOOOOOON@AON@OO@@COOOOOOOOOH@AON@OO@@@OOOOOOOON@@AON@OO@@@COOOOOOOH@@AON@OO@@@OOOOOOOON@@AON@OO@@COOOOOOOOOH@AON@OO@@OOOOOOOOOON@AON@OO@COOOOOOOOOOOHAON@OO@OOOOOOOOOOOONAON@OOCOOOOOOOOOOOOOION@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOCOOOIOOOOOON@OOOOOOLCOOOHGOOOOON@OOOOOO@COOOHAOOOOON@GOOOOL@COOOH@GOOOOL@COOOO@@COOOH@AOOOOH@COOOL@@COOOH@@GOOOH@COOO@@@COOOH@@AOOOH@COOOL@@COOOH@@GOOOH@COOOO@@COOOH@AOOOOH@COOOOL@COOOH@GOOOOH@AOOOOO@COOOHAOOOOO@@@OOOOOLCOOOHGOOOON@@@COOOOOCOOOIOOOOOH@@@@OOOOOOOOOOOOOON@@@@@COOOOOOOOOOOOOH@@@@@@OOOOOOOOOOOON@@@@@@@COOOOOOOOOOOH@@@@@@@@OOOOOOOOOON@@@@@@@@@COOOOOOOOOH@@@@@@@@@@OOOOOOOON@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@@OOOOOON@@@@@@@@@@@@@COOOOOH@@@@@@@@@@@@@@OOKON@@@@@@@@
-)
-(IRIS.CREATE.ICON)
-(printout T "Boot the IRIS, then choose 'create IRISview Panel' from the IRIS icon menu." T)
-(PUTPROPS LOADIRIS COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1223 9129 (LI.CIRCLES 1233 . 1608) (LI.LOAD 1610 . 2687) (LI.MAKEMENU 2689 . 5066) (
-LI.SETUP 5068 . 5825) (IRIS.CREATE.ICON 5827 . 6230) (IRIS.DOMENU 6232 . 6559) (IRIS.TRY 6561 . 7221) 
-(LOADIRIS 7223 . 7894) (INSTALLIRIS 7896 . 8300) (LI.TRAVEL 8302 . 9127)))))
-STOP
diff --git a/obsolete/lispusers/LUPINE b/obsolete/lispusers/LUPINE
deleted file mode 100644
index 866cb921..00000000
--- a/obsolete/lispusers/LUPINE
+++ /dev/null
@@ -1,1485 +0,0 @@
-(FILECREATED "30-Jun-86 16:38:25" {PHYLUM}<LANNING>RPC>LUPINE.;1 57734  
-
-      changes to:  (FNS \MakeUnmarshalRecord)
-
-      previous date: " 1-Aug-85 12:16:27" {PHYLUM}<LISP>KOTO>LISPUSERS>LUPINE.;1)
-
-
-(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT LUPINECOMS)
-
-(RPAQQ LUPINECOMS [(DECLARE: DONTCOPY (RECORDS ArgSpec Fragment FunctionSpec FieldSpec LupineType 
-						 RecordLayout TypeSpec))
-		     (* Basic stub construction)
-		     (FNS Lupine \ServerComs \MakeUnmarshal \MakeUnmarshal1 \MakeUnmarshalRecord 
-			  \FixedFetch \MakeArgsUnmarshal \ClientComs \MakeMarshal \MakeMarshal1 
-			  \MakeMarshalRecord \FixedStore \MakeArgsMarshal)
-		     (* Checking of declarations)
-		     (FNS \CheckSpec \CheckType \CheckType1 \CheckRecordDecl)
-		     (* Type table construction)
-		     (FNS \DeclareTypes \Allocate \AllocateRecord)
-		     (* Utilities)
-		     (FNS \TypeName \BaseType \TypeLayout \TypeSize \LupineNotFixed \StaticsFirst 
-			  \IsStatic)
-		     (VARS \LupineGetFns \LupinePutFns \LupinePrimativeTypes \LupineInitialTypeTable 
-			   \LupineNumberTypes \LupineNotFixedTypes \LupineDummyTypes \LupineStatics 
-			   \LupineTypesWithParm)
-		     (GLOBALVARS \LupineGetFns \LupinePutFns \LupineStatics \LupineTypesWithParm 
-				 \LupinePrimativeTypes \LupineDummyTypes \LupineNotFixedTypes 
-				 \LupineNumberTypes \LupineInitialTypeTable)
-		     (DECLARE: DONTCOPY (CONSTANTS (\FirstLupineUserCall 4)
-						   (\FirstLupineSignal 4])
-(DECLARE: DONTCOPY 
-[DECLARE: EVAL@COMPILE 
-
-(RECORD ArgSpec (argName argType))
-
-(RECORD Fragment (fixed . notFixed))
-
-(RECORD FunctionSpec (fn . specs))
-
-(RECORD FieldSpec (fieldName fieldType))
-
-(RECORD LupineType (typeName . typeParm))
-
-(RECORD RecordLayout (need . fields))
-
-(RECORD TypeSpec (type typeType definedStubs typeSize . typeBits))
-]
-)
-
-
-
-(* Basic stub construction)
-
-(DEFINEQ
-
-(Lupine
-  [LAMBDA (packageName functionSpecList signalSpecList typeList lupineTypeString noServer noClient)
-                                                             (* ht: "31-Jul-85 11:47")
-    (if (NOT (LITATOM packageName))
-	then (ERROR "package name must be an atom" packageName))
-    (if (AND functionSpecList (NLISTP functionSpecList))
-	then (ERROR "function spec must be a list" functionSpecList))
-    (if (AND signalSpecList (NLISTP signalSpecList))
-	then (ERROR "signal spec must be a list" signalSpecList))
-    (if (AND typeList (NLISTP typeList))
-	then (ERROR "type declarations must be a list" typeList))
-    (if (NOT lupineTypeString)
-	then (printout T "type string defaulted to " [lupineTypeString_(MKSTRING
-			   (PACK (LIST packageName (GDATE)
-				       (ETHERHOSTNUMBER]
-		       T))
-    (if (NOT (STRINGP lupineTypeString))
-	then lupineTypeString_(MKSTRING lupineTypeString))
-    (RESETLST (RESETSAVE DFNFLG T)
-	      (LET ((typeTable (\DeclareTypes typeList))
-		 sName cName)
-		(for s in functionSpecList do (\CheckSpec s typeTable))
-		(for s in signalSpecList do (\CheckSpec s typeTable T))
-		[if (NOT noServer)
-		    then (SET sName_(PACK (LIST (U-CASE packageName)
-						'SERVERCOMS))
-			      (\ServerComs packageName functionSpecList signalSpecList typeTable 
-					   lupineTypeString))
-			 (ADDFILE (PACK (LIST (U-CASE packageName)
-					      'SERVER]
-		[if (NOT noClient)
-		    then (SET cName_(PACK (LIST (U-CASE packageName)
-						'CLIENTCOMS))
-			      (\ClientComs packageName functionSpecList signalSpecList typeTable 
-					   lupineTypeString))
-			 (ADDFILE (PACK (LIST (U-CASE packageName)
-					      'CLIENT]
-		(CONS sName cName])
-
-(\ServerComs
-  [LAMBDA ($packageName$ functionSpecList signalSpecList typeTable lupineTypeString)
-                                                             (* ht: " 1-Aug-85 12:13")
-    (DECLARE (SPECVARS $packageName$))
-    (LET ($fns$ dfn iName selTerms $rNames$ catchTerms labelTerms movds hideFn loads)
-      (DECLARE (SPECVARS $fns$ $rNames$))
-
-          (* * the NCONC is because some stuff gets pushed onto $fns$ underneath here)
-
-
-      $fns$_(NCONC (bind (i _ \FirstLupineUserCall)
-			 argNames nameMap rec rfl fn argSets end result for spec in functionSpecList
-		      unless (spec:fn= '*)
-		      collect [fn_(PACK (LIST spec:fn 'ServerStub]
-			      [argNames_(for aSpec in spec:specs as i from 1
-					   until (if (U-CASE aSpec:argName)= 'RETURNS
-						     then result_aSpec)
-					   collect (CDAR (push nameMap (CONS aSpec:argName
-									     (PACK* 'l..arg
-										    i]
-			      [argSets_(for aSpec in (\StaticsFirst spec:specs typeTable)
-					  collect (LIST 'SETQ
-							(CDR (ASSOC aSpec:argName nameMap))
-							(\MakeUnmarshal aSpec:argType spec:fn 
-									aSpec:argName typeTable]
-			      (end_(if result
-				       then (\MakeArgsMarshal result:argType fn 'RESULT
-							      'l..result
-							      typeTable)))
-			      [APPLY* (FUNCTION DEFINEQ)
-				      (BQUOTE (, fn (l..cPup l..conv)
-                                                             (* Lupine generated stub)
-						 (DECLARE (SPECVARS l..cPup l..conv))
-						 (PROG (l..result ,. argNames)
-						   ,.
-						   argSets
-						       (SETQ l..result (, (fetch fn of spec)
-									  ,. argNames))
-						       (\StartReturn l..cPup)
-						   ,.
-						   end (RETURN l..cPup]
-			      [selTerms_(NCONC1 selTerms (BQUOTE (, i (, fn l..pup l..conv]
-			      (push movds (CONS spec:fn (CONS (PACK* 'Hidden.
-								     spec:fn)
-							      fn)))
-			      (add i 1)
-			      fn)
-		   $fns$)
-      dfn_(PACK (LIST $packageName$ 'ServerDispatch))
-      (if signalSpecList
-	  then (bind (j _ \FirstLupineSignal)
-		     cName specs resultSpec margs umres for sSpec in signalSpecList
-		  unless (sSpec:fn= '*)
-		  do (specs_sSpec:specs)
-		     (margs_(if (U-CASE specs:1:argName)= 'ARGS
-				then (\MakeArgsMarshal (pop specs):argType sSpec:fn 'SIGARGS
-						       'arg
-						       typeTable)))
-		     (if (U-CASE specs:1:argName)= 'RETURNS
-			 then umres_(\MakeArgsUnmarshal specs:1:argType sSpec:fn 'RESULT
-							typeTable))
-		     [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
-					      (BQUOTE (, [SETQ cName
-							   (PACK (LIST 'Catch
-								       (fetch fn of sSpec]
-							 (arg l..conv)
-                                                             (* Lupine generated signal catcher)
-							 (DECLARE (USEDFREE l..cPup))
-							 (\StartSignal l..cPup)
-							 (\AddPupWord l..cPup , j)
-							 ., margs (SETQ l..cPup
-							   (\Call l..cPup NIL l..conv))
-							 , umres]
-		     [catchTerms_(NCONC catchTerms (APPEND (BQUOTE (, (fetch fn of sSpec)=>
-								      (sresume (, cName arg l..conv]
-		     (add j 1)))
-
-          (* * the (, (QUOTE enable)) is to keep the form from being prettyprinted)
-
-
-      [APPLY* (FUNCTION DEFINEQ)
-	      (BQUOTE (, dfn (l..pup request l..conv)        (* Lupine generated dispatcher)
-			 (, 'enable
-			    ., catchTerms (SELECTQ request ., selTerms (SHOULDNT))
-			    ., labelTerms]
-      (push $fns$ dfn)
-      iName_(PACK (LIST $packageName$ 'ServerInterface))
-      (if (NOT (BOUNDP iName))
-	  then (SET iName NIL))
-      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
-			       (BQUOTE (, (PACK (LIST 'Unexport
-						      $packageName$))
-					  NIL                (* Lupine generated interface)
-					  [UnexportInterface (OR , iName (ERROR "not exported"
-										(QUOTE , 
-										    $packageName$]
-					  (SETQ , iName NIL]
-      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
-			       (BQUOTE (, (PACK (LIST 'Export
-						      $packageName$))
-					  (type instance version user password)
-                                                             (* Lupine generated interface)
-					  (if , iName
-					      then (ERROR "Already exported" (QUOTE , $packageName$)))
-					  (SETQ , iName (ExportInterface user password
-									 (OR type , lupineTypeString)
-									 instance version
-									 (FUNCTION , dfn]
-      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
-			       (BQUOTE (, [SETQ hideFn (PACK (LIST 'Hide
-								   $packageName$
-								   'ServerMovds]
-					  NIL                (* Lupine generated utility)
-					  (for p in (QUOTE , movds)
-					     do (PUTD (CADR p)
-						      (GETD (CAR p)))
-						(PUTD (CAR p))
-						(CHANGENAME (CDDR p)
-							    (CAR p)
-							    (CADR p]
-      [LET [(files (NCONC1 (bind wh res for r in $rNames$
-			      when (if wh_(WHEREIS r 'RECORDS)
-				     else (printout T T "Note - the record " r 
-						    " is not on any known file"
-						    T))
-			      do (pushnew res wh:1) finally (RETURN res))
-			   'SIGNAL]
-	loads_(LIST (BQUOTE (DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (FILES (LOADCOMP)
-									     ., files]
-      (BQUOTE (                                              (* Created by Lupine , (GDATE))
-	       (FNS ,. $fns$)
-	       (VARS (, iName))
-	       (GLOBALVARS , iName)
-	       ., loads (DECLARE: EVAL@LOAD DONTEVAL@COMPILE DOCOPY (FILES (SYSLOAD)
-									   RPC))
-	       (P (COND
-		    ((EQ 'Y
-			 (ASKUSER 15 'N
-				  "Hide server fns (must have been already loaded)? "))
-		      (, hideFn])
-
-(\MakeUnmarshal
-  [LAMBDA (type fn name typeTable pupName)                   (* ht: " 1-Aug-85 08:57")
-    (if type
-	then (if (NOT pupName)
-		 then pupName_ 'l..cPup)
-	     (LET (fragment)
-	       fragment_(\MakeUnmarshal1 type fn name typeTable 0 16 pupName)
-	       (if NOT (fragment:notFixed)
-		   then fragment:fixed
-		 else (BQUOTE (LET ((l..datum , (fetch fixed of fragment)))
-				.,
-				(fetch notFixed of fragment)
-				l..datum])
-
-(\MakeUnmarshal1
-  [LAMBDA (type fn name typeTable whereAreWe size pupName)   (* ht: " 1-Aug-85 09:09")
-    (LET ((typeName (\TypeName type))
-       (typeParm (if (LISTP type)
-		     then type:typeParm))
-       afn typeSpec)
-      (SELECTQ typeName
-	       ((RECORD SEQRECORD)
-		 (SHOULDNT))
-	       [LIST (create Fragment
-			     fixed _(BQUOTE (PROGN (SETQ , pupName (\CheckPupExhausted , pupName 2))
-						   (for l..i from 1 to (\GetArgDblWord , pupName 
-										       l..conv)
-						      collect , (\MakeUnmarshal (CAR typeParm)
-										fn name typeTable 
-										pupName]
-	       [REF                                          (* no-op except for SEQRECORDs)
-		    (LET ((trueType (\BaseType typeParm:1 typeTable))
-		       typeSpec)
-		      (if (AND (LISTP trueType)
-			       trueType:typeName=
-			       'SEQRECORD)
-			  then 
-
-          (* * have to back up one)
-
-
-			       (\MakeUnmarshalRecord (OR typeSpec_(for tte in typeTable thereis
-											 
-									    tte:typeType=trueType)
-							 (SHOULDNT))
-						     fn name typeTable whereAreWe
-						     (if size=16
-							 then typeSpec:typeSize
-						       else (SHOULDNT))
-						     pupName)
-			else (create Fragment
-				     fixed _(LET [(nilCheck (BQUOTE (\GetArgBool , pupName l..conv]
-				       [if pupName= 'l..pup
-					   then nilCheck_(BQUOTE (PROG1 , nilCheck (SETQ l..pup 
-									  l..cPup]
-				       (BQUOTE (if , nilCheck
-						   then NIL
-						 else , (\MakeUnmarshal (CAR typeParm)
-									fn name typeTable pupName]
-	       [BITS                                         (* Just a bit special)
-		     (create Fragment
-			     fixed _(if (ILESSP size 16)
-					then (\FixedFetch size type whereAreWe fn name typeTable)
-				      elseif whereAreWe~=0
-					then (HELP "bad layout")
-				      elseif (ILEQ typeParm:1 16)
-					then 
-
-          (* * note that even if we get here with a BITS record of <16 size, we just get a whole word)
-
-
-					     (BQUOTE (\GetArgWord , pupName l..conv))
-				      elseif typeParm:1=32
-					then                 (* closest we get to LONG CARDINAL)
-					     (BQUOTE (\GetArgDblWord , pupName l..conv))
-				      else (SHOULDNT]
-	       (if (FMEMB typeName \LupinePrimativeTypes)
-		   then (if (ILESSP size 16)
-			    then (create Fragment
-					 fixed _(\FixedFetch size type whereAreWe fn name typeTable))
-			  elseif whereAreWe~=0
-			    then (HELP "bad layout")
-			  elseif afn_(CDR (ASSOC typeName \LupineGetFns))
-			    then 
-
-          (* * note that even if we get here with a BITS record of <16 size, we just get a whole word courtesy of the GetFns 
-	  table entry)
-
-
-				 [create Fragment
-					 fixed _(LET [(sr (BQUOTE (, afn , pupName .,
-								     (if typeParm
-									 then (LIST (KWOTE typeParm)))
-								     l..conv]
-					   (if pupName= 'l..cPup
-					       then sr
-					     else (BQUOTE (PROG1 , sr (SETQ l..pup l..cPup]
-			  else (SHOULDNT))
-		 elseif typeSpec_(ASSOC typeName typeTable)
-		   then (if typeSpec:typeType:type= 'RECORD
-			    then (\MakeUnmarshalRecord typeSpec fn name typeTable whereAreWe
-						       (if (AND size=16 (IGREATERP typeSpec:typeSize 
-										   16))
-							   then typeSpec:typeSize
-							 else size)
-						       pupName)
-			  else (\MakeUnmarshal1 typeSpec:typeType fn name typeTable whereAreWe size 
-						pupName))
-		 else (ERROR "Invalid spec" (LIST fn name type])
-
-(\MakeUnmarshalRecord
-  [LAMBDA (spec fn name typeTable startBit bitWidth pupName)
-                                                             (* smL "30-Jun-86 16:17")
-    (LET ((fnName (PACK* (QUOTE Unmarshal)
-			   $packageName$
-			   (fetch type of spec)
-			   (QUOTE %#)
-			   startBit
-			   (QUOTE %#)
-			   bitWidth))
-	  (bits (fetch typeBits of spec))
-	  (seq? (EQ (fetch typeName of (fetch typeType of spec))
-		      (QUOTE SEQRECORD)))
-	  fetches createExpr indirects umc notFixed someNot res seqSpec seqEltFetch seqSubSpec 
-	  seqStatic? leftOver)
-         [if (NOT (FMEMB fnName (fetch definedStubs of spec)))
-	     then (push $rNames$ (fetch type of spec))
-		    (if (ILESSP (fetch typeSize of spec)
-				    bitWidth)
-			then (SETQ bits (CONS (IPLUS (CAR bits)
-							     (DIFFERENCE bitWidth
-									   (fetch typeSize
-									      of spec)))
-						    (CDR bits)))
-		      elseif (AND (IGREATERP (fetch typeSize of spec)
-						   bitWidth)
-				      (NOT (ZEROP startBit)))
-			then (HELP "bad layout"))
-		    [SETQ fetches
-		      (bind (whereAreWe _ startBit)
-			      (nFixed _ 0)
-			      last for field in (fetch typeParm of (fetch typeType
-									      of spec))
-			 as size in bits
-			 join
-			  (if (AND (LISTP (fetch fieldType of field))
-				       (EQ (fetch typeName of (fetch fieldType of field))
-					     (QUOTE SEQUENCE)))
-			      then (if seq?
-					 then (SETQ seqSpec field)
-						[SETQ seqSubSpec
-						  (CAR (fetch typeParm
-							    of (fetch fieldType of field]
-
-          (* * * This should be a call to \MakeUnmarshal1, but because of a CEDAR Lupine bug, is not 
-	  (see below for more discussion) -
-	  If CEDAR is ever fixed, the call should be as follows: (SETQ seqEltFetch (\MakeUnmarshal1 seqSubSpec fn name 
-	  typeTable whereAreWe size (QUOTE l..pup))))
-
-
-						[SETQ seqEltFetch (\MakeUnmarshal
-						    seqSubSpec fn name typeTable
-						    (if (SETQ seqStatic? (\IsStatic seqSubSpec 
-											typeTable))
-							then (QUOTE l..pup)
-						      else (QUOTE l..cPup]
-				       else (SHOULDNT))
-				     NIL
-			    elseif (\LupineNotFixed field typeTable)
-			      then (add nFixed 1)
-				     (SETQ someNot T)
-				     NIL
-			    else (SETQ umc (\MakeUnmarshal1 (fetch fieldType of field)
-								  fn name typeTable whereAreWe size
-								  (QUOTE l..pup)))
-				   [if (fetch notFixed of umc)
-				       then
-					(SETQ notFixed
-					  (NCONC1 notFixed
-						    (BQUOTE
-						      (LET ((l..datum (fetch (, (fetch type
-										     of spec)
-										  ,
-										  (fetch fieldName
-										     of field))
-									 of l..datum)))
-						       .,  (fetch notFixed of umc]
-				   (SETQ umc (fetch fixed of umc))
-				   (SETQ whereAreWe (LOGAND 15 (IPLUS whereAreWe size)))
-				   (if (NOT (ZEROP nFixed))
-				       then (SETQ umc (BQUOTE (PROGN (SETQ l..pup
-									       (\SkipWordsIn
-										 l..pup ,
-										 (LLSH nFixed 1)))
-									     , umc)))
-					      (SETQ nFixed 0))
-				   (SETQ last (LIST (fetch fieldName of field)
-							(QUOTE _)
-							umc)))
-			 finally (if (NOT (ZEROP nFixed))
-				       then (SETQ leftOver (BQUOTE (SETQ l..pup
-									   (\SkipWordsIn
-									     l..pup ,
-									     (LLSH nFixed 1]
-		    (SETQ createExpr (BQUOTE (create , (fetch type of spec)
-							   ., fetches)))
-		    [if leftOver
-			then (SETQ createExpr (BQUOTE (PROG1 , createExpr , leftOver]
-		    (if someNot
-			then [SETQ indirects (for field in (fetch typeParm
-								      of (fetch typeType
-									      of spec))
-						    when (\LupineNotFixed field typeTable)
-						    collect (SETQ umc
-								(\MakeUnmarshal (fetch fieldType
-										     of field)
-										  fn name typeTable
-										  (QUOTE l..cPup)))
-							      (BQUOTE (replace
-									  (, (fetch type
-										of spec)
-									     ,
-									     (fetch fieldName
-										of field))
-									   of l..datum
-									   with , umc]
-			       (SETQ notFixed (NCONC notFixed indirects)))
-		    (SETQ createExpr
-		      (if seq?
-			  then [LET (prelim term f nf)
-
-          (* * the code in this comment is the way this **should** work, with only the non-statics following after, but in 
-	  fact as CEDAR Lupine stands if a sequence's element type has any non-static parts, the WHOLE element gets repeated.
-	  There is a further patch associated with this higher up in this function. If this ever gets fixed, replace the if 
-	  statement which follows this comment with this code: (if (fetch notFixed of seqEltFetch) then 
-	  (SETQ f (fetch fixed of seqEltFetch)) (SETQ nf (fetch notFixed of seqEltFetch)) elseif (\LupineNotFixed 
-	  (fetch fieldType of seqSpec) typeTable) then (SETQ prelim (BQUOTE (first (\SkipWordsIn l..pup 
-	  (LLSH size 1))))) (SETQ nf (fetch fixed of seqEltFetch)) else (SETQ f (fetch fixed of seqEltFetch))))
-
-
-				      (if seqStatic?
-					  then (SETQ f seqEltFetch)
-					else [SETQ prelim
-						 (BQUOTE (first
-							     (\SkipWordsIn
-							       l..pup
-							       (ITIMES , (LRSH (\TypeSize
-										     seqSubSpec 
-										     typeTable)
-										   4)
-									 l..size]
-					       (SETQ nf seqEltFetch))
-				      [if nf
-					  then [SETQ term
-						   (if f
-						       then (BQUOTE (LET ((l..datum (CAR l..p)))
-									 .,
-									 nf))
-						     else (BQUOTE (RPLACA l..p , nf]
-						 (SETQ notFixed
-						   (NCONC1
-						     notFixed
-						     (BQUOTE (for l..p
-								  on (fetch (, (fetch type
-										      of spec)
-										   ,
-										   (fetch fieldName
-										      of seqSpec))
-									  of l..datum)
-								  do , term]
-				      (BQUOTE ((SETQ l..pup (\CheckPupExhausted l..pup 3))
-						 (if (\GetArgBool l..pup l..conv)
-						     then NIL
-						   else (LET ((l..size (\GetArgDblWord l..pup 
-											  l..conv)))
-							       (bind (l..result _ , createExpr)
-								       ., prelim for l..i
-								  from 1 to l..size
-								  collect , f
-								  finally
-								   (replace (, (fetch type
-										    of spec)
-										 ,
-										 (fetch fieldName
-										    of seqSpec))
-								      of l..result with $$VAL)
-								   (RETURN l..result]
-			else (LIST createExpr)))
-		    [if (AND seq? notFixed)
-			then (SETQ notFixed (LIST (BQUOTE (if l..datum
-								      then ., notFixed]
-		    (APPLY* (FUNCTION DEFINEQ)
-			      (BQUOTE (, fnName (l..pup l..conv)
-                                                             (* Lupine generated stub)
-					   ., createExpr)))
-
-          (* * must record the notFixed generated here so they get used if the function gets re-used)
-
-
-		    (PUT fnName (QUOTE LupineNotFixed)
-			   notFixed)
-		    (push $fns$ fnName)
-		    (push (fetch definedStubs of spec)
-			    fnName)
-	   else (SETQ notFixed (APPEND (GETP fnName (QUOTE LupineNotFixed]
-         (SETQ res (BQUOTE (, fnName , pupName l..conv)))
-         [if pupName=(QUOTE l..pup)
-	     then 
-
-          (* * horrible kludge as our function may have reset l..cPup but our caller won't see that)
-
-
-		    (SETQ res (LIST (QUOTE PROG1)
-					res
-					(QUOTE (SETQ l..pup l..cPup]
-         (create Fragment
-		   fixed _ res
-		   notFixed _ notFixed])
-
-(\FixedFetch
-  [LAMBDA (size type whereAreWe fn name typeTable)           (* ht: " 1-Aug-85 08:54")
-    (LET ((typeName (\TypeName type))
-       (typeParm (if (LISTP type)
-		     then type:typeParm))
-       ff bitNum form)
-      (SELECTQ typeName
-	       (RECORD (SHOULDNT))
-	       ((BOOLEAN BITS ENUMERATION)
-
-          (* * compute the field descriptor)
-
-
-		 bitNum_
-		 (IPLUS (LLSH whereAreWe 4)
-			size-1)
-
-          (* * make the call to FETCHFIELD)
-
-
-		 ff_
-		 (BQUOTE (FETCHFIELD '(NIL 0 (BITS ., bitNum))
-				     (\CurrentPupBase l..pup)))
-		 form_
-		 (SELECTQ typeName
-			  (BITS ff)
-			  [ENUMERATION (BQUOTE (CAR (NTH (QUOTE , typeParm)
-							 (ADD1 , ff]
-			  [BOOLEAN (BQUOTE (NOT (ZEROP , ff]
-			  (SHOULDNT))
-		 (if (ZEROP whereAreWe)
-		     then 
-
-          (* * need to check there is room in the l..pup)
-
-
-			  (BQUOTE (PROGN (SETQ l..pup (\CheckPupExhausted l..pup 1))
-					 , form))
-		   elseif (IPLUS whereAreWe size)=16
-		     then 
-
-          (* * must advance the counter)
-
-
-			  (BQUOTE (PROG1 , form (\IncrDataOffset l..pup 1)))
-		   else form))
-	       (SHOULDNT])
-
-(\MakeArgsUnmarshal
-  [LAMBDA (spec fn multTypeName typeTable)                   (* ht: " 1-Aug-85 08:51")
-    (LET (resultSpec)
-      (if (AND (LITATOM spec)
-	       resultSpec_(\BaseType spec typeTable)
-	       (LISTP resultSpec)
-	       resultSpec:typeName=multTypeName)
-	  then                                               (* create the record)
-	       (push $rNames$ spec)
-	       [NCONC (LIST 'create
-			    spec)
-		      (for rSpec in (\StaticsFirst resultSpec:typeParm typeTable)
-			 join (BQUOTE (, (fetch fieldName of rSpec)_ , (\MakeUnmarshal (fetch 
-											fieldType
-											  of rSpec)
-										       fn
-										       (fetch 
-											fieldName
-											  of rSpec)
-										       typeTable]
-	else (\MakeUnmarshal spec fn 'l..result
-			     typeTable])
-
-(\ClientComs
-  [LAMBDA ($packageName$ functionSpecList signalSpecList typeTable lupineTypeString)
-                                                             (* ht: " 1-Aug-85 09:39")
-    (DECLARE (SPECVARS $packageName$))
-    (LET ($fns$ dfn selTerms iName cName typeSels $rNames$ sDisp sigTerms movds movdFn result loads)
-      (DECLARE (SPECVARS $fns$ $rNames$))
-      iName_(PACK (LIST $packageName$ 'ClientInterface))
-      sDisp_(PACK (LIST 'Dispatch
-			$packageName$
-			'Signals))
-
-          (* * the NCONC is because some stuff gets pushed onto $fns$ underneath here)
-
-
-      $fns$_(NCONC (bind (i _ \FirstLupineUserCall)
-			 argNames rec rfl fn argPuts end stubFn for spec in functionSpecList
-		      unless spec:fn= '*
-		      collect (fn_spec:fn)
-			      (stubFn_(PACK (LIST 'RPCClientStub.
-						  fn)))
-			      (argPuts_(for aSpec in (\StaticsFirst spec:specs typeTable)
-					  join (\MakeMarshal aSpec:argType aSpec:argName fn 
-							     aSpec:argName typeTable)))
-			      [argNames_(NCONC (for aSpec in spec:specs until (if (U-CASE 
-										    aSpec:argName)=
-										  'RETURNS
-										  then result_aSpec)
-						  collect aSpec:argName)
-					       (LIST 'l..interfaceArg
-						     'l..conv]
-			      (end_(if result
-				       then (\MakeArgsUnmarshal result:argType fn 'RESULT
-								typeTable)))
-			      [APPLY* (FUNCTION DEFINEQ)
-				      (BQUOTE (, stubFn , argNames 
-                                                             (* Lupine generated stub)
-						 (PROG [l..cPup (l..interface (OR l..interfaceArg
-										  (CAR , iName]
-						       (DECLARE (SPECVARS l..cPup))
-						       (SETQ l..cPup (\StartCall (CAR l..interface)
-										 (CDR l..interface)
-										 l..conv))
-						       (\AddPupWord l..cPup , i l..conv)
-						   ,.
-						   argPuts
-						       (SETQ l..cPup (\Call l..cPup
-									    (FUNCTION , sDisp)
-									    l..conv))
-						       (RETURN (PROG1 , end (\RELEASE.PUP l..cPup]
-			      (push movds (CONS stubFn fn))
-			      (add i 1)
-			      stubFn)
-		   $fns$)
-      sigTerms_(bind (j _ \FirstLupineSignal)
-		     mres umargs specs for sSpec in signalSpecList unless sSpec:fn= '*
-		  collect (specs_sSpec:specs)
-			  (umargs_(if (U-CASE specs:1:argName)= 'ARGS
-				      then (\MakeArgsUnmarshal (pop specs):argType sSpec:fn
-							       'SIGARGS
-							       typeTable)))
-			  (if (U-CASE specs:1:argName)= 'RETURNS
-			      then mres_(\MakeArgsMarshal specs:1:argType sSpec:fn 'RESULT
-							  'l..result
-							  typeTable))
-			  (PROG1 (BQUOTE (, j (PROG (l..result)
-						    (SETQ l..result
-						      (Signal (QUOTE , (fetch fn of sSpec))
-							      , umargs))
-						    (\StartReturn l..cPup)
-						.,
-						mres)))
-				 (add j 1)))
-      (APPLY* (FUNCTION DEFINEQ)
-	      (BQUOTE (, sDisp (l..cPup l..conv)             (* Lupine generated dispatcher)
-			 (DECLARE (SPECVARS l..cPup l..conv))
-			 (SELECTQ (\GetArgWord l..cPup l..conv)
-				  ., sigTerms (SHOULDNT))
-			 l..cPup)))
-      (push $fns$ sDisp)
-      (if (NOT (BOUNDP iName))
-	  then (SET iName NIL))
-      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
-			       (BQUOTE (, (PACK (LIST 'Unimport
-						      $packageName$))
-					  (l..interface)     (* Lupine generated interface)
-					  (if l..interface
-					      then (if (FMEMB l..interface , iName)
-						       then (UnimportInterface l..interface)
-							    (SETQ , iName (DREMOVE l..interface , 
-										   iName))
-						     else (ERROR "not imported" l..interface))
-					    else (for e in , iName do (UnimportInterface e))
-						 (SETQ , iName NIL]
-      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
-			       (BQUOTE (, (PACK (LIST 'Import
-						      $packageName$))
-					  (type instance version)
-                                                             (* Lupine generated interface)
-					  (CAR (push , iName (ImportInterface (OR type , 
-										 lupineTypeString)
-									      instance version]
-      [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ)
-			       (BQUOTE (, (SETQ movdFn (PACK (LIST 'MovdsFor
-								   $packageName$)))
-					  NIL                (* Lupine generated utility)
-					  (for p in (QUOTE , movds)
-					     do (PUTD (CDR p)
-						      (GETD (CAR p]
-      [if $rNames$
-	  then (LET [(files (bind wh res for r in $rNames$
-			       when (if wh_(WHEREIS r 'RECORDS)
-				      else (printout T T "Note - the record " r 
-						     " is not on any known file"
-						     T))
-			       do (pushnew res wh:1) finally (RETURN res]
-		 loads_(LIST (BQUOTE (DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (FILES (LOADCOMP)
-										      ., files]
-      (BQUOTE (                                              (* Created by Lupine , (GDATE))
-	       (FNS ,. $fns$)
-	       (VARS (, iName))
-	       (GLOBALVARS , iName)
-	       (P (, movdFn))
-	       ., loads (DECLARE: EVAL@LOAD DONTEVAL@COMPILE DOCOPY (FILES (SYSLOAD)
-									   RPC])
-
-(\MakeMarshal
-  [LAMBDA (type val fn name typeTable pupName)               (* ht: " 1-Aug-85 08:57")
-    (if type
-	then (if (NOT pupName)
-		 then pupName_ 'l..cPup)
-	     (LET (fragment)
-	       fragment_(\MakeMarshal1 type val fn name typeTable 0 16 pupName)
-	       (if NOT (fragment:notFixed)
-		   then fragment:fixed
-		 else (NCONC fragment:fixed (if val~= 'l..datum
-						then [LIST (BQUOTE (LET ((l..datum , val))
-								     .,
-								     (fetch notFixed of fragment]
-					      else fragment:notFixed])
-
-(\MakeMarshal1
-  [LAMBDA (type val fn name typeTable whereAreWe size pupName)
-                                                             (* ht: " 1-Aug-85 08:59")
-    (LET ((typeName (\TypeName type))
-       (typeParm (if (LISTP type)
-		     then type:typeParm))
-       afn typeSpec)
-      (SELECTQ typeName
-	       ((RECORD SEQRECORD)
-		 (SHOULDNT))
-	       [LIST (create Fragment
-			     fixed _(LIST (BQUOTE (PROGN (\CheckPupOverflow , pupName 4)
-							 (\AddPupDblWord , pupName (LENGTH , val)
-									 l..conv)
-							 (for l..v in , val
-							    do ., (\MakeMarshal (CAR typeParm)
-										'l..v
-										fn name typeTable 
-										pupName]
-	       [REF                                          (* no-op except for SEQRECORDs)
-		    (LET ((trueType (\BaseType typeParm:1 typeTable))
-		       typeSpec)
-		      (if (AND (LISTP trueType)
-			       trueType:typeName=
-			       'SEQRECORD)
-			  then 
-
-          (* * have to back up one)
-
-
-			       (\MakeMarshalRecord (OR typeSpec_(for tte in typeTable thereis 
-									    tte:typeType=trueType)
-						       (SHOULDNT))
-						   val fn name typeTable whereAreWe
-						   (if size=16
-						       then typeSpec:typeSize
-						     else (SHOULDNT))
-						   pupName)
-			else (create Fragment
-				     fixed _(LIST (BQUOTE (if , val
-							      then (\AddPupBoolean , pupName NIL 
-										   l..conv)
-								   .,
-								   (\MakeMarshal (CAR typeParm)
-										 val fn name 
-										 typeTable pupName)
-							    else (\AddPupBoolean , pupName T l..conv]
-	       [BITS (create Fragment
-			     fixed _(if (ILESSP size 16)
-					then (\FixedStore size type val whereAreWe fn name typeTable)
-				      elseif whereAreWe~=0
-					then (HELP "bad layout")
-				      elseif (ILEQ typeParm:1 16)
-					then 
-
-          (* * note that even if we get here with a BITS record of <16 size, we just put a whole word)
-
-
-					     (LIST (BQUOTE (\AddPupWord , pupName , val l..conv)))
-				      elseif typeParm:1=32
-					then                 (* closest we get to LONG CARDINAL)
-					     (LIST (BQUOTE (\AddPupDblWord , pupName , val l..conv)))
-				      else (SHOULDNT]
-	       (if (FMEMB typeName \LupinePrimativeTypes)
-		   then (if (ILESSP size 16)
-			    then (create Fragment
-					 fixed _(\FixedStore size type val whereAreWe fn name 
-							     typeTable))
-			  elseif whereAreWe~=0
-			    then (HELP "bad layout")
-			  elseif afn_(CDR (ASSOC typeName \LupinePutFns))
-			    then 
-
-          (* * note that if we get here with a BITS record of <16 size, we just get a whole word courtesy of the PutFns table 
-	  entry)
-
-
-				 [create Fragment
-					 fixed _(LIST (BQUOTE (, afn , pupName .,
-								 (if typeParm
-								     then (LIST (KWOTE typeParm)))
-								 , val l..conv]
-			  else (SHOULDNT))
-		 elseif typeSpec_(ASSOC typeName typeTable)
-		   then (if typeSpec:typeType:type= 'RECORD
-			    then (\MakeMarshalRecord typeSpec val fn name typeTable whereAreWe
-						     (if (AND size=16 (IGREATERP typeSpec:typeSize 16)
-							      )
-							 then typeSpec:typeSize
-						       else size)
-						     pupName)
-			  else (\MakeMarshal1 typeSpec:typeType val fn name typeTable whereAreWe size 
-					      pupName))
-		 else (ERROR "Invalid spec" (LIST fn name type])
-
-(\MakeMarshalRecord
-  [LAMBDA (spec val fn name typeTable startBit bitWidth pupName)
-                                                             (* ht: " 1-Aug-85 12:16")
-    (LET ((fnName (PACK* 'Marshal
-			 $packageName$ spec:type '#
-			 startBit
-			 '#
-			 bitWidth))
-       (bits spec:typeBits)
-       (seq? spec:typeType:typeName= 'SEQRECORD)
-       seqSpec seqSubSpec seqEltStore seqStatic? stores notFixed indirects mc someNot)
-      [if (NOT (FMEMB fnName spec:definedStubs))
-	  then (push $rNames$ spec:type)
-	       (if (ILESSP spec:typeSize bitWidth)
-		   then bits_(CONS (IPLUS bits:1 bitWidth-spec:typeSize)
-				   bits::1)
-		 elseif (AND (IGREATERP spec:typeSize bitWidth)
-			     (NOT (ZEROP startBit)))
-		   then (HELP "bad layout"))
-	       [stores_(bind (whereAreWe _ startBit)
-			     (nFixed _ 0) for field in spec:typeType:typeParm as size in bits
-			  join (if (AND (LISTP field:fieldType)
-					field:fieldType:typeName=
-					'SEQUENCE)
-				   then (if seq?
-					    then (seqSpec_field)
-						 (seqSubSpec_field:fieldType:typeParm:1) 
-
-          (* * * This should be a call to \MakeMarshal1 but because of a CEDAR Lupine bug, is not (see below for more 
-	  discussion) -
-	  If CEDAR is ever fixed, the call should be as follows: (SETQ seqEltStore (\MakeMarshal1 seqSubSpec 
-	  (QUOTE l..datum) fn name typeTable whereAreWe size (QUOTE l..pup))))
-
-
-						 [seqEltStore_(\MakeMarshal seqSubSpec 'l..datum
-									    fn name typeTable
-									    (if seqStatic?_(\IsStatic
-										  seqSubSpec 
-										  typeTable)
-										then 'l..pup
-									      else 'l..cPup]
-					  else (SHOULDNT))
-					NIL
-				 elseif (\LupineNotFixed field typeTable)
-				   then (add nFixed 1)
-					(someNot_T)
-					NIL
-				 else (mc_(\MakeMarshal1 field:fieldType
-							 (BQUOTE (fetch (, (fetch type of spec)
-									   ,
-									   (fetch fieldName
-									      of field))
-								    of l..datum))
-							 fn name typeTable whereAreWe size
-							 'l..pup))
-				      [if mc:notFixed
-					  then
-					   notFixed_(NCONC1
-					     notFixed
-					     (BQUOTE (LET ((l..datum (fetch (, (fetch type
-										  of spec)
-									       ,
-									       (fetch fieldName
-										  of field))
-									of l..datum)))
-						       .,
-						       (fetch notFixed of mc]
-				      (mc_mc:fixed)
-				      (whereAreWe_(LOGAND 15 (IPLUS whereAreWe size)))
-				      (if (NOT (ZEROP nFixed))
-					  then (PROG1 (CONS (BQUOTE (\SkipBytesOut l..pup ,
-										   (LLSH nFixed 2)))
-							    mc)
-						      nFixed_0)
-					else mc))
-			  finally (if (NOT (ZEROP nFixed))
-				      then $$VAL_(NCONC1 $$VAL (BQUOTE (\SkipBytesOut l..pup ,
-										      (LLSH nFixed 2]
-	       (if someNot
-		   then [indirects_(for field in spec:typeType:typeParm when (\LupineNotFixed field 
-											typeTable)
-				      join (\MakeMarshal field:fieldType
-							 (BQUOTE (fetch (, (fetch type of spec)
-									   ,
-									   (fetch fieldName
-									      of field))
-								    of l..datum))
-							 fn name typeTable 'l..cPup]
-			(notFixed_(NCONC notFixed indirects)))
-	       [if seq?
-		   then (LET (code f nf)
-
-          (* * the code in this comment is the way this **should** work, with only the non-statics following after, but in 
-	  fact as CEDAR Lupine stands if a sequence%'s element type has any non-static parts, the WHOLE element gets repeated.
-	  There is a further patch associated with this higher up in this function. If this ever gets fixed, replace the if 
-	  statement which follows this comment with this code: (if (fetch notFixed of seqEltStore) then 
-	  (SETQ f (fetch fixed of seqEltStore)) (SETQ nf (fetch notFixed of seqEltStore)) elseif (\LupineNotFixed 
-	  (fetch fieldType of seqSpec) typeTable) then (SETQ code (LIST (QUOTE (\SkipBytesOut l..pup (LLSH 
-	  (LENGTH l..sequence) 2))))) (SETQ nf (fetch fixed of seqEltStore)) else (SETQ f (fetch fixed of seqEltStore))))
-
-
-			  (if seqStatic?
-			      then f_seqEltStore
-			    else [code_(LIST (BQUOTE (\SkipBytesOut l..pup
-								    (ITIMES ,
-									    (LRSH (\TypeSize 
-										       seqSubSpec 
-											typeTable)
-										  3)
-									    (LENGTH l..sequence]
-				 (nf_seqEltStore))
-			  [if f
-			      then code_(LIST (BQUOTE (for l..datum in l..sequence do ., f]
-			  [if nf
-			      then notFixed_(NCONC1 notFixed
-						    (BQUOTE (for l..datum
-							       in (fetch (, (fetch type of spec)
-									    ,
-									    (fetch fieldName
-									       of seqSpec))
-								     of l..datum)
-							       do ., nf]
-			  stores_(BQUOTE ((\CheckPupOverflow l..pup 6)
-					  (if l..datum
-					      then (LET ((l..sequence (fetch (, (fetch type
-										   of spec)
-										,
-										(fetch fieldName
-										   of seqSpec))
-									 of l..datum)))
-						     (\AddPupBoolean l..pup NIL l..conv)
-						     (\AddPupDblWord l..pup (LENGTH l..sequence)
-								     l..conv)
-						     ., stores ., code)
-					    else (\AddPupBoolean l..pup T l..conv]
-	       [if (AND seq? notFixed)
-		   then notFixed_(LIST (BQUOTE (if l..datum
-						   then ., notFixed]
-	       (APPLY* (FUNCTION DEFINEQ)
-		       (BQUOTE (, fnName (l..pup l..datum l..conv)
-                                                             (* Lupine generated stub)
-				  ., stores)))
-
-          (* * must record the notFixed generated here so they get used if the function gets re-used)
-
-
-	       (PUT fnName 'LupineNotFixed
-		    notFixed)
-	       (push $fns$ fnName)
-	       (push spec:definedStubs fnName)
-	else notFixed_(APPEND (GETP fnName 'LupineNotFixed]
-      (create Fragment
-	      fixed _(LIST (BQUOTE (, fnName , pupName , val l..conv)))
-	      notFixed _ notFixed])
-
-(\FixedStore
-  [LAMBDA (size type val whereAreWe fn name typeTable)       (* ht: " 1-Aug-85 09:10")
-    (LET ((typeName (\TypeName type))
-       (typeParm (if (LISTP type)
-		     then type:typeParm))
-       rf bitNum form)
-      (SELECTQ typeName
-	       (RECORD (SHOULDNT))
-	       ((BOOLEAN BITS ENUMERATION)
-
-          (* * compute the field descriptor)
-
-
-		 bitNum_
-		 (IPLUS (LLSH whereAreWe 4)
-			size-1)
-
-          (* * make the call to FETCHFIELD)
-
-
-		 form_
-		 (SELECTQ typeName
-			  (BITS val)
-			  [ENUMERATION (BQUOTE (for l..i from 0 as l..t in (QUOTE , typeParm)
-						  do (if (EQ l..t , val)
-							 then (RETURN l..i))
-						  finally (Signal 'BoundsCheck
-								  (CONS , val (QUOTE , typeParm]
-			  (BOOLEAN (BQUOTE (if , val
-					       then 1
-					     else 0)))
-			  (SHOULDNT))
-		 rf_
-		 (BQUOTE (REPLACEFIELD '(NIL 0 (BITS ., bitNum))
-				       (\CurrentPupPosition l..pup)
-				       , form))
-		 (if (ZEROP whereAreWe)
-		     then 
-
-          (* * need to check there is room in the l..pup)
-
-
-			  (BQUOTE ((\CheckPupOverflow l..pup 2)
-				   , rf))
-		   elseif (IPLUS whereAreWe size)=16
-		     then 
-
-          (* * must advance the counter -
-	  must use LIST here because BQUOTE causes NCONC problems)
-
-
-			  (LIST rf '(\IncrPupLength l..pup 2))
-		   else (LIST rf)))
-	       (SHOULDNT])
-
-(\MakeArgsMarshal
-  [LAMBDA (spec fn multTypeName varName typeTable)           (* ht: "31-Jul-85 11:44")
-    (LET (resultSpec)
-      (if (AND (LITATOM spec)
-	       resultSpec_(\BaseType spec typeTable)
-	       (LISTP resultSpec)
-	       resultSpec:typeName=multTypeName)
-	  then                                               (* unpack a record)
-	       (push $rNames$ spec)
-	       (for rBit in (\StaticsFirst resultSpec:typeParm typeTable)
-		  join (\MakeMarshal rBit:fieldType (BQUOTE (fetch (, spec , (fetch fieldName
-										of rBit))
-							       of , varName))
-				     fn rBit:fieldName typeTable))
-	else (\MakeMarshal spec varName fn varName typeTable])
-)
-
-
-
-(* Checking of declarations)
-
-(DEFINEQ
-
-(\CheckSpec
-  [LAMBDA (spec typeTable sigFlg)                            (* ht: "31-Jul-85 11:35")
-    (if (NLISTP spec)
-	then (ERROR "each spec must be a list" spec))
-    (if spec:fn~= '*
-	then (if (NOT (LITATOM spec:fn))
-		 then (ERROR "the fn/signal of a spec must be an atom" spec:fn))
-	     (if (NLISTP spec:specs)
-		 then (if spec:specs
-			  then (ERROR "the arg specs of a spec must be a list" spec:specs)))
-	     (if (OR spec:specs=NIL (U-CASE spec:specs:1:argName)= 'RETURNS)
-		 then (printout T "Note: " spec:fn " has no args" T))
-	     (bind aSpec argsAlready [an _(if (AND (NOT sigFlg)
-						   (GETD (fetch fn of spec)))
-					      then (ARGLIST (fetch fn of spec]
-		for specP on spec:specs
-		do (if (U-CASE specP:1:argName)= 'RETURNS
-		       then (if specP::1
-				then (ERROR "RETURNS must be the last spec" specP)
-			      else (GO $$OUT))
-		     else aSpec_specP:1)
-		   (if sigFlg
-		       then (if (AND (U-CASE specP:1:argName)= 'ARGS
-				     (NOT argsAlready))
-				then argsAlready_T
-			      else (ERROR "first and only arg spec for a signal must be called ARGS"))
-			    (\CheckType aSpec typeTable NIL T)
-		     else (if an
-			      then [if aSpec:argName=an:1
-				       then (pop an)
-				     else (ERROR "arg name not right" (CONS aSpec:argName
-									    (pop an]
-			    else (if (NOT (LITATOM aSpec:argName))
-				     then (ERROR "arg name must be litatom" aSpec))
-				 (if (GETD spec:fn)
-				     then (printout T "Note: spec has more arguments than function" , 
-						    spec:fn , aSpec T)))
-			  (\CheckType aSpec typeTable))
-		finally (if an
-			    then (printout T "Note: spec has fewer arguments than function" , spec:fn 
-					   T)))
-	     (LET ((last spec:-1))
-	       (if (U-CASE last:argName)= 'RETURNS
-		   then (\CheckType last typeTable NIL T)
-		 else (printout T "Note: " spec:fn " has no result" T])
-
-(\CheckType
-  [LAMBDA (spec typeTable inDecl inSpecial inRef inSeq)      (* ht: "30-Jul-85 09:01")
-    (\CheckType1 spec (\TypeName spec:argType)
-		 (if (LISTP spec:argType)
-		     then spec:argType:typeParm)
-		 typeTable inDecl inSpecial inRef inSeq])
-
-(\CheckType1
-  [LAMBDA (spec typeName typeParm typeTable inDecl inSpecial inRef inSeq)
-                                                             (* ht: "31-Jul-85 15:57")
-    (LET (trueType)
-      (if (FMEMB typeName \LupinePrimativeTypes)
-	  then (if (FMEMB typeName \LupineTypesWithParm)
-		   then (if (NOT typeParm)
-			    then (ERROR "Must have type parm for type" spec))
-			(SELECTQ typeName
-				 ((LIST REF SEQUENCE)
-				   (if (AND typeName= 'SEQUENCE
-					    (NOT inSeq))
-				       then (ERROR "SEQUENCE field can occur only in SEQRECORDs" spec)
-				       )
-				   (\CheckType spec:argType typeTable NIL NIL typeName= 'REF))
-				 (BITS (if (NOT (AND (NUMBERP typeParm:1)
-						     (IGREATERP typeParm:1 0)
-						     (OR (ILEQ typeParm:1 16)
-							 typeParm:1=32)
-						     typeParm::1=NIL))
-					   then (ERROR 
-			   "BITS type must have exactly one  numeric parameter in [1..16] U [32]"
-						       spec)))
-				 ((RECORD RESULT SIGARGS)
-				   (if (NOT inDecl)
-				       then (ERROR 
-	    "In line RECORDs/RESULTs/SIGARGSs not allowed - must be pre-declared as a named type"
-						   spec))
-				   (\CheckRecordDecl spec typeParm)
-				   (for fs in typeParm do (\CheckType fs typeTable)))
-				 (SEQRECORD (if (NOT inDecl)
-						then (ERROR 
-			  "In line SEQRECORDs not allowed - must be pre-declared as a named type"
-							    spec))
-					    (\CheckRecordDecl spec typeParm)
-					    (if [NOT (for fieldSpecPointer on typeParm
-							thereis (PROG1 (if (U-CASE (\TypeName 
-								     fieldSpecPointer:1:fieldType))=
-									   'SEQUENCE
-									   then (if 
-									      fieldSpecPointer::1
-										    then
-										     (ERROR 
-						 "SEQUENCE must be the last field of a SEQRECORD"
-											    spec)
-										  else T))
-								       (\CheckType fieldSpecPointer:1 
-										   typeTable NIL NIL 
-										   NIL T]
-						then (ERROR 
-						       "SEQRECORD must end with a SEQUENCE field"
-							    spec))
-					    (if (NOT (FMEMB (\TypeName typeParm:-2:fieldType)
-							    \LupineNumberTypes))
-						then (printout T 
-				  "Warning - next to last field in SEQRECORD not a numeric type?"
-							       , spec)))
-				 NIL)
-		 elseif typeParm
-		   then (ERROR "Shouldnt have type parm for type" spec))
-	elseif (ASSOC typeName typeTable)
-	  then (if typeParm
-		   then (ERROR "Shouldnt have type parm for user-defined type" spec))
-	       (trueType_(\BaseType typeName typeTable))
-	       (if (LISTP trueType)
-		   then (if (AND (FMEMB trueType:typeName \LupineDummyTypes)
-				 (NOT inSpecial))
-			    then (ERROR "Can't use RESULT/SIGARGS except from RETURNS/ARGS spec" spec)
-			  elseif (AND trueType:typeName= 'SEQRECORD
-				      (NOT inRef))
-			    then (ERROR "Must get to SEQRECORD via a REF, not directly" spec)))
-	else (ERROR "Not a type" spec])
-
-(\CheckRecordDecl
-  [LAMBDA (spec fieldSpecs)                                  (* ht: "30-Jul-85 09:41")
-    (LET ((recFields (RECORDFIELDNAMES spec:fieldName)))
-      (if (NOT recFields)
-	  then (ERROR "No record declaration for record type" spec))
-      (if [NOT (AND (LENGTH recFields)=(LENGTH fieldSpecs)
-		    (for fieldSpec in fieldSpecs always (FMEMB fieldSpec:fieldName recFields]
-	  then (ERROR "Field names in type declaration don't match up  with those of record"
-		      (LIST recFields spec])
-)
-
-
-
-(* Type table construction)
-
-(DEFINEQ
-
-(\DeclareTypes
-  [LAMBDA (typeDecls)                                        (* ht: "31-Jul-85 14:50")
-    (bind newEntry (typeTable _(APPEND \LupineInitialTypeTable))
-	  allocation for ty in typeDecls unless ty:type= '*
-       do (if (NOT (AND ty:type (LITATOM ty:type)))
-	      then (ERROR "type declaration must begin with an atomic type name" ty))
-	  (if (OR NOT (ty:typeType)
-		  ty::2)
-	      then (ERROR "there must be one and only one type in a type declaration" ty))
-	  (if (U-CASE ty:type)= 'INCLUDE
-	      then (if (AND ty:typeType (LITATOM ty:typeType))
-		       then typeTable_(NCONC typeTable (\DeclareTypes (EVALV ty:typeType)))
-		     else (ERROR "INCLUDE must be of the form (INCLUDE <litatom>)" ty))
-	    else (\CheckType ty typeTable T)
-		 (newEntry_(create TypeSpec
-				   type _ ty:type
-				   typeType _ ty:typeType))
-		 (if (NOT (AND (LISTP ty:typeType)
-			       (FMEMB (U-CASE ty:typeType:typeName)
-				      \LupineDummyTypes)))
-		     then (allocation_(\Allocate ty:typeType typeTable))
-			  (newEntry:typeSize_allocation:need)
-			  (newEntry:typeBits_allocation:fields))
-		 (push typeTable newEntry))
-       finally (RETURN typeTable])
-
-(\Allocate
-  [LAMBDA (type typeTable subFlg)                            (* ht: "29-Jul-85 13:38")
-    (let ((typeName (\TypeName type))
-	  (typeParm (if (LISTP type)
-			then type:typeParm))
-	  res rRes)
-	 res_[SELECTQ typeName
-		      ((STRING ATOM LIST STREAM ARB FIXP REF SEQUENCE)
-			32)
-		      (SSMALLP 16)
-		      ((RECORD SEQRECORD)
-			rRes_
-			(\AllocateRecord typeName typeParm typeTable)
-			(if subFlg
-			    then rRes:need
-			  else rRes))
-		      (if (FMEMB typeName \LupinePrimativeTypes)
-			  then (let [(need (SELECTQ typeName
-						    (BOOLEAN 1)
-						    (BITS typeParm:1)
-						    [ENUMERATION
-						      (IMAX 1 (bind (max _(SUB1 (LENGTH typeParm)))
-								 until (ZEROP max)
-								 count max_(LRSH max 1]
-						    (SHOULDNT]
-				    (if (IGREATERP need 16)
-					then (SHOULDNT "Too big")
-				      else need))
-			else                                 (* user defined type)
-			     (fetch typeSize of (\TypeLayout typeName typeTable]
-	 (if subFlg
-	     then (LIST res)
-	   else (OR (LISTP res)
-		    (create RecordLayout
-			    need _ res
-			    fields _(LIST res])
-
-(\AllocateRecord
-  [LAMBDA (typeName typeParm typeTable)                      (* ht: "24-Jul-85 19:33")
-    (bind (bitsLeft _ 16)
-	  (wordsUsed _ 0)
-	  left sub need for t in typeParm
-       join (sub_(\Allocate t:fieldType typeTable T))
-	    (need_sub:1)
-	    (if (IGREATERP need bitsLeft)
-		then (if (ZEROP bitsLeft)
-			 then 
-
-          (* * run out -
-	  fix it)
-
-
-			      (add wordsUsed 1)
-		       elseif bitsLeft~=16
-			 then 
-
-          (* * expand the leftmost bit of the last thing to fit)
-
-
-			      (add left:1 bitsLeft)
-			      (add wordsUsed 1))
-		     (bitsLeft_16)
-		     (if (IGREATERP need 15)
-			 then 
-
-          (* * must be some number of words)
-
-
-			      (add wordsUsed (LRSH need 4))
-			      (need_0)
-		       else bitsLeft_bitsLeft-need)
-	      else bitsLeft_bitsLeft-need)
-	    (left_sub)
-       finally (if (ZEROP bitsLeft)
-		   then (add wordsUsed 1)
-		 elseif (AND (NOT (ZEROP wordsUsed))
-			     bitsLeft~=16)
-		   then 
-
-          (* * only sub-word records are allowed to be not a multiple of 16 -
-	  pad)
-
-
-			(add left:1 bitsLeft)
-			(add wordsUsed 1))
-	       (RETURN (create RecordLayout
-			       need _(if (ZEROP wordsUsed)
-					 then 16-bitsLeft
-				       else (LLSH wordsUsed 4))
-			       fields _ $$VAL])
-)
-
-
-
-(* Utilities)
-
-(DEFINEQ
-
-(\TypeName
-  [LAMBDA (type)                                             (* ht: "26-Jul-85 09:14")
-    (LET ((typen (if (LISTP type)
-		     then type:typeName
-		   else type)))
-      (if (FMEMB (U-CASE typen)
-		 \LupinePrimativeTypes)
-	  then (U-CASE typen)
-	else typen])
-
-(\BaseType
-  [LAMBDA (type typeTable)                                   (* ht: "26-Jul-85 09:04")
-    (LET ((typeName (\TypeName type)))
-      (if (FMEMB typeName \LupinePrimativeTypes)
-	  then type
-	else (\BaseType (fetch typeType of (\TypeLayout typeName typeTable))
-			typeTable])
-
-(\TypeLayout
-  [LAMBDA (typeName typeTable)                               (* ht: "24-Jul-85 11:32")
-    (OR (ASSOC typeName typeTable)
-	(HELP "Type not defined" typeName])
-
-(\TypeSize
-  [LAMBDA (type typeTable)                                   (* ht: "31-Jul-85 09:21")
-    (LET ((typeName (\TypeName type))
-       entry)
-      (if entry_(ASSOC typeName typeTable)
-	  then entry:typeSize
-	elseif (FMEMB typeName \LupineNotFixedTypes)
-	  then 32
-	else 16])
-
-(\LupineNotFixed
-  [LAMBDA (field typeTable)                                  (* ht: "26-Jul-85 09:08")
-    (FMEMB (\TypeName (\BaseType field:fieldType typeTable))
-	   \LupineNotFixedTypes])
-
-(\StaticsFirst
-  [LAMBDA (specs typeTable)                                  (* ht: "25-Jul-85 16:13")
-    (bind nonStatics for s in specs when (if (U-CASE s:argName)
-					     ~=
-					     'RETURNS
-					     then (if (\IsStatic s:argType typeTable)
-						    else (nonStatics_(NCONC1 nonStatics s))
-							 NIL))
-       collect s finally (RETURN (NCONC $$VAL nonStatics])
-
-(\IsStatic
-  [LAMBDA (type typeTable)                                   (* ht: "26-Jul-85 09:01")
-    (LET* ((trueType (\BaseType type typeTable))
-       (typeName (\TypeName trueType)))
-      (OR (MEMB typeName \LupineStatics)
-	  (AND typeName= 'RECORD
-	       (for f in trueType:typeParm always (\IsStatic f:fieldType typeTable])
-)
-
-(RPAQQ \LupineGetFns ((SSMALLP . \GetArgSmallp)
-			(FIXP . \GetArgDblWord)
-			(BOOLEAN . \GetArgBool)
-			(STRING . \UnmarshalString)
-			(ATOM . \UnmarshalAtom)
-			(STREAM . \UnmarshalStream)
-			(ENUMERATION . \GetArgEnum)
-			(ARB . \UnmarshalArb)))
-
-(RPAQQ \LupinePutFns ((SSMALLP . \AddPupSmallp)
-			(FIXP . \AddPupDblWord)
-			(BOOLEAN . \AddPupBoolean)
-			(STRING . \MarshalString)
-			(ATOM . \MarshalAtom)
-			(STREAM . \MarshalStream)
-			(ENUMERATION . \AddPupEnum)
-			(ARB . \MarshalArb)
-			(BITS . \AddPupWord)))
-
-(RPAQQ \LupinePrimativeTypes (SSMALLP FIXP BOOLEAN STRING ATOM STREAM ENUMERATION ARB BITS LIST 
-					RECORD RESULT SIGARGS REF SEQRECORD SEQUENCE))
-
-(RPAQQ \LupineInitialTypeTable ((CARDINAL (BITS 16)
-					    NIL 16 16)
-				  (* the next is not true, but is as close as we get)
-				  (LONGCARDINAL (BITS 32)
-						NIL 32 32)))
-
-(RPAQQ \LupineNumberTypes (FIXP SSMALLP ENUMERATION BITS))
-
-(RPAQQ \LupineNotFixedTypes (STRING ATOM STREAM ARB LIST REF))
-
-(RPAQQ \LupineDummyTypes (RESULT SIGARGS))
-
-(RPAQQ \LupineStatics (SSMALLP FIXP BOOLEAN ENUMERATION BITS))
-
-(RPAQQ \LupineTypesWithParm (ENUMERATION BITS LIST REF SEQRECORD SEQUENCE RECORD RESULT SIGARGS 
-					   STREAM))
-(DECLARE: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \LupineGetFns \LupinePutFns \LupineStatics \LupineTypesWithParm \LupinePrimativeTypes 
-	    \LupineDummyTypes \LupineNotFixedTypes \LupineNumberTypes \LupineInitialTypeTable)
-)
-(DECLARE: DONTCOPY 
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ \FirstLupineUserCall 4)
-
-(RPAQQ \FirstLupineSignal 4)
-
-(CONSTANTS (\FirstLupineUserCall 4)
-	   (\FirstLupineSignal 4))
-)
-)
-(PUTPROPS LUPINE COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (1917 43384 (Lupine 1927 . 3884) (\ServerComs 3886 . 10078) (\MakeUnmarshal 10080 . 
-10581) (\MakeUnmarshal1 10583 . 14428) (\MakeUnmarshalRecord 14430 . 22709) (\FixedFetch 22711 . 23977
-) (\MakeArgsUnmarshal 23979 . 24867) (\ClientComs 24869 . 30430) (\MakeMarshal 30432 . 31021) (
-\MakeMarshal1 31023 . 34722) (\MakeMarshalRecord 34724 . 41100) (\FixedStore 41102 . 42627) (
-\MakeArgsMarshal 42629 . 43382)) (43422 49673 (\CheckSpec 43432 . 45630) (\CheckType 45632 . 45912) (
-\CheckType1 45914 . 49088) (\CheckRecordDecl 49090 . 49671)) (49710 53777 (\DeclareTypes 49720 . 51058
-) (\Allocate 51060 . 52323) (\AllocateRecord 52325 . 53775)) (53800 56008 (\TypeName 53810 . 54128) (
-\BaseType 54130 . 54457) (\TypeLayout 54459 . 54650) (\TypeSize 54652 . 54975) (\LupineNotFixed 54977
- . 55188) (\StaticsFirst 55190 . 55629) (\IsStatic 55631 . 56006)))))
-STOP
diff --git a/obsolete/lispusers/LoadPatches b/obsolete/lispusers/LoadPatches
deleted file mode 100644
index 2de5a1e6..00000000
--- a/obsolete/lispusers/LoadPatches
+++ /dev/null
@@ -1,72 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "16-Nov-88 14:11:42" {PHYLUM}<BURWELL>LISP>LYRIC>LOADPATCHES.;3 3441   
-
-      changes to%:  (VARS LOADPATCHESCOMS)
-                    (FNS LoadPatches COLLECT-PATCH-FILES)
-
-      previous date%: "27-Sep-88 22:56:49" {PHYLUM}<BURWELL>LISP>LYRIC>LOADPATCHES.;1)
-
-
-(* "
-Copyright (c) 1985, 1988 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT LOADPATCHESCOMS)
-
-(RPAQQ LOADPATCHESCOMS ((FNS LoadPatches COLLECT-PATCH-FILES)
-                        (DECLARE%: DONTCOPY (PROP FILETYPE LOADPATCHES))))
-(DEFINEQ
-
-(LoadPatches
-  [LAMBDA (DIRECTORY LDFLG AFTERDATE)                      (* ; "Edited 16-Nov-88 13:08 by Burwell")
-
-(* ;;; "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 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 16-Nov-88 13:13 by Burwell")
-
-    (* ;; "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))))])
-)
-(DECLARE%: DONTCOPY 
-
-(PUTPROPS LOADPATCHES FILETYPE :COMPILE-FILE)
-)
-(PUTPROPS LOADPATCHES COPYRIGHT ("Xerox Corporation" 1985 1988))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (608 3275 (LoadPatches 618 . 2308) (COLLECT-PATCH-FILES 2310 . 3273)))))
-STOP
diff --git a/obsolete/lispusers/MATHSERVER b/obsolete/lispusers/MATHSERVER
deleted file mode 100644
index c52bd79f..00000000
--- a/obsolete/lispusers/MATHSERVER
+++ /dev/null
@@ -1,3637 +0,0 @@
-(FILECREATED "15-Apr-87 10:54:01" {IVY}<BLOOMBERG>LISP>MATHSERVER.;1 129647 
-
-      changes to:  (METHODS Server.ExecuteCommandFile)
-		   (FNS Server.ExecuteCommandFile MS.TopLevel MS.ExpandFilename MS.SubmitBatchJob 
-			MS.RunInteractiveJob MS.Compile MS.Link MS.CompileLink MS.CompileLinkRun 
-			MS.StartDefaultFE)
-		   (VARS MATHSERVERCOMS)
-
-      previous date: "12-Dec-86 19:13:28" {PHYLUM}<LISPUSERS>KOTO>MATHSERVER.;1)
-
-
-(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT MATHSERVERCOMS)
-
-(RPAQQ MATHSERVERCOMS ((* * SERVER MENU - Sets up the main Server Free Menu)
-	(* MENU AND WINDOW FUNCTIONS)
-	(FNS MS.TopLevel MS.CreateFreeMenu MS.SelectHost MS.ExpandFilename MS.CloseErrorWindow 
-	     MS.CleanupErrorFile MS.AttachErrorWindow MS.MostRoom MS.GetMessageWindow 
-	     MS.MakeIconWindow PrintMsg)
-	(* SERVER METACLASS FUNCTIONS)
-	(FNS MS.MakeMenuOfKnownHosts MS.DestroyInstances)
-	(* MATH SERVER FUNCTIONS)
-	(FNS MS.SubmitBatchJob MS.AbortBatchJob MS.Status MS.DisplayStatus MS.RunInteractiveJob 
-	     MS.Compile MS.Link MS.CompileLink MS.CLR.Check MS.CLR.NoCheck MS.CompileLinkRun)
-	(* FORTRAN EDITOR FUNCTIONS)
-	(FNS MS.StartNewFE MS.StartDefaultFE MS.FindFortranEdit MS.CheckForDirtyFile)
-	(* ERROR HANDLING FUNCTIONS)
-	(FNS MS.BatchErrors? MS.BatchLog)
-	(* Icon BITMAPS)
-	(BITMAPS MS.Icon MS.IconMask)
-	(* VARS)
-	(ADDVARS (BackgroundMenuCommands (Server% Menu (QUOTE (MS.TopLevel))
-						       "Start the Server Menu")))
-	(VARS (BackgroundMenu NIL))
-	(GLOBALVARS MS.HostPopMenu)
-	(* * FORTRAN EDIT - Sets up a Fortran Edit Process)
-	(* MAIN FUNCTIONS)
-	(FNS FE.TopLevel FE.AdjustProps FE.CaretPosition TEDIT.PARA&CHAR FE.CharFn FE.GetEditProps 
-	     FE.GetSourceFileName FE.LoopFn)
-	(* WINDOW FUNCTIONS)
-	(FNS FE.GetPositionWindow FE.GetEditWindow FE.GetMessageWindow FE.ReshapeFn FE.ShadeWindow)
-	(* LOCALMENU FUNCTIONS)
-	(FNS FE.CreateLocalMenu FE.SetHost FE.SetDirectory FE.MyGet FE.MyPut FE.StripVersion 
-	     FE.Compile FE.Link FE.CompileLinkRun FE.RunInteractive)
-	(* SERVER METACLASS FUNCTIONS)
-	(FNS FE.ValidHostname FE.GetServer)
-	(* ICON STUFF)
-	(FNS FE.ShrinkIconCreate)
-	(BITMAPS FE.Icon FE.IconMask)
-	(INITVARS (FE.defaultFont (FONTCLASS (QUOTE FORTRANEDITFONT)
-					     (QUOTE (1 (GACHA 12)
-						       (GACHA 10)
-						       (GACHA 10)))))
-		  (FE.iconFont (FONTCREATE (QUOTE HELVETICA)
-					   8
-					   (QUOTE BOLD)))
-		  (FE.iconTitleRegion (create REGION LEFT _ 8 BOTTOM _ 8 WIDTH _ 110 HEIGHT _ 40))
-		  (FE.titledIconTemplate (create TITLEDICON ICON _ FE.Icon MASK _ FE.IconMask 
-						 TITLEREG _ FE.iconTitleRegion)))
-	(* VARS)
-	(ADDVARS (BackgroundMenuCommands (Fortran% Edit (QUOTE (FE.TopLevel))
-							"Start a Fortran Edit")))
-	(VARS (BackgroundMenu NIL))
-	(GLOBALVARS FE.defaultFont FE.iconFont FE.titledIconTemplate TEDIT.READTABLE)
-	(* * SERVERS -- Defines the Loops MathServer objects)
-	(CLASSES Cray FortranServer MathServer Server VMSServer)
-	(METHODS FortranServer.Compile FortranServer.Compiled? FortranServer.Link 
-		 FortranServer.Linked? MathServer.AlertManager Server.AbortJob 
-		 Server.CommandFileExtension Server.Description Server.Error? Server.ErrorFile 
-		 Server.ErrorString Server.ExecuteCommandFile Server.ExtractFilename Server.GetQueues 
-		 Server.GetTime Server.Host Server.MakeError Server.MakeFullName 
-		 Server.MakePartialName Server.Name Server.PutErrorInWindow Server.PutTextInWindow 
-		 Server.Result Server.RunFile Server.RunJob Server.ServerDirectory 
-		 Server.SourceExtension Server.Status Server.SubmitJob Server.UserDirectory 
-		 VMSServer.MakeCommandString)
-	(FNS MS.MakeInstances StripPA)
-	(P (MS.DestroyInstances)
-	   (MS.MakeInstances))
-	(* * PROGRAMCHAT - Windowless CHAT for communication)
-	(FNS OPENCHATSTREAM PROGRAMCHAT PROGRAMCHAT.LOGIN PROGRAMCHAT.OUTPUT)
-	(* VARS for our site)
-	(VARS NETWORKLOGINFO)
-	(P (pushnew NETWORKOSTYPES (QUOTE (GSLVAX . VMS))
-		    (QUOTE (SITKA . VMS))
-		    (QUOTE (MADVAX . VMS))))
-	(* * PROGRAMMER'S INTERFACE - use remote servers with LISP calls)
-	(FNS PRIN.RunRemote PRIN.ValidateHost PRIN.ValidateFilename PRIN.Error)))
-(* * SERVER MENU - Sets up the main Server Free Menu)
-
-
-
-
-(* MENU AND WINDOW FUNCTIONS)
-
-(DEFINEQ
-
-(MS.TopLevel
-  (LAMBDA NIL                                                (* DSB "15-Apr-87 10:19")
-                                                             (* Sets up the ServerFreeMenu, with PopUpMenu for host
-							     selection and with attached messageWindow)
-    (PROG (menuWindow menuRegion messageWindow side)
-	    (SETQ menuWindow (MS.CreateFreeMenu 470 470))
-	    (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE QUEUE))
-			      menuWindow)
-	    (SETQ menuRegion (WINDOWPROP menuWindow (QUOTE REGION)))
-
-          (* * Create PopUp menu for selection of Host)
-
-
-	    (SETQ MS.HostPopMenu (MS.MakeMenuOfKnownHosts))
-
-          (* * create, attach and save pointer to messageWindow)
-
-
-	    (SETQ messageWindow (CREATEW (CREATEREGION 0 0 200 150)
-					     "Message Window" NIL T))
-	    (SETQ side (QUOTE LEFT))
-	    (COND
-	      ((EQ (QUOTE LEFT)
-		     (MS.MostRoom menuWindow))
-		(SETQ side (QUOTE RIGHT)))
-	      (T NIL))
-	    (ATTACHWINDOW messageWindow menuWindow side (QUOTE JUSTIFY))
-	    (WINDOWPROP menuWindow (QUOTE MessageWindow)
-			  messageWindow)
-	    (WINDOWPROP menuWindow (QUOTE ICONFN)
-			  (FUNCTION MS.MakeIconWindow))
-	    (OPENW menuWindow))))
-
-(MS.CreateFreeMenu
-  (LAMBDA (LEFT BOTTOM)                                      (* DSB " 9-Dec-86 15:50")
-                                                             (* returns a free menu window at specified position)
-    (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL FortranEdit-Commands: FONT (MODERN 12 BOLD))
-				 (LABEL StartNew SELECTEDFN MS.StartNewFE)
-				 (LABEL StartWithDefault SELECTEDFN MS.StartDefaultFE))
-				((TYPE TITLE LABEL PlotMenu-Commands: FONT (MODERN 12 BOLD))
-				 (LABEL SimplePlot SELECTEDFN MAPL.Simple.TopLevel)
-				 (LABEL Gen.Plot SELECTEDFN MAPL.Gen.TopLevel)
-				 (LABEL MetaPlot SELECTEDFN MAPL.Meta.TopLevel))
-				((TYPE TITLE LABEL Compiler-Commands: FONT (MODERN 12 BOLD))
-				 (LABEL Compile SELECTEDFN MS.Compile)
-				 (LABEL Link SELECTEDFN MS.Link)
-				 (LABEL C/L SELECTEDFN MS.CompileLink))
-				((TYPE TITLE LABEL Run-Commands: FONT (MODERN 12 BOLD))
-				 (LABEL RunInteractive SELECTEDFN MS.RunInteractiveJob)
-				 (LABEL C/L/R SELECTEDFN MS.CLR.NoCheck)
-				 (LABEL C?/L?/R SELECTEDFN MS.CLR.Check))
-				((TYPE TITLE LABEL Batch-Commands: FONT (MODERN 12 BOLD))
-				 (LABEL Submit SELECTEDFN MS.SubmitBatchJob)
-				 (LABEL Status SELECTEDFN MS.Status)
-				 (LABEL Errors? SELECTEDFN MS.BatchErrors?)
-				 (LABEL Abort SELECTEDFN MS.AbortBatchJob)
-				 (LABEL Log SELECTEDFN MS.BatchLog))
-				((TYPE TITLE LABEL "COMPUTE SERVER FILE INFO" FONT (MODERN 12 BOLD)))
-				((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (FILENAME))
-				 (TYPE EDIT ID FILENAME LABEL ""))
-				((TYPE EDITSTART LABEL DefaultDirectory: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (DEFAULTDIRECTORY))
-				 (TYPE EDIT ID DEFAULTDIRECTORY LABEL ""))
-				((TYPE EDITSTART LABEL JobParameters: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (PARAMETERSTRING))
-				 (TYPE EDIT ID PARAMETERSTRING LABEL ""))
-				((TYPE EDITSTART LABEL LinkParameters: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (LINKSTRING))
-				 (TYPE EDIT ID LINKSTRING LABEL ""))
-				((TYPE TITLE LABEL "COMPUTE SERVER HOST INFO" FONT (MODERN 12 BOLD)))
-				((TYPE TITLE LABEL HostName: FONT (MODERN 12 BOLD)
-				       SELECTEDFN MS.SelectHost)
-				 (TYPE TITLE ID HOST LABEL ""))
-				((TYPE TITLE LABEL Queue: FONT (MODERN 12 BOLD))
-				 (TYPE NWAY ID QUEUE LABEL Fast CLASSNAME FastQueue)
-				 (TYPE NWAY ID QUEUE LABEL Medium CLASSNAME MediumQueue)
-				 (TYPE NWAY ID QUEUE LABEL Slow CLASSNAME SlowQueue))
-				((TYPE EDITSTART LABEL JobNumber: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (JOBNUMBER))
-				 (TYPE EDIT ID JOBNUMBER LABEL ""))
-				((TYPE TITLE LABEL SERVERBROWSER-Command: FONT (MODERN 12 BOLD))
-				 (LABEL MakeBrowser SELECTEDFN MS.MakeInstances))
-				(WINDOWPROPS TITLE "Server Menu" LEFT , LEFT BOTTOM , BOTTOM))))))
-
-(MS.SelectHost
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "10-Jun-86 18:17")
-                                                             (* Uses the pop-up menu MS.HostPopMenu to return a 
-							     label and a pointer to the Host Server.)
-    (PROG ((promptW (GETPROMPTWINDOW WINDOW))
-	     (sItem (FM.ITEMFROMID WINDOW (QUOTE HOST)))
-	     server)
-
-          (* * Opens the PopUp menu. Returns the object name of the selected server.)
-
-
-	    (CLEARW promptW)
-	    (PRIN1 "Select host." promptW)
-	    (SETQ server (MENU MS.HostPopMenu))
-	    (CLEARW promptW)
-
-          (* * if the server exists, set the Host prop of the "HOST" item in the menu to point to the Server object.
-	  Then change the item label to be the name of the Server object.)
-
-
-	    (COND
-	      (server (FM.ITEMPROP sItem (QUOTE Host)
-				     server)
-		      (FM.CHANGELABEL sItem WINDOW (_ server Name)))
-	      (T 
-
-          (* * otherwise, set both the Host prop and the label of the "HOST" item in the menu to nil.)
-
-
-		 (FM.ITEMPROP sItem (QUOTE Host)
-				NIL)
-		 (FM.CHANGELABEL sItem WINDOW ""))))))
-
-(MS.ExpandFilename
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Apr-87 10:22")
-                                                             (* if filename contains a directory, expand it into 
-							     separate slots)
-                                                             (* this is a shortened version of MAPL.ExpandFilename)
-    (PROG ((state (FM.READSTATE WINDOW))
-	     filename defaultDirectory name)
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-
-          (* * strip off any extensions and version numbers)
-
-
-	    (SETQ name (UNPACKFILENAME filename (QUOTE NAME)))
-	    (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE FILENAME))
-			      WINDOW name)
-
-          (* * if there is a directory, place it in the menu)
-
-
-	    (SETQ defaultDirectory (UNPACKFILENAME filename (QUOTE DIRECTORY)))
-	    (COND
-	      (defaultDirectory (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE DEFAULTDIRECTORY))
-						  WINDOW defaultDirectory)))
-
-          (* * update "state" and return)
-
-
-	    (SETQ state (FM.READSTATE WINDOW))
-	    (RETURN state))))
-
-(MS.CloseErrorWindow
-  (LAMBDA (mainWindow)                                       (* DSB "15-Aug-86 15:27")
-
-          (* * Check if an errorWindow already exists. If so, delete the {core} file behind it, clean up props, and finally 
-	  close the window.)
-
-
-    (LET (oldWindow oldFile)
-         (SETQ oldWindow (find item in (ATTACHEDWINDOWS mainWindow)
-			      suchthat (WINDOWPROP item (QUOTE ERRORFILE))))
-         (COND
-	   (oldWindow (MS.CleanupErrorFile oldWindow)
-		      (CLOSEW oldWindow))))))
-
-(MS.CleanupErrorFile
-  (LAMBDA (errorWindow)                                      (* DSB "15-Aug-86 15:30")
-                                                             (* deletes the error file that resides in {core}, if 
-							     it exists, and resets errorWindow prop to NIL)
-    (LET ((oldFile (WINDOWPROP errorWindow (QUOTE ERRORFILE))))
-         (COND
-	   (oldFile (CLOSEF? oldFile)
-		    (DELFILE oldFile)
-		    (WINDOWPROP errorWindow (QUOTE ERRORFILE)
-				  NIL)))
-     NIL)))
-
-(MS.AttachErrorWindow
-  (LAMBDA (mainWindow title)                                 (* DSB "15-Aug-86 15:22")
-                                                             (* Attaches an error window to the main menu window)
-
-          (* * MS.CloseErrorWindow should have been called prior to this. Nevertheless, we check for an old errorWindow, and 
-	  if it exists, we call MS.CloseErrorWindow)
-
-
-
-          (* * Make the error window and attach it to the appropriate side of the main window)
-
-
-    (LET (oldWindow errorWindow)
-         (SETQ oldWindow (find item in (ATTACHEDWINDOWS mainWindow)
-			      suchthat (WINDOWPROP item (QUOTE ERRORFILE))))
-         (AND oldWindow (MS.CloseErrorWindow mainWindow))
-         (SETQ errorWindow (CREATEW (QUOTE (0 0 470 300))
-					title NIL T))
-         (ATTACHWINDOW errorWindow mainWindow (MS.MostRoom mainWindow)
-			 (QUOTE JUSTIFY)
-			 (QUOTE LOCALCLOSE))
-     errorWindow)))
-
-(MS.MostRoom
-  (LAMBDA (WINDOW)                                           (* DSB " 7-Aug-86 11:55")
-                                                             (* determines if attached window should be on right or
-							     left side of main window)
-    (LET ((region (WINDOWPROP WINDOW (QUOTE REGION)))
-	  leftSpace rightSpace)
-         (SETQ leftSpace (fetch (REGION LEFT) of region))
-         (SETQ rightSpace (DIFFERENCE 1025 (PLUS leftSpace (fetch (REGION WIDTH)
-								    of region))))
-         (COND
-	   ((GEQ leftSpace rightSpace)
-	     (QUOTE LEFT))
-	   (T (QUOTE RIGHT))))))
-
-(MS.GetMessageWindow
-  (LAMBDA (WINDOW)                                           (* DSB " 6-Jun-86 15:57")
-                                                             (* maybe later, we'll check if the message window 
-							     exists and if not, will make it first)
-    (WINDOWPROP WINDOW (QUOTE MessageWindow))))
-
-(MS.MakeIconWindow
-  (LAMBDA (WINDOW OLDICON)                                   (* DSB " 9-Dec-86 15:44")
-
-          (* * Creates a window with an icon formed by two bit maps.)
-
-
-    (OR OLDICON (ICONW MS.Icon MS.IconMask))))
-
-(PrintMsg
-  (LAMBDA (place msg)                                        (* thh: " 6-Nov-85 11:04")
-                                                             (* prints message in appropriate prompt window)
-                                                             (* no message if place = DON'T)
-    (COND
-      ((Object? place)
-	(_ place ClearPromptWindow)
-	(_ place PromptPrint msg))
-      ((TYPENAMEP place (QUOTE PLOT))
-	(LET ((w (PLOTPROP place (QUOTE PLOTPROMPTWINDOW))))
-	     (CLEARW w)
-	     (PRIN1 msg w)))
-      ((WINDOWP place)
-	(LET ((w (GETPROMPTWINDOW place 2)))
-	     (CLEARW w)
-	     (PRIN1 msg w)))
-      ((EQ place (QUOTE DON'T)))
-      (T (CLRPROMPT)
-	 (PROMPTPRINT msg)))))
-)
-
-
-
-(* SERVER METACLASS FUNCTIONS)
-
-(DEFINEQ
-
-(MS.MakeMenuOfKnownHosts
-  (LAMBDA NIL                                                (* DSB "19-Aug-86 17:05")
-                                                             (* makes the MS.HostPopMenu)
-    (create MENU
-	      ITEMS _(for server in (_ ($ Server)
-					     AllInstances!)
-			collect (LIST (_ server Name)
-					  server
-					  (_ server Description))))))
-
-(MS.DestroyInstances
-  (LAMBDA NIL                                                (* DSB "19-Aug-86 15:37")
-                                                             (* obvious! Use MS.MakeInstances after this.)
-    (for instance in (_ ($ Server)
-			      AllInstances!)
-       do (_ instance Destroy))))
-)
-
-
-
-(* MATH SERVER FUNCTIONS)
-
-(DEFINEQ
-
-(MS.SubmitBatchJob
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Apr-87 10:28")
-                                                             (* Creates the SubmitJob message to be sent to the 
-							     appropriate host)
-    (PROG (state (promptW (GETPROMPTWINDOW WINDOW))
-		   (messageW (MS.GetMessageWindow WINDOW))
-		   filename defaultDirectory host validQueues queue parameterString result)
-
-          (* * check that all required data is specified)
-
-
-	    (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS))
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (COND
-	      ((EQUAL filename "")
-		(PrintMsg WINDOW "Unspecified file name.")
-		(RETURN)))
-	    (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY)))
-	    (COND
-	      ((EQUAL defaultDirectory "")
-		(PrintMsg WINDOW "Unspecified default directory.")
-		(RETURN)))
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      ((NOT host)
-		(PrintMsg WINDOW "Unspecified host.")
-		(RETURN)))
-	    (SETQ validQueues (_ host GetQueues))
-	    (SETQ queue (LISTGET state (QUOTE QUEUE)))
-	    (COND
-	      ((NOT queue)
-		(PrintMsg WINDOW "Unspecified queue.")
-		(RETURN))
-	      ((NOT (MEMBER queue validQueues))
-		(CLEARW promptW)
-		(PRIN1 "Not a valid queue for this server" promptW)
-		(TERPRI promptW)
-		(PRINTOUT promptW "Valid queues:  " validQueues)
-		(RETURN)))
-	    (SETQ parameterString (LISTGET state (QUOTE PARAMETERSTRING)))
-	    (COND
-	      ((STRPOS "," parameterString)
-		(PrintMsg WINDOW "Remove comma(s) from JobParameters")
-		(RETURN)))
-
-          (* * return the SubmitJob message)
-
-
-	    (PrintMsg WINDOW "Submitting Batch Job ...")
-	    (CLEARW messageW)
-	    (MS.CloseErrorWindow WINDOW)
-	    (COND
-	      ((EQUAL parameterString "")
-		(SETQ result (_ host SubmitJob (PACKFILENAME (QUOTE DIRECTORY)
-								   defaultDirectory
-								   (QUOTE BODY)
-								   filename)
-				    queue)))
-	      (T (SETQ result (_ host SubmitJob (PACKFILENAME (QUOTE DIRECTORY)
-								    defaultDirectory
-								    (QUOTE BODY)
-								    filename)
-				     queue
-				     (LIST (MKSTRING parameterString))))))
-	    (PRIN1 result messageW)
-	    (CLEARW promptW)
-	    (PRIN1 "Done" promptW)
-	    (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE JOBNUMBER))
-			      WINDOW
-			      (CAR result)))))
-
-(MS.AbortBatchJob
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "12-Aug-86 09:52")
-                                                             (* Creates the AbortJob message to be sent to the 
-							     appropriate host)
-    (PROG ((state (FM.READSTATE WINDOW))
-	     (promptW (GETPROMPTWINDOW WINDOW))
-	     (messageW (MS.GetMessageWindow WINDOW))
-	     host jobNumber queue validQueues result)
-
-          (* * check that the host name is specified)
-
-
-	    (CLEARW promptW)
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      ((NOT host)
-		(PrintMsg WINDOW "Unspecified host.")
-		(RETURN)))
-
-          (* * check that the job number is specified)
-
-
-	    (SETQ jobNumber (LISTGET state (QUOTE JOBNUMBER)))
-	    (COND
-	      ((EQUAL jobNumber "")
-		(SETQ jobNumber NIL)
-		(PrintMsg WINDOW "Unspecified job number.")
-		(RETURN)))
-
-          (* * check that the queue is specified and valid)
-
-
-	    (SETQ validQueues (_ host GetQueues))
-	    (SETQ queue (LISTGET state (QUOTE QUEUE)))
-	    (COND
-	      ((NOT queue)
-		(PrintMsg WINDOW "Unspecified queue.")
-		(RETURN))
-	      ((NOT (MEMBER queue validQueues))
-		(CLEARW promptW)
-		(PRIN1 "Not a valid queue for this server" promptW)
-		(TERPRI promptW)
-		(PRINTOUT promptW "Valid queues:  " validQueues)
-		(RETURN)))
-
-          (* * abort the job and return the result)
-
-
-	    (CLEARW promptW)
-	    (PRINTOUT promptW "Job " jobNumber " on queue " queue " is being aborted ...")
-	    (SETQ result (_ host AbortJob jobNumber queue))
-	    (TERPRI promptW)
-	    (PRIN1 "Done" promptW)
-	    (CLEARW messageW)
-	    (PRIN1 result messageW))))
-
-(MS.Status
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "12-Aug-86 17:53")
-                                                             (* Creates the Status message to be sent to the 
-							     appropriate host)
-    (PROG ((state (FM.READSTATE WINDOW))
-	     (promptW (GETPROMPTWINDOW WINDOW))
-	     (messageW (MS.GetMessageWindow WINDOW))
-	     host jobNumber result)
-
-          (* * check that the host name is specified)
-
-
-	    (CLEARW promptW)
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      ((NOT host)
-		(PrintMsg WINDOW "Unspecified host.")
-		(RETURN)))
-
-          (* * give notice if no job number is supplied)
-
-
-	    (SETQ jobNumber (LISTGET state (QUOTE JOBNUMBER)))
-	    (COND
-	      ((NUMBERP (MKATOM jobNumber))
-		(PRIN1 "Finding Status ..." promptW))
-	      (T (SETQ jobNumber NIL)
-		 (PRIN1 "Unspecified job number." promptW)
-		 (TERPRI promptW)
-		 (PRIN1 "Finding status of all batch jobs ..." promptW)))
-
-          (* * return the Status message)
-
-
-	    (CLEARW messageW)
-	    (SETQ result (_ host Status jobNumber))
-	    (MS.DisplayStatus result messageW)
-	    (CLEARW promptW)
-	    (PRIN1 "Done" promptW))))
-
-(MS.DisplayStatus
-  (LAMBDA (result messageW)                                  (* DSB "12-Aug-86 18:00")
-                                                             (* Displays the status in nice format in 
-							     messageWindow)
-    (PROG (number time)
-	    (TERPRI messageW)
-	    (PRIN1 "     JOB            CPU" messageW)
-	    (TERPRI messageW)
-	    (PRIN1 "- - - - - - - - - - - - - - - - -" messageW)
-
-          (* * is it a single data item (JOB in CAAR) or...)
-
-
-	    (COND
-	      ((EQ (CAAR result)
-		     (QUOTE JOB))
-		(SETQ number (CADAR result))
-		(SETQ time (CADADR result))
-		(TERPRI messageW)
-		(PRIN1 (CONCAT "     " number "       " time)
-			 messageW))
-	      (T (for item in result
-		    do (SETQ number (CADAR item))
-			 (SETQ time (CADADR item))
-			 (TERPRI messageW)
-			 (PRIN1 (CONCAT "     " number "       " time)
-				  messageW)))))))
-
-(MS.RunInteractiveJob
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Apr-87 10:30")
-                                                             (* Creates the RunJob message to be sent to the 
-							     appropriate host)
-    (PROG (state (promptW (GETPROMPTWINDOW WINDOW))
-		   (messageW (MS.GetMessageWindow WINDOW))
-		   filename defaultDirectory host parameterString result errorFile errorWindow)
-
-          (* * check that all required data is specified)
-
-
-	    (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS))
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (COND
-	      ((EQUAL filename "")
-		(PrintMsg WINDOW "Unspecified file name.")
-		(RETURN)))
-	    (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY)))
-	    (COND
-	      ((EQUAL defaultDirectory "")
-		(PrintMsg WINDOW "Unspecified default directory.")
-		(RETURN)))
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      ((NOT host)
-		(PrintMsg WINDOW "Unspecified host.")
-		(RETURN)))
-	    (SETQ parameterString (LISTGET state (QUOTE PARAMETERSTRING)))
-	    (COND
-	      ((STRPOS "," parameterString)
-		(PrintMsg WINDOW "Remove comma(s) from JobParameters")
-		(RETURN)))
-
-          (* * return the RunJob message)
-
-
-	    (CLEARW promptW)
-	    (PRIN1 "Running interactive job ..." promptW)
-	    (CLEARW messageW)
-	    (MS.CloseErrorWindow WINDOW)
-	    (COND
-	      ((EQUAL parameterString "")
-		(SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY)
-								defaultDirectory
-								(QUOTE BODY)
-								filename))))
-	      (T (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY)
-								 defaultDirectory
-								 (QUOTE BODY)
-								 filename)
-				     (LIST (MKSTRING parameterString))))))
-	    (PRIN1 result messageW)
-	    (CLEARW promptW)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(PRIN1 "Run-time warning or error" promptW)
-		(SETQ errorWindow (MS.AttachErrorWindow WINDOW "Run-time Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow WINDOW))
-	      (T (PRIN1 "Done" promptW))))))
-
-(MS.Compile
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Apr-87 10:14")
-                                                             (* Creates the Compile message to be sent to the 
-							     appropriate host)
-    (PROG (state (promptW (GETPROMPTWINDOW WINDOW))
-		   (messageW (MS.GetMessageWindow WINDOW))
-		   filename defaultDirectory host result errorFile errorWindow)
-	    (CLEARW messageW)
-
-          (* * check that all required data is specified)
-
-
-	    (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS))
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (COND
-	      ((EQUAL filename "")
-		(PrintMsg WINDOW "Unspecified file name.")
-		(RETURN)))
-	    (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY)))
-	    (COND
-	      ((EQUAL defaultDirectory "")
-		(PrintMsg WINDOW "Unspecified default directory.")
-		(RETURN)))
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      ((NOT host)
-		(PrintMsg WINDOW "Unspecified host.")
-		(RETURN)))
-
-          (* * check for dirty file in a Fortran Edit)
-
-
-	    (COND
-	      ((MS.CheckForDirtyFile filename promptW messageW)
-		(RETURN)))
-
-          (* * send the Compile message)
-
-
-	    (CLEARW promptW)
-	    (PRIN1 "Compiling source file ..." promptW)
-	    (MS.CloseErrorWindow WINDOW)
-	    (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY)
-							     defaultDirectory
-							     (QUOTE BODY)
-							     filename)))
-	    (CLEARW messageW)
-	    (PRIN1 result messageW)
-	    (CLEARW promptW)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(PRIN1 "Compilation Error" promptW)
-		(SETQ errorWindow (MS.AttachErrorWindow WINDOW "Compilation Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow WINDOW))
-	      (T (PRIN1 "Successful Compilation" promptW))))))
-
-(MS.Link
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Apr-87 10:31")
-                                                             (* Creates the Link message to be sent to the 
-							     appropriate host)
-    (PROG (state (promptW (GETPROMPTWINDOW WINDOW))
-		   (messageW (MS.GetMessageWindow WINDOW))
-		   filename defaultDirectory host linkString result errorFile errorWindow)
-
-          (* * check that all required data is specified)
-
-
-	    (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS))
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (COND
-	      ((EQUAL filename "")
-		(PrintMsg WINDOW "Unspecified file name.")
-		(RETURN)))
-	    (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY)))
-	    (COND
-	      ((EQUAL defaultDirectory "")
-		(PrintMsg WINDOW "Unspecified default directory.")
-		(RETURN)))
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      ((NOT host)
-		(PrintMsg WINDOW "Unspecified host.")
-		(RETURN)))
-	    (SETQ linkString (LISTGET state (QUOTE LINKSTRING)))
-	    (COND
-	      ((STRPOS " " linkString)
-		(PrintMsg WINDOW "Remove spaces from LinkParameters")
-		(RETURN)))
-
-          (* * return the Link message)
-
-
-	    (CLEARW promptW)
-	    (PRIN1 "Linking ..." promptW)
-	    (CLEARW messageW)
-	    (MS.CloseErrorWindow WINDOW)
-	    (COND
-	      ((EQUAL linkString "")
-		(SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY)
-							      defaultDirectory
-							      (QUOTE BODY)
-							      filename))))
-	      (T (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY)
-							       defaultDirectory
-							       (QUOTE BODY)
-							       filename)
-				     (LIST (MKSTRING linkString))))))
-	    (PRIN1 result messageW)
-	    (CLEARW promptW)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(PRIN1 "Linking Error" promptW)
-		(SETQ errorWindow (MS.AttachErrorWindow WINDOW "Link Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow WINDOW))
-	      (T (PRIN1 "Done:  successful link" promptW))))))
-
-(MS.CompileLink
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Apr-87 10:31")
-                                                             (* Creates the Compile and Link messages to be sent to
-							     the appropriate host)
-    (PROG (state (promptW (GETPROMPTWINDOW WINDOW))
-		   (messageW (MS.GetMessageWindow WINDOW))
-		   filename defaultDirectory host linkString result errorFile errorWindow)
-	    (CLEARW messageW)
-
-          (* * check that all required data is specified)
-
-
-	    (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS))
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (COND
-	      ((EQUAL filename "")
-		(PrintMsg WINDOW "Unspecified file name.")
-		(RETURN)))
-	    (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY)))
-	    (COND
-	      ((EQUAL defaultDirectory "")
-		(PrintMsg WINDOW "Unspecified default directory.")
-		(RETURN)))
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      ((NOT host)
-		(PrintMsg WINDOW "Unspecified host.")
-		(RETURN)))
-	    (SETQ linkString (LISTGET state (QUOTE LINKSTRING)))
-	    (COND
-	      ((STRPOS " " linkString)
-		(PrintMsg WINDOW "Remove spaces from LinkParameters")
-		(RETURN)))
-
-          (* * check for dirty file in a Fortran Edit)
-
-
-	    (COND
-	      ((MS.CheckForDirtyFile filename promptW messageW)
-		(RETURN)))
-
-          (* * send the Compile message)
-
-
-	    (CLEARW promptW)
-	    (PRIN1 "Compiling source file ..." promptW)
-	    (MS.CloseErrorWindow WINDOW)
-	    (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY)
-							     defaultDirectory
-							     (QUOTE BODY)
-							     filename)))
-	    (CLEARW messageW)
-	    (PRIN1 result messageW)
-	    (CLEARW promptW)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(PRIN1 "Compilation error" promptW)
-		(SETQ errorWindow (MS.AttachErrorWindow WINDOW "Compilation Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow WINDOW)
-		(RETURN))
-	      (T (PRIN1 "Compile finished.  Now linking..." promptW)))
-
-          (* * return the Link message)
-
-
-	    (COND
-	      ((EQUAL linkString "")
-		(SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY)
-							      defaultDirectory
-							      (QUOTE BODY)
-							      filename))))
-	      (T (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY)
-							       defaultDirectory
-							       (QUOTE BODY)
-							       filename)
-				     (LIST (MKSTRING linkString))))))
-	    (CLEARW messageW)
-	    (PRIN1 result messageW)
-	    (CLEARW promptW)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(PRIN1 "Linking Error" promptW)
-		(SETQ errorWindow (MS.AttachErrorWindow WINDOW "Link Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow WINDOW))
-	      (T (PRIN1 "Done:  successful link" promptW))))))
-
-(MS.CLR.Check
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "12-Aug-86 10:17")
-                                                             (* This functin calls MS.CompileLinkRun with the check
-							     flag T)
-    (MS.CompileLinkRun ITEM WINDOW BUTTONS T)))
-
-(MS.CLR.NoCheck
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "12-Aug-86 10:18")
-                                                             (* This functin calls MS.CompileLinkRun with the check
-							     flag NIL)
-    (MS.CompileLinkRun ITEM WINDOW BUTTONS NIL)))
-
-(MS.CompileLinkRun
-  (LAMBDA (ITEM WINDOW BUTTONS checkFlag)                    (* DSB "15-Apr-87 10:34")
-                                                             (* Sequentially creates the Compile, Link and RunJob 
-							     messages, to be sent to the appropriate host)
-    (PROG (state (promptW (GETPROMPTWINDOW WINDOW))
-		   (messageW (MS.GetMessageWindow WINDOW))
-		   filename defaultDirectory host parameterString linkString result errorFile 
-		   errorWindow)
-	    (CLEARW messageW)
-
-          (* * check that all required data is specified)
-
-
-	    (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS))
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (COND
-	      ((EQUAL filename "")
-		(PrintMsg WINDOW "Unspecified file name.")
-		(RETURN)))
-	    (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY)))
-	    (COND
-	      ((EQUAL defaultDirectory "")
-		(PrintMsg WINDOW "Unspecified default directory.")
-		(RETURN)))
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      ((NOT host)
-		(PrintMsg WINDOW "Unspecified host.")
-		(RETURN)))
-	    (SETQ linkString (LISTGET state (QUOTE LINKSTRING)))
-	    (COND
-	      ((STRPOS " " linkString)
-		(PrintMsg WINDOW "Remove spaces from LinkParameters")
-		(RETURN)))
-	    (SETQ parameterString (LISTGET state (QUOTE PARAMETERSTRING)))
-	    (COND
-	      ((STRPOS "," parameterString)
-		(PrintMsg WINDOW "Remove comma(s) from JobParameters")
-		(RETURN)))
-
-          (* * check for dirty file in a Fortran Edit)
-
-
-	    (COND
-	      ((MS.CheckForDirtyFile filename promptW messageW)
-		(RETURN)))
-
-          (* * send the Compile message)
-
-
-	    (CLEARW promptW)
-	    (MS.CloseErrorWindow WINDOW)
-	    (COND
-	      ((AND checkFlag (_ host Compiled? host defaultDirectory filename))
-		(PRIN1 "Source file already compiled. " promptW))
-	      (T (PRIN1 "Compiling source file ..." promptW)
-		 (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY)
-								  defaultDirectory
-								  (QUOTE BODY)
-								  filename)))
-		 (CLEARW messageW)
-		 (PRIN1 result messageW)
-		 (CLEARW promptW)
-		 (COND
-		   ((EQUAL (CAR result)
-			     (QUOTE ERROR))
-		     (PRIN1 "Compilation error" promptW)
-		     (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Compilation Errors"))
-		     (SETQ errorFile (_ host ExtractFilename result))
-		     (_ host PutErrorInWindow errorFile errorWindow WINDOW)
-		     (RETURN))
-		   (T (PRIN1 "Compile finished.  " promptW)))))
-
-          (* * return the Link message)
-
-
-	    (COND
-	      ((AND checkFlag (_ host Linked? host defaultDirectory filename))
-		(TERPRI promptW)
-		(PRIN1 "    Exec. file exists.  Now running it..." promptW))
-	      (T (PRIN1 "   Now linking..." promptW)
-		 (COND
-		   ((EQUAL linkString "")
-		     (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY)
-								   defaultDirectory
-								   (QUOTE BODY)
-								   filename))))
-		   (T (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY)
-								    defaultDirectory
-								    (QUOTE BODY)
-								    filename)
-					  (LIST (MKSTRING linkString))))))
-		 (CLEARW messageW)
-		 (PRIN1 result messageW)
-		 (CLEARW promptW)
-		 (COND
-		   ((EQUAL (CAR result)
-			     (QUOTE ERROR))
-		     (PRIN1 "Linking Error" promptW)
-		     (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Link Errors"))
-		     (SETQ errorFile (_ host ExtractFilename result))
-		     (_ host PutErrorInWindow errorFile errorWindow WINDOW)
-		     (RETURN))
-		   (T (PRIN1 "Link finished.  Now running job ..." promptW)))))
-
-          (* * return the RunJob message)
-
-
-	    (COND
-	      ((EQUAL parameterString "")
-		(SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY)
-								defaultDirectory
-								(QUOTE BODY)
-								filename))))
-	      (T (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY)
-								 defaultDirectory
-								 (QUOTE BODY)
-								 filename)
-				     (LIST (MKSTRING parameterString))))))
-	    (CLEARW messageW)
-	    (PRIN1 result messageW)
-	    (CLEARW promptW)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(PRIN1 "Run-time warning or error" promptW)
-		(SETQ errorWindow (MS.AttachErrorWindow WINDOW "Run-time Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow WINDOW))
-	      (T (PRIN1 "Done" promptW))))))
-)
-
-
-
-(* FORTRAN EDITOR FUNCTIONS)
-
-(DEFINEQ
-
-(MS.StartNewFE
-  (LAMBDA NIL                                                (* DSB "21-Aug-86 15:38")
-                                                             (* starts a new Fortran Edit process without setting 
-							     defaults or getting a file)
-    (FE.TopLevel)))
-
-(MS.StartDefaultFE
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Apr-87 10:35")
-
-          (* Starts a FE, sets defaults according to the values in the ServerMenu, and gets the source file named in the 
-	  server menu, if it exists.)
-
-
-    (PROG (state textStream host hostname defaultDirectory directory filename name getFilename)
-	    (SETQ textStream (FE.TopLevel))
-	    (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS))
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY)))
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      (host (TEXTPROP textStream (QUOTE MS.HOST)
-				host)
-		    (SETQ hostname (_ host Name))
-		    (TEXTPROP textStream (QUOTE MS.HOSTNAME)
-				hostname)
-		    (TEXTPROP textStream (QUOTE MS.DIRECTORY)
-				(_ host UserDirectory))))
-	    (COND
-	      ((NOT (EQUAL defaultDirectory ""))
-		(SETQ directory (MKATOM defaultDirectory))
-		(TEXTPROP textStream (QUOTE MS.DIRECTORY)
-			    directory)))
-	    (COND
-	      ((NOT (EQUAL filename ""))
-		(SETQ name (MKATOM filename))))
-	    (COND
-	      ((AND host directory name)
-		(SETQ getFilename (PACKFILENAME (QUOTE HOST)
-						    hostname
-						    (QUOTE DIRECTORY)
-						    directory
-						    (QUOTE NAME)
-						    name
-						    (QUOTE EXTENSION)
-						    (_ host SourceExtension)))
-		(COND
-		  ((INFILEP getFilename)
-		    (TEDIT.GET (TEXTOBJ textStream)
-				 getFilename)
-		    (TEXTPROP textStream (QUOTE FILENAME)
-				getFilename)
-		    (TEDIT.PROMPTPRINT textStream (CONCAT "Retrieved file " getFilename)))
-		  (T (TEDIT.PROMPTPRINT textStream (CONCAT "File " getFilename " not found")))))))
-    ))
-
-(MS.FindFortranEdit
-  (LAMBDA (filename)                                         (* DSB "22-Aug-86 09:36")
-
-          (* * searches through all open windows and returns a stream number of a Fortran Edit process whose filename matches
-	  the parameter filename If no such process exists, it returns NIL.)
-
-
-    (LET (textStream fullEditFilename editFilename)
-         (for window in (OPENWINDOWS) do (COND
-						   ((WINDOWPROP window (QUOTE FORTRANEDIT))
-						     (SETQ textStream (TEXTSTREAM window))
-						     (SETQ fullEditFilename (TEXTPROP
-							 textStream
-							 (QUOTE FILENAME)))
-						     (SETQ editFilename (UNPACKFILENAME
-							 fullEditFilename
-							 (QUOTE NAME)))
-						     (COND
-						       ((EQUAL (U-CASE editFilename)
-								 (U-CASE (MKATOM filename)))
-							 (RETURN textStream))
-						       (T NIL))))))))
-
-(MS.CheckForDirtyFile
-  (LAMBDA (filename promptW messageW)                        (* DSB "22-Aug-86 09:42")
-
-          (* * returns T (to abort the operation) only if there exists a dirty file with the same name and the user does not 
-	  click the left button.)
-
-
-    (PROG (textStream dirty)
-
-          (* * see if there is an active FE with filename)
-
-
-	    (SETQ textStream (MS.FindFortranEdit filename))
-	    (COND
-	      ((NOT textStream)
-		(RETURN NIL)))
-
-          (* * if the file has been changed, give the user the option to abort the operation)
-
-
-	    (SETQ dirty (TEDIT.STREAMCHANGEDP textStream))
-	    (COND
-	      (dirty (CLEARW promptW)
-		     (COND
-		       ((MOUSECONFIRM "Not saved yet; LEFT to use previous version." T promptW)
-			 (PRIN1 "Using old version on the server" messageW)
-			 (RETURN NIL))
-		       (T (PRIN1 "Operation aborted.  Put file in Fortran Edit to server." messageW)
-			  (RETURN T))))
-	      (T (PRIN1 "File in Fortran Editor has not been changed.  Operation proceeds" messageW)
-		 (RETURN NIL))))))
-)
-
-
-
-(* ERROR HANDLING FUNCTIONS)
-
-(DEFINEQ
-
-(MS.BatchErrors?
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Aug-86 18:07")
-                                                             (* If Batch errors have occurred, it displays them in 
-							     the error window)
-    (PROG ((state (FM.READSTATE WINDOW))
-	     (promptW (GETPROMPTWINDOW WINDOW))
-	     (messageW (MS.GetMessageWindow WINDOW))
-	     host defaultDirectory jobNumber errorFile localErrorFile resultFile stream result 
-	     errorWindow)
-
-          (* * check that all required data is specified)
-
-
-	    (CLEARW promptW)
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      ((NOT host)
-		(PrintMsg WINDOW "Unspecified host.")
-		(RETURN)))
-	    (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY)))
-	    (COND
-	      ((EQUAL defaultDirectory "")
-		(PrintMsg WINDOW "Unspecified default directory.")
-		(RETURN)))
-	    (SETQ jobNumber (LISTGET state (QUOTE JOBNUMBER)))
-	    (COND
-	      ((EQUAL jobNumber "")
-		(SETQ jobNumber NIL)
-		(PrintMsg WINDOW "Unspecified job number.")
-		(RETURN)))
-
-          (* * get the error file)
-
-
-	    (CLEARW promptW)
-	    (CLEARW messageW)
-	    (MS.CloseErrorWindow WINDOW)
-	    (SETQ resultFile (INFILEP (PACKFILENAME (QUOTE HOST)
-							  (_ host Name)
-							  (QUOTE DIRECTORY)
-							  defaultDirectory
-							  (QUOTE NAME)
-							  jobNumber
-							  (QUOTE EXTENSION)
-							  (QUOTE RES))))
-	    (SETQ errorFile (INFILEP (PACKFILENAME (QUOTE HOST)
-							 (_ host Name)
-							 (QUOTE DIRECTORY)
-							 defaultDirectory
-							 (QUOTE NAME)
-							 jobNumber
-							 (QUOTE EXTENSION)
-							 (QUOTE ERR))))
-	    (COND
-	      (errorFile (PRIN1 "Retrieving error messages..." promptW)
-			 (SETQ stream (OPENFILE resultFile (QUOTE INPUT)))
-			 (SETQ result (READ stream))
-			 (CLOSEF stream)
-			 (DELFILE resultFile)
-			 (PRIN1 result messageW)
-			 (SETQ localErrorFile (COPYFILE errorFile (QUOTE {core}localErrorFile)))
-			 (DELFILE errorFile)
-			 (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Batch Errors"))
-			 (_ host PutErrorInWindow localErrorFile errorWindow WINDOW))
-	      (T (PRIN1 "No batch errors found" promptW))))))
-
-(MS.BatchLog
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Aug-86 18:07")
-                                                             (* opens a window to display the batch log file)
-    (PROG ((state (FM.READSTATE WINDOW))
-	     (promptW (GETPROMPTWINDOW WINDOW))
-	     (messageW (MS.GetMessageWindow WINDOW))
-	     filename host logfile localLogfile errorWindow)
-
-          (* * check that all required data is specified)
-
-
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (COND
-	      ((EQUAL filename "")
-		(PrintMsg WINDOW "Unspecified file name.")
-		(RETURN)))
-	    (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST))
-					(QUOTE Host)))
-	    (COND
-	      ((NOT host)
-		(PrintMsg WINDOW "Unspecified host.")
-		(RETURN)))
-
-          (* * get the logfile)
-
-
-	    (CLEARW promptW)
-	    (CLEARW messageW)
-	    (MS.CloseErrorWindow WINDOW)
-	    (SETQ logfile (INFILEP (PACKFILENAME (QUOTE HOST)
-						       (_ host Name)
-						       (QUOTE DIRECTORY)
-						       (_ host UserDirectory)
-						       (QUOTE BODY)
-						       filename
-						       (QUOTE EXTENSION)
-						       (QUOTE LOG))))
-	    (COND
-	      (logfile (SETQ localLogfile (COPYFILE logfile (QUOTE {core}localLogfile)))
-		       (DELFILE logfile)
-		       (PRIN1 "fetching Batch Log File..." promptW)
-		       (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Batch Log File"))
-		       (_ host PutErrorInWindow localLogfile errorWindow WINDOW))
-	      (T (PRIN1 "Batch Log File not found" promptW))))))
-)
-
-
-
-(* Icon BITMAPS)
-
-
-(RPAQ MS.Icon (READBITMAP))
-(78 74
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@O@@@@@@@@@L"
-"L@@@@@@@@I@GH@@@@@@L"
-"L@@@@@@B@O@DHGH@@@@L"
-"L@@@@@@B@O@@HDH@@@@L"
-"L@@@@@@B@I@AHGH@@@@L"
-"L@@@@@@B@O@C@GH@@@@L"
-"L@@@@@@B@@@GLDH@@@@L"
-"L@@@@@@B@@@@@GH@@@@L"
-"L@@@@@@@@@@D@@@D@@@L"
-"L@@@@@@@@@@F@@@L@@@L"
-"L@@@@CN@@@@C@DAH@@@L"
-"L@@@@@F@@@@A@DA@@@@L"
-"L@@@@@L@@@@AHDC@@@@L"
-"L@@@@AH@@@@@HDB@@@@L"
-"L@@@CA@@@@@@LDF@@@@L"
-"L@@@CC@@@@@@D@D@@@@L"
-"L@@@@@@@@@@@D@D@CO@L"
-"L@@@@@@@@@@@FNL@CO@L"
-"L@@@GH@@@@@@BJH@AH@L"
-"L@@@DH@@@@@@BJH@AH@L"
-"L@@@@H@@@COOOOOOIH@L"
-"L@@@AH@@@B@@@@@@IH@L"
-"L@@@C@@@@B@@@@@@IH@L"
-"L@@@GL@@@B@@@@@@IH@L"
-"L@@@@@@@@B@D@@@@IH@L"
-"L@@@@@@@@B@D@@L@IH@L"
-"L@@@@@@@@B@D@@@@IH@L"
-"L@COOOH@@BCOHCO@IH@L"
-"L@COOOH@@B@D@@@@IH@L"
-"L@CH@CH@@B@D@@L@IH@L"
-"L@C@@AH@@B@D@@@@OH@L"
-"L@C@@AH@@B@@@@@@OH@L"
-"L@C@@AH@@B@@@@@@H@@L"
-"L@C@@AH@@B@@@@@@H@@L"
-"L@C@@AH@@BBDH@@@H@@L"
-"L@C@@AH@@BAE@@@@H@@L"
-"L@C@@AH@@B@N@@@@H@@L"
-"L@C@@AH@@BCOHCO@H@@L"
-"L@C@@AH@@B@N@@@@H@@L"
-"L@CH@CKFMJAE@@@@H@@L"
-"L@COOOH@@BBDH@@@H@@L"
-"L@COOOH@@B@@@@@@H@@L"
-"L@@AO@@@@COOOOOOH@@L"
-"LAOOOON@@@@@@@@@@@@L"
-"LA@@@@B@@@@@@@@@@@@L"
-"LA@@@@B@@@@@@@@@@@@L"
-"LA@@@@B@@@@@@@@@@@@L"
-"LAOOOON@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"LC@HNGLICLOCNDBOCN@L"
-"LCOIOA@IB@HBBDBHBB@L"
-"LBNIAA@ICLNCNFFNCN@L"
-"LBDIOA@O@DHCHCLHCH@L"
-"LB@IAA@IBDHBLAHHBL@L"
-"LB@IAA@ICLOBFAHOBF@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"L@@@@@@@@@@@@@@@@@@L"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL")
-
-(RPAQ MS.IconMask (READBITMAP))
-(78 74
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOH@COOOOOOOOOOOOOL"
-"OOO@@AOOOOOOOOOOOOOL"
-"OOO@@AOOOOOOOOOOOOOL"
-"OOO@@AOOOOOOOOOOOOOL"
-"OOO@@AOOOOOOOOOOOOOL"
-"OOO@@AOOOOOOOOOOOOOL"
-"OOO@@AOOOOOOOOOOOOOL"
-"OOO@@AOOOOOOOOOOOOOL"
-"OOO@@AOOOOOOOOOOOOOL"
-"OOO@@AOOOOOOOOOOOOOL"
-"OOOH@COOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL"
-"OOOOOOOOOOOOOOOOOOOL")
-
-
-
-(* VARS)
-
-
-(ADDTOVAR BackgroundMenuCommands (Server% Menu (QUOTE (MS.TopLevel))
-						 "Start the Server Menu"))
-
-(RPAQQ BackgroundMenu NIL)
-(DECLARE: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS MS.HostPopMenu)
-)
-(* * FORTRAN EDIT - Sets up a Fortran Edit Process)
-
-
-
-
-(* MAIN FUNCTIONS)
-
-(DEFINEQ
-
-(FE.TopLevel
-  (LAMBDA (program window)                                   (* DSB "22-Aug-86 11:49")
-
-          (* * Edit a Fortran program using a specialized TEdit.)
-
-
-
-          (* * Program is either a File name, an open Stream, or a string. If NIL, an empty edit window is open.)
-
-
-
-          (* * Window is an optional window to be used for editing. If NIL, the user will be asked to sweep out a window on 
-	  the screen.)
-
-
-    (PROG (editProps editWindow messageWindow processHandle textStream)
-
-          (* * Get prop list for edit props)
-
-
-	    (SETQ editProps (FE.GetEditProps))
-
-          (* * Get the window to be used)
-
-
-	    (SETQ editWindow (FE.GetEditWindow window))
-
-          (* * Get the message window)
-
-
-	    (SETQ messageWindow (FE.GetMessageWindow editWindow))
-
-          (* * Set up the edit process)
-
-
-	    (SETQ processHandle (TEDIT program editWindow NIL editProps))
-
-          (* * Get the textstream parameter of the edit process)
-
-
-	    (SETQ textStream (TEXTSTREAM editWindow))
-
-          (* * Do any final modifications)
-
-
-	    (FE.AdjustProps processHandle textStream)
-	    (WINDOWPROP editWindow (QUOTE FORTRANEDIT)
-			  T)
-	    (TEXTPROP textStream (QUOTE EDITWINDOW)
-			editWindow)
-	    (TEXTPROP textStream (QUOTE MESSAGEWINDOW)
-			messageWindow)
-	    (TEXTPROP textStream (QUOTE PROCESS)
-			processHandle)
-	    (TEXTPROP textStream (QUOTE FE.POSITIONWINDOW)
-			(WINDOWPROP editWindow (QUOTE POSITIONWINDOW)))
-
-          (* * Finally, return the process handle)
-
-
-	    (RETURN textStream))))
-
-(FE.AdjustProps
-  (LAMBDA (processHandle textStream)                         (* DSB " 7-Jul-86 15:52")
-
-          (* * Do final adjustments to Fortran editor)
-
-
-    (LET NIL
-         (COND
-	   ((PROCESSP processHandle)
-
-          (* * The following gives the process a name)
-
-
-	     (PROCESSPROP processHandle (QUOTE NAME)
-			    (QUOTE FORTRAN% EDITOR))
-
-          (* * The following disables image object insertion into the document)
-
-
-	     (until (PROCESSPROP processHandle (QUOTE TEDITTTYWINDOW)) do (BLOCK)
-		finally (WINDOWPROP (PROCESSPROP processHandle (QUOTE TEDITTTYWINDOW))
-					(QUOTE COPYINSERTFN)
-					NIL)))))))
-
-(FE.CaretPosition
-  (LAMBDA (textStream)                                       (* DSB " 7-Jul-86 15:48")
-
-          (* * Write the line# and the column# of the position of the caret in Textstream)
-
-
-    (PROG* (charWidth column midpoint position positionWindow textWindow (margin 8)
-		      (textStream (TEXTSTREAM textStream)))
-           (COND
-	     ((AND (TEXTSTREAMP textStream)
-		     (WINDOWP (SETQ positionWindow (TEXTPROP textStream (QUOTE 
-										FE.POSITIONWINDOW)))))
-	       (SETQ textWindow (WINDOWP (CAR (LISTP (fetch (TEXTOBJ \WINDOW)
-								of (TEXTOBJ textStream))))))
-	       (SETQ charWidth (CHARWIDTH (CHCON1 "X")
-					      (TEXTPROP textStream (QUOTE FONT))))
-	       (COND
-		 ((NOT (EQUAL (SETQ position (TEDIT.PARA&CHAR textStream))
-				  (TEXTPROP textStream (QUOTE FE.POSITION))))
-		   (SETQ midpoint (IPLUS 3 (IQUOTIENT (IQUOTIENT (WINDOWPROP positionWindow
-										       (QUOTE
-											 WIDTH))
-									 (CHARWIDTH (CHARCODE
-											X)
-										      (DSPFONT
-											NIL 
-										   positionWindow)))
-							    2)))
-		   (SETQ column (IPLUS (QUOTIENT (IDIFFERENCE (DSPXPOSITION NIL textWindow)
-								      margin)
-						       charWidth)
-					   1))
-		   (CLEARW positionWindow)
-		   (printout positionWindow .TAB0 0 (COND
-			       ((MINUSP (IDIFFERENCE column (CDR position)))
-				 " ? ")
-			       (T ""))
-			     .CENTER midpoint (CONCAT "L: " (CAR position))
-			     .TAB0 midpoint .CENTER 0 (CONCAT "C: " (COND
-								  ((NOT (ZEROP charWidth))
-								    column)
-								  (T -1))))
-		   (TEXTPROP textStream (QUOTE FE.POSITION)
-			       position)))
-	       (RETURN position))))))
-
-(TEDIT.PARA&CHAR
-  (LAMBDA (TEXTSTREAM SEL)                                 (* RAR " 9-Oct-85 15:49")
-
-          (* * Given a text stream, (and optionally a selection) find the pagagraph %# and ch within paragraph that the caret
-	  is at)
-
-
-    (PROG (CH# PC PCTB (TEXTOBJ (TEXTOBJ TEXTSTREAM))
-		 (PARA# 1)
-		 (CHAR# 1)
-		 (LASTPARACH# 1))
-	    (SETQ PCTB (fetch PCTB of TEXTOBJ))
-	    (SETQ PC (ELT PCTB 3))
-	    (SETQ CH# (TEDIT.GETPOINT TEXTOBJ SEL))
-	    (COND
-	      ((ZEROP (fetch TEXTLEN of TEXTOBJ))
-		(RETURN (CONS 1 0))))
-	    (RETURN (while PC
-			 do (COND
-				((IGREATERP (add CHAR# (fetch PLEN of PC))
-					      CH#)           (* Passed the relevant char;
-							     return a result)
-				  (RETURN (CONS PARA# (IDIFFERENCE CH# LASTPARACH#))))
-				(T                           (* Not past the caret; keep going)
-				   (COND
-				     ((fetch PPARALAST of PC)
-                                                             (* Crossing a paragraph boundary.
-							     Count (QUOTE em) up.)
-				       (add PARA# 1)
-				       (SETQ LASTPARACH# CHAR#)))))
-			      (SETQ PC (fetch NEXTPIECE of PC))
-			 finally (RETURN (CONS PARA# (IDIFFERENCE CH# LASTPARACH#))))))))
-
-(FE.CharFn
-  (LAMBDA (textObj charCode)                                 (* DSB " 7-Jul-86 15:51")
-
-          (* * This function filters out the effects of someone trying to alter the "LOOKS" of something in the 
-	  FORTRANEDITOR)
-
-
-    (COND
-      ((ILEQ charCode 127)
-	charCode))))
-
-(FE.GetEditProps
-  (LAMBDA NIL                                                (* DSB "20-Aug-86 14:19")
-
-          (* * Return a prop list for TEdit call)
-
-
-    (PROG (charWidth (font FE.defaultFont))
-	    (SETQ charWidth (CHARWIDTH (CHCON1 "X")
-					   font))
-	    (RETURN (APPEND (QUOTE (CLEARGET T))
-				(QUOTE (CLEARPUT T))
-				(LIST (QUOTE FONT)
-					font)
-				(LIST (QUOTE MENU)
-					(FE.CreateLocalMenu))
-				(LIST (QUOTE PARALOOKS)
-					(LIST (QUOTE TABS)
-						(CONS (ITIMES 8 charWidth)
-							NIL)))
-				(LIST (QUOTE LOOPFN)
-					(FUNCTION FE.LoopFn))
-				(LIST (QUOTE CHARFN)
-					(FUNCTION FE.CharFn))
-				(QUOTE (COPYBYBKSYSBUF T))
-				(LIST (QUOTE READTABLE)
-					(PROG ((table (COPYREADTABLE TEDIT.READTABLE)))
-
-          (* * Return the read table to be used with this process)
-
-
-					        (TEDIT.SETSYNTAX 15 NIL table)
-                                                             (* Turns of inserting with CTRL-O)
-					        (RETURN table))))))))
-
-(FE.GetSourceFileName
-  (LAMBDA (textObj)                                          (* DSB "22-Aug-86 14:08")
-
-          (* * Return filename associated with textObj)
-
-
-
-          (* * Due to a TEDIT bug, we can't use (FULLNAME (fetch TXTFILE of textObj)), because this can be changed when a 
-	  file is opened to the same non-leaf server. Thus, we use the same FILENAME textprop that FE.MyPut uses and FE.MyGet
-	  updates.)
-
-
-    (PROG (fileStream textStream filename messageWindow promptWindow dirty)
-
-          (* * Make sure we have a text object)
-
-
-	    (COND
-	      ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ)))
-		(RETURN NIL)))
-
-          (* * See if the file is ready to use)
-
-
-	    (SETQ fileStream (fetch TXTFILE of textObj))
-	    (SETQ textStream (TEXTSTREAM textObj))
-	    (SETQ filename (TEXTPROP textStream (QUOTE FILENAME)))
-	    (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW)))
-	    (CLEARW messageWindow)
-	    (SETQ promptWindow (fetch PROMPTWINDOW of textObj))
-	    (CLEARW promptWindow)
-	    (SETQ dirty (TEDIT.STREAMCHANGEDP textStream))
-	    (COND
-	      ((NOT dirty)
-		(RETURN filename)))
-	    (COND
-	      ((AND dirty (NOT fileStream))
-		(PRIN1 "Can't.  No file has been saved yet." promptWindow)
-		(RETURN NIL)))
-	    (COND
-	      ((AND dirty fileStream)
-		(COND
-		  ((MOUSECONFIRM "Not saved yet; LEFT to use previous version." T promptWindow)
-		    (PRIN1 "Using old version on the server" messageWindow)
-		    (RETURN filename))
-		  (T (RETURN NIL))))))))
-
-(FE.LoopFn
-  (LAMBDA (textStream)                                       (* DSB " 7-Jul-86 17:08")
-
-          (* * Things to be done each time around TEdit command loop)
-
-
-    (LET NIL
-
-          (* * Shade the edit window)
-
-
-         (FE.ShadeWindow textStream)
-
-          (* * Update the position display)
-
-
-         (FE.CaretPosition textStream))))
-)
-
-
-
-(* WINDOW FUNCTIONS)
-
-(DEFINEQ
-
-(FE.GetPositionWindow
-  (LAMBDA (mainWindow)                                       (* DSB " 7-Jul-86 17:13")
-
-          (* * Return the window to be used as the caret-position indicator window)
-
-
-    (PROG (height positionWindow (font FE.defaultFont))
-	    (SETQ height (HEIGHTIFWINDOW (FONTPROP font (QUOTE HEIGHT))))
-	    (SETQ positionWindow (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW
-								(WINDOWPROP mainWindow
-									      (QUOTE WIDTH)))
-							      height)
-					      NIL NIL T))
-	    (DSPFONT font positionWindow)
-	    (DSPTEXTURE BLACKSHADE positionWindow)
-	    (DSPOPERATION (QUOTE INVERT)
-			    positionWindow)
-	    (WINDOWPROP positionWindow (QUOTE CLOSEFN)
-			  (QUOTE (DETACHWINDOW)))
-	    (WINDOWPROP positionWindow (QUOTE MINSIZE)
-			  (CONS 0 height))
-	    (WINDOWPROP positionWindow (QUOTE MAXSIZE)
-			  (CONS 64000 height))
-	    (WINDOWPROP positionWindow (QUOTE PAGEFULLFN)
-			  (FUNCTION NILL))
-	    (RETURN positionWindow))))
-
-(FE.GetEditWindow
-  (LAMBDA (window)                                           (* DSB "15-Aug-86 09:19")
-
-          (* * Return a window to be used by the Fortran editor)
-
-
-    (PROG (fontHeight minWidth minHeight positionWindow (font FE.defaultFont))
-
-          (* * Set the minimum window dimensions to be 20 characters wide by four lines high)
-
-
-	    (SETQ minWidth (WIDTHIFWINDOW (ITIMES 20 (CHARWIDTH (CHCON1 "X")
-									font))))
-	    (SETQ minHeight (HEIGHTIFWINDOW (ITIMES 4 (SETQ fontHeight (FONTPROP
-							      font
-							      (QUOTE HEIGHT))))
-						T))
-
-          (* * If not passed a window, then create one)
-
-
-	    (COND
-	      ((NOT (WINDOWP window))
-		(SETQ window (CREATEW (GETREGION minWidth minHeight)
-					  (QUOTE Fortran% Editor)
-					  NIL T))))
-
-          (* * Add our window properties)
-
-
-	    (WINDOWADDPROP window (QUOTE RESHAPEFN)
-			     (FUNCTION FE.ReshapeFn))
-	    (WINDOWPROP window (QUOTE ICONFN)
-			  (FUNCTION FE.ShrinkIconCreate))
-	    (WINDOWPROP window (QUOTE MINSIZE)
-			  (CONS minWidth minHeight))
-
-          (* * Now add a window for displaying the caret position)
-
-
-	    (SETQ positionWindow (FE.GetPositionWindow window))
-	    (ATTACHWINDOW positionWindow window (QUOTE TOP)
-			    (QUOTE JUSTIFY))
-	    (WINDOWPROP positionWindow (QUOTE PASSTOMAINCOMS)
-			  T)                                 (* needed due to bug in ATTACHWINDOW which does not 
-							     set the prop correctly when WINDOWCOMACTION=MAIN)
-	    (WINDOWPROP window (QUOTE POSITIONWINDOW)
-			  positionWindow)
-
-          (* * Return the main window)
-
-
-	    (RETURN window))))
-
-(FE.GetMessageWindow
-  (LAMBDA (editWindow)                                       (* DSB "19-Aug-86 17:55")
-
-          (* * Create, attach, and return the messageWindow on the bottom of the editWindow)
-
-
-    (PROG (messageWindow)
-	    (SETQ messageWindow (CREATEW (CREATEREGION 0 0 200 60)
-					     "Message Window" NIL T))
-	    (ATTACHWINDOW messageWindow editWindow (QUOTE BOTTOM)
-			    (QUOTE JUSTIFY))
-	    (RETURN messageWindow))))
-
-(FE.ReshapeFn
-  (LAMBDA (window oldImage oldRegion)                        (* DSB " 7-Jul-86 17:23")
-
-          (* * Need to set the TEXTPROP FE.POSITION to Nil to force position update following reshape of main window)
-
-
-    (TEXTPROP (TEXTSTREAM window)
-		(QUOTE FE.POSITION)
-		NIL)))
-
-(FE.ShadeWindow
-  (LAMBDA (stream)                                           (* DSB " 7-Jul-86 17:28")
-
-          (* * Highlight the sixth and seventy-third columns of the editor window)
-
-
-    (PROG (charWidth height window (margin 8)
-		       (textObj (TEXTOBJ stream)))
-	    (SETQ window (CAR (fetch (TEXTOBJ \WINDOW) of textObj)))
-	    (SETQ charWidth (CHARWIDTH (CHCON1 "X")
-					   (TEXTPROP textObj (QUOTE FONT))))
-	    (SETQ height (WINDOWPROP window (QUOTE HEIGHT)))
-	    (BITBLT NIL NIL NIL window (IPLUS margin (ITIMES 5 charWidth))
-		      0 1 height (QUOTE TEXTURE)
-		      (QUOTE REPLACE)
-		      GRAYSHADE)
-	    (BITBLT NIL NIL NIL window (SUB1 (IPLUS margin (ITIMES 6 charWidth)))
-		      0 1 height (QUOTE TEXTURE)
-		      (QUOTE REPLACE)
-		      GRAYSHADE)
-	    (BITBLT NIL NIL NIL window (IPLUS margin (ITIMES 72 charWidth))
-		      0 1 height (QUOTE TEXTURE)
-		      (QUOTE REPLACE)
-		      GRAYSHADE))))
-)
-
-
-
-(* LOCALMENU FUNCTIONS)
-
-(DEFINEQ
-
-(FE.CreateLocalMenu
-  (LAMBDA NIL                                                (* DSB " 7-Nov-86 09:42")
-
-          (* * Return the local menu that pops up when the left or middle buttons are pressed when the mouse pointer is in 
-	  the title bar area of the Fortran editor window.)
-
-
-    (create MENU
-	      ITEMS _(QUOTE (Quit Hardcopy (Put (FUNCTION FE.MyPut)
-						  "Write edit buffer to specified file")
-				    (Get (FUNCTION FE.MyGet)
-					 
-				"Replace contents of edit buffer with contents of specified file")
-				    (Include (QUOTE Include)
-					     
-			      "Add contents of specified file to edit buffer at present location")
-				    (Find (QUOTE Find)
-					  
-			       "Find first occurence of specified string beyond present location")
-				    (Substitute (QUOTE Substitute)
-						
-		    "Replace all occurances of specified string with new string in selected text")
-				    (Host (FUNCTION FE.SetHost)
-					  "Declare host server")
-				    (Directory (FUNCTION FE.SetDirectory)
-					       "Declare host directory")
-				    (Compile (FUNCTION FE.Compile)
-					     "Compile file on host")
-				    (Link (FUNCTION FE.Link)
-					  "Link file on host")
-				    (C/L/R (FUNCTION FE.CompileLinkRun)
-					   "Compile,link and run file on host")
-				    (Run (FUNCTION FE.RunInteractive)
-					 "Run file on host")))
-	      CENTERFLG _ T
-	      MENUFONT _(FONTCREATE (QUOTE HELVETICA)
-				      10
-				      (QUOTE BOLD))
-	      WHENSELECTEDFN _(FUNCTION \TEDIT.MENU.WHENSELECTEDFN)
-	      WHENHELDFN _(FUNCTION \TEDIT.MENU.WHENHELDFN))))
-
-(FE.SetHost
-  (LAMBDA (textStream)                                       (* DSB "22-Aug-86 13:07")
-
-          (* * Ask user to declare a host server, using the present host server as a default answer.)
-
-
-
-          (* * the host, hostname and default directory are all calculated and stored as TEXTPROPs)
-
-
-
-          (* * Note that FE.GetServer returns the pointer to the server instance. When the message is sent to host, host is 
-	  evaled.)
-
-
-
-          (* * Note also that hostname must be an upper-case atom when it is passed to FE.ValidHostname and FE.GetServer)
-
-
-    (PROG (messageWindow host hostname (oldHostname (TEXTPROP textStream (QUOTE MS.HOSTNAME))))
-	    (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW)))
-	    (CLEARW messageWindow)
-	    (COND
-	      ((FE.ValidHostname (SETQ hostname (U-CASE (MKATOM (TEDIT.GETINPUT textStream 
-										     "Hostname :"
-											  oldHostname)
-									))))
-		(TEXTPROP textStream (QUOTE MS.HOSTNAME)
-			    hostname)
-		(SETQ host (FE.GetServer hostname))
-		(TEXTPROP textStream (QUOTE MS.HOST)
-			    host)
-		(TEXTPROP textStream (QUOTE MS.DIRECTORY)
-			    (_ host UserDirectory))
-		(TEDIT.PROMPTPRINT textStream (CONCAT "Hostname is " hostname)
-				     T))
-	      (T (TEDIT.PROMPTPRINT textStream (CONCAT hostname 
-							   " is not valid...Hostname unchanged")
-				      T)))
-	    (RETURN NIL))))
-
-(FE.SetDirectory
-  (LAMBDA (textStream)                                       (* DSB "22-Aug-86 13:09")
-
-          (* * ask user to declare a default directory, using the previously defined directory as a default.
-	  The default is initially set to the user's root directory when the host is declared.)
-
-
-    (PROG (messageWindow newDirectory (oldDirectory (TEXTPROP textStream (QUOTE MS.DIRECTORY)))
-			   (host (TEXTPROP textStream (QUOTE MS.HOST))))
-
-          (* * first clear the message window)
-
-
-	    (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW)))
-	    (CLEARW messageWindow)
-
-          (* * then make sure a host has been declared)
-
-
-	    (COND
-	      ((NOT host)
-		(RETURN (TEDIT.PROMPTPRINT textStream 
-					  "No host has yet been declared.  Name your host first."
-					       T))))
-
-          (* * then reset directory if changed)
-
-
-	    (SETQ newDirectory (MKATOM (TEDIT.GETINPUT textStream "Directory: " oldDirectory)))
-	    (COND
-	      ((EQUAL newDirectory oldDirectory)
-		(TEDIT.PROMPTPRINT textStream (CONCAT newDirectory 
-				       " is the same as the previous value...Directory unchanged")
-				     T))
-	      (T (TEXTPROP textStream (QUOTE MS.DIRECTORY)
-			     newDirectory)
-		 (TEDIT.PROMPTPRINT textStream (CONCAT "Directory is " newDirectory)
-				      T))))))
-
-(FE.MyGet
-  (LAMBDA (textStream)                                       (* DSB "22-Aug-86 12:59")
-                                                             (* My TEDIT Get Function)
-
-          (* * after getting the file, it sets the FILENAME textprop to the new fullFilename. This textprop is only changed 
-	  by a Get, whereas due to an error in TEDIT, the TXTFILE slot of textObj can change whenever an OPENFILE is made to 
-	  the server)
-
-
-
-          (* * Note that we only store the versionless filename, because it then gets updated properly on a Put.)
-
-
-    (PROG (messageWindow textObj fileStream fullFilename versionlessFilename)
-	    (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW)))
-	    (CLEARW messageWindow)
-	    (SETQ textObj (TEXTOBJ textStream))
-	    (TEDIT.GET textObj)
-	    (SETQ fileStream (fetch TXTFILE of textObj))
-	    (SETQ fullFilename (FULLNAME fileStream))
-	    (SETQ versionlessFilename (FE.StripVersion fullFilename))
-	    (TEXTPROP textStream (QUOTE FILENAME)
-			versionlessFilename))))
-
-(FE.MyPut
-  (LAMBDA (textStream)                                       (* DSB " 7-Nov-86 11:03")
-                                                             (* my TEDIT put function)
-
-          (* * When the edit buffer is to be saved for the first time, the FILENAME TEXTPROP is NIL. Subsequently, it has a 
-	  (versionless) value, which remains the same if put the the same filename or is altered if put to a different 
-	  filename)
-
-
-
-          (* * The new filename is stored without version number in the FILENAME field of TEXTPROP)
-
-
-
-          (* * The reason for this stuff is that the name in (FULLNAME (fetch TXTFILE of textObj)) can be altered by an 
-	  OPENFILE, when both files are on a non-leaf server. Thus, we have to keep track of the TEDIT filename ourselves.)
-
-
-    (PROG (messageWindow newFilename textObj fileStream fullFilename versionlessFilename)
-
-          (* * first clear the message window)
-
-
-	    (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW)))
-	    (CLEARW messageWindow)
-
-          (* * get the filename to be put. If the user inputs a c.r., it returns the old filename; otherwise, it retains the 
-	  user input.)
-
-
-	    (SETQ oldFilename (TEXTPROP textStream (QUOTE FILENAME)))
-	    (SETQ newFilename (MKATOM (U-CASE (TEDIT.GETINPUT textStream "(Put) Filename:" 
-								      oldFilename))))
-
-          (* * put the returned filename)
-
-
-	    (TEDIT.PUT textStream newFilename NIL T)
-
-          (* * a new FILENAME textprop is saved only when the new filename differs from the old filename)
-
-
-	    (COND
-	      ((EQUAL oldFilename newFilename)
-		(RETURN))
-	      (T (SETQ textObj (TEXTOBJ textStream))
-		 (SETQ fileStream (fetch TXTFILE of textObj))
-		 (SETQ fullFilename (FULLNAME fileStream))
-		 (SETQ versionlessFilename (FE.StripVersion fullFilename))
-		 (TEXTPROP textStream (QUOTE FILENAME)
-			     versionlessFilename))))))
-
-(FE.StripVersion
-  (LAMBDA (fullFilename)                                     (* DSB "20-Aug-86 13:50")
-                                                             (* returns a filename with the version stripped number
-							     out)
-    (PROG (host directory name extension)
-	    (SETQ host (UNPACKFILENAME fullFilename (QUOTE HOST)))
-	    (SETQ directory (UNPACKFILENAME fullFilename (QUOTE DIRECTORY)))
-	    (SETQ name (UNPACKFILENAME fullFilename (QUOTE NAME)))
-	    (SETQ extension (UNPACKFILENAME fullFilename (QUOTE EXTENSION)))
-	    (RETURN (PACKFILENAME (QUOTE HOST)
-				      host
-				      (QUOTE DIRECTORY)
-				      directory
-				      (QUOTE NAME)
-				      name
-				      (QUOTE EXTENSION)
-				      extension)))))
-
-(FE.Compile
-  (LAMBDA (textStream)                                       (* DSB "22-Aug-86 11:54")
-
-          (* * Compile the file associated with this edit process.)
-
-
-    (PROG (fullFilename filename directory host result errorFile errorWindow editWindow 
-			  messageWindow (textObj (TEXTOBJ textStream)))
-	    (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW)))
-	    (CLEARW messageWindow)
-
-          (* * Make sure we have a text object)
-
-
-	    (COND
-	      ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ)))
-		(PRIN1 "No text to compile" messageWindow)
-		(RETURN NIL)))
-
-          (* * See if the file is ready to use)
-
-
-	    (COND
-	      ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj)))
-		(PRIN1 "Text non-existant or unsaved:  compile aborted" messageWindow)
-		(RETURN NIL)))
-
-          (* * Check that a host has been specified)
-
-
-	    (COND
-	      ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST))))
-		(PRIN1 "Can't compile.  No Host has been declared" messageWindow)
-		(RETURN NIL)))
-
-          (* * Do the compile)
-
-
-	    (TEDIT.PROMPTPRINT textStream (CONCAT "Compiling " fullFilename " on "
-						      (_ host Name)
-						      "...")
-				 T)
-	    (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW)))
-	    (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY)))
-	    (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME)))
-	    (MS.CloseErrorWindow editWindow)
-	    (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY)
-							     directory
-							     (QUOTE NAME)
-							     filename)))
-	    (CLEARW messageWindow)
-	    (PRIN1 result messageWindow)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(TEDIT.PROMPTPRINT textStream "Compilation errors" T)
-		(SETQ errorWindow (MS.AttachErrorWindow editWindow "Compilation Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow editWindow))
-	      (T (TEDIT.PROMPTPRINT textStream "Successful compilation." T))))))
-
-(FE.Link
-  (LAMBDA (textStream)                                       (* DSB "22-Aug-86 12:01")
-
-          (* * Link the file associated with this edit process.)
-
-
-    (PROG (fullFilename filename directory host result errorFile errorWindow editWindow 
-			  messageWindow (textObj (TEXTOBJ textStream)))
-	    (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW)))
-	    (CLEARW messageWindow)
-
-          (* * Make sure we have a text object)
-
-
-	    (COND
-	      ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ)))
-		(PRIN1 "No file to link" messageWindow)
-		(RETURN NIL)))
-
-          (* * See if the file is ready to use)
-
-
-	    (COND
-	      ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj)))
-		(PRIN1 "File non-existant or unsaved:  link aborted" messageWindow)
-		(RETURN NIL)))
-
-          (* * Check that a host has been specified)
-
-
-	    (COND
-	      ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST))))
-		(PRIN1 "Can't link.  No Host has been declared" messageWindow)
-		(RETURN NIL)))
-
-          (* * Do the link)
-
-
-	    (TEDIT.PROMPTPRINT textStream (CONCAT "Linking " fullFilename " on "
-						      (_ host Name)
-						      "...")
-				 T)
-	    (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW)))
-	    (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY)))
-	    (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME)))
-	    (MS.CloseErrorWindow editWindow)
-	    (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY)
-							  directory
-							  (QUOTE NAME)
-							  filename)))
-	    (CLEARW messageWindow)
-	    (PRIN1 result messageWindow)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(TEDIT.PROMPTPRINT textStream "Linking error" T)
-		(SETQ errorWindow (MS.AttachErrorWindow editWindow "Link Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow editWindow))
-	      (T (TEDIT.PROMPTPRINT textStream "Successful link" T))))))
-
-(FE.CompileLinkRun
-  (LAMBDA (textStream)                                       (* DSB "22-Aug-86 11:54")
-
-          (* * sequentially compiles, links, and runs the file associated with this edit process.)
-
-
-    (PROG (fullFilename filename directory host result errorFile errorWindow editWindow 
-			  messageWindow (textObj (TEXTOBJ textStream)))
-	    (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW)))
-	    (CLEARW messageWindow)
-
-          (* * Make sure we have a text object)
-
-
-	    (COND
-	      ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ)))
-		(PRIN1 "No text to compile" messageWindow)
-		(RETURN NIL)))
-
-          (* * See if the file is ready to use)
-
-
-	    (COND
-	      ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj)))
-		(PRIN1 "Text non-existant or unsaved:  compile aborted" messageWindow)
-		(RETURN NIL)))
-
-          (* * Check that a host has been specified)
-
-
-	    (COND
-	      ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST))))
-		(PRIN1 "Can't compile.  No Host has been declared" messageWindow)
-		(RETURN NIL)))
-
-          (* * Do the compile)
-
-
-	    (TEDIT.PROMPTPRINT textStream (CONCAT "Compiling " fullFilename " on "
-						      (_ host Name)
-						      "...")
-				 T)
-	    (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW)))
-	    (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY)))
-	    (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME)))
-	    (MS.CloseErrorWindow editWindow)
-	    (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY)
-							     directory
-							     (QUOTE NAME)
-							     filename)))
-	    (CLEARW messageWindow)
-	    (PRIN1 result messageWindow)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(TEDIT.PROMPTPRINT textStream "Compilation errors" T)
-		(SETQ errorWindow (MS.AttachErrorWindow editWindow "Compilation Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow editWindow)
-		(RETURN))
-	      (T (TEDIT.PROMPTPRINT textStream "Successful compilation." T)))
-
-          (* * Do the link)
-
-
-	    (TEDIT.PROMPTPRINT textStream (CONCAT "Linking " fullFilename " on "
-						      (_ host Name)
-						      "...")
-				 T)
-	    (MS.CloseErrorWindow editWindow)
-	    (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY)
-							  directory
-							  (QUOTE NAME)
-							  filename)))
-	    (CLEARW messageWindow)
-	    (PRIN1 result messageWindow)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(TEDIT.PROMPTPRINT textStream "Linking error" T)
-		(SETQ errorWindow (MS.AttachErrorWindow editWindow "Link Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow editWindow)
-		(RETURN))
-	      (T (TEDIT.PROMPTPRINT textStream "Successful link" T)))
-
-          (* * Run the job interactively)
-
-
-	    (TEDIT.PROMPTPRINT textStream (CONCAT "Running interactive job " fullFilename " on "
-						      (_ host Name)
-						      "...")
-				 T)
-	    (MS.CloseErrorWindow editWindow)
-	    (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY)
-							    directory
-							    (QUOTE NAME)
-							    filename)))
-	    (CLEARW messageWindow)
-	    (PRIN1 result messageWindow)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(TEDIT.PROMPTPRINT textStream "Run-time warning or error" T)
-		(SETQ errorWindow (MS.AttachErrorWindow editWindow "Run-time Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow editWindow))
-	      (T (TEDIT.PROMPTPRINT textStream "Done" T))))))
-
-(FE.RunInteractive
-  (LAMBDA (textStream)                                       (* DSB "22-Aug-86 12:49")
-
-          (* * Run (interactively) the file associated with this edit process.)
-
-
-    (PROG (fullFilename filename directory host result errorFile errorWindow editWindow 
-			  messageWindow (textObj (TEXTOBJ textStream)))
-	    (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW)))
-	    (CLEARW messageWindow)
-
-          (* * Make sure we have a text object)
-
-
-	    (COND
-	      ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ)))
-		(PRIN1 "No file to run" messageWindow)
-		(RETURN NIL)))
-
-          (* * See if the file is ready to use)
-
-
-	    (COND
-	      ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj)))
-		(PRIN1 "File non-existant or unsaved:  run aborted" messageWindow)
-		(RETURN NIL)))
-
-          (* * Check that a host has been specified)
-
-
-	    (COND
-	      ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST))))
-		(PRIN1 "Can't run.  No Host has been declared" messageWindow)
-		(RETURN NIL)))
-
-          (* * Run it)
-
-
-	    (TEDIT.PROMPTPRINT textStream (CONCAT "Running interactive job " fullFilename " on "
-						      (_ host Name)
-						      "...")
-				 T)
-	    (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW)))
-	    (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY)))
-	    (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME)))
-	    (MS.CloseErrorWindow editWindow)
-	    (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY)
-							    directory
-							    (QUOTE NAME)
-							    filename)))
-	    (CLEARW messageWindow)
-	    (PRIN1 result messageWindow)
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(TEDIT.PROMPTPRINT textStream "Run-time warning or error" T)
-		(SETQ errorWindow (MS.AttachErrorWindow editWindow "Run-time Errors"))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow editWindow))
-	      (T (TEDIT.PROMPTPRINT textStream "Done" T))))))
-)
-
-
-
-(* SERVER METACLASS FUNCTIONS)
-
-(DEFINEQ
-
-(FE.ValidHostname
-  (LAMBDA (hostname)                                         (* DSB "20-Aug-86 08:40")
-                                                             (* returns the hostname if it is on the list of valid 
-							     hosts)
-
-          (* * Note that hostname must be passed from FE.SetHost as an upper-case atom)
-
-
-    (PROG (server validHostname)
-	    (SETQ server (FE.GetServer hostname))
-	    (COND
-	      (server (SETQ validHostname (_ server Name))
-		      (RETURN validHostname))
-	      (T NIL)))))
-
-(FE.GetServer
-  (LAMBDA (hostname)                                         (* DSB "20-Aug-86 08:42")
-                                                             (* given a hostname, returns the pointer to the 
-							     server)
-
-          (* * note that the hostname must be an upper-case atom)
-
-
-    (find server in (_ ($ Server)
-			     AllInstances!)
-       suchthat (EQUAL hostname (_ server Name)))))
-)
-
-
-
-(* ICON STUFF)
-
-(DEFINEQ
-
-(FE.ShrinkIconCreate
-  (LAMBDA (W ICON ICONW)                                     (* DSB " 6-Oct-86 13:52")
-                                                             (* Create the icon that represents this window.)
-    (PROG ((icon (WINDOWPROP W (QUOTE ICON)))
-	     (iconTitle (WINDOWPROP W (QUOTE TEDIT.ICON.TITLE)))
-	     (shrinkfn (WINDOWPROP W (QUOTE SHRINKFN))))
-	    (COND
-	      ((NOT (WINDOWPROP W (QUOTE TEXTOBJ)))    (* This isn't really a TEdit window any more.
-							     Don't do anything)
-		NIL)
-	      ((WINDOWPROP W (QUOTE TEDITMENU))          (* This is a text menu, and shrinks without trace.)
-		NIL)
-	      ((OR (IGREATERP (FLENGTH shrinkfn)
-				  3)
-		     (AND (NOT (FMEMB (QUOTE SHRINKATTACHEDWINDOWS)
-					    shrinkfn))
-			    (IGREATERP (FLENGTH shrinkfn)
-					 2)))                (* There are other functions that expect to handle 
-							     this. Don't bother.)
-		NIL)
-	      ((OR (AND iconTitle (EQUAL iconTitle (TEXTSTREAM.TITLE (TEXTSTREAM W))))
-		     (AND (NOT iconTitle)
-			    icon))                           (* we built this and the title is the same, or he has 
-							     already put an icon on this.
-							     Do nothing)
-		NIL)
-	      (icon                                          (* There's an existing icon window;
-							     change the title in it)
-		    (WINDOWPROP W (QUOTE TEDIT.ICON.TITLE)
-				  (SETQ iconTitle (TEXTSTREAM.TITLE (TEXTSTREAM W))))
-		    (ICONTITLE iconTitle NIL NIL icon))
-	      (T                                             (* install a new icon)
-		 (WINDOWPROP W (QUOTE TEDIT.ICON.TITLE)
-			       (SETQ iconTitle (TEXTSTREAM.TITLE (TEXTSTREAM W))))
-		 (WINDOWPROP W (QUOTE ICON)
-			       (TITLEDICONW FE.titledIconTemplate iconTitle FE.iconFont NIL T
-					      (QUOTE TOP))))))
-    (WINDOWPROP W (QUOTE ICON))))
-)
-
-(RPAQ FE.Icon (READBITMAP))
-(120 61
-"@@@COOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@@@GOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@@@N@CHCHAL@L@O@GCION@C@CHAHAO@@"
-"@@AN@C@AH@L@L@F@CCION@C@AHAHAO@@"
-"@@CNGOCIILOCLNFGCAIONGOCINGNGO@@"
-"@@GN@GCIILOCLNFGC@ION@GCINGNGO@@"
-"@@ON@GCIH@OCL@F@C@AON@GCINGNGO@@"
-"@AONGOCIHAOCL@N@CBAONGOCINGNGO@@"
-"@CONGOCIIAOCLHNGCCAONGOCINGNGO@@"
-"@GONGO@AIHOCLLFGCCION@C@AHANGO@@"
-"@OONGOHCILGCLNBGCCION@C@CHANGO@@"
-"AOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"CN@@@@@@@@@@@@@@@@@@@B@@@@@@@A@@"
-"GN@@@@@@@@@@@@@@@@@B@@@@@@@@@A@@"
-"OJ@@@@@@@@@@@@@@@@@B@@@@@@@@@A@@"
-"OJ@@@@@@@@@@@@@@@@@@H@@@@@@@@A@@"
-"NJ@@@@@@@@@@@@@@@@@@H@@@@@@@@A@@"
-"NJ@H@@@@@@@B@@@@@@@H@@H@@@@@@A@@"
-"JJ@H@@@@@@@B@@@@@@@H@@H@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"KJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@H@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@H@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@H@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@H@@@@@B@H@@@@@@@@@@@@A@@"
-"JN@@@@@@@@@@@@B@H@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJB@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"NJB@@@@B@B@H@B@@@B@@@@@@@@@@@A@@"
-"JJ@@@@@B@B@H@B@@@B@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@BH@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@BH@@@@@H@@@@B@@@@B@@@@@@@@A@@"
-"JJ@@@@@@@@H@@@@B@@@@B@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@B@@@@@@A@@"
-"JJH@@@@@@@@@@@@@@@@@@@B@@@@@@A@@"
-"JJH@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@B@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JJ@@@@B@@@@@@@@@@@@@@H@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@H@@@@@@@A@@"
-"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"KJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@"
-"JKOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"JH@@@@@D@@@@@@@@A@@@@@@@@@H@@D@@"
-"JOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@"
-"J@@@@@@@@@@D@@@@@@D@@@@D@@@@A@@@"
-"KOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@"
-"H@@@A@@@@@@@@@@@H@@@@@@@@@@BD@@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@")
-
-(RPAQ FE.IconMask (READBITMAP))
-(120 61
-"@@@COOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@@@GOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@@@OOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@@AOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@@COOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@@GOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@@OOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@AOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@COOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@GOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"@OOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"AOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"COOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"GOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@"
-"OOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@")
-
-(RPAQ? FE.defaultFont (FONTCLASS (QUOTE FORTRANEDITFONT)
-				   (QUOTE (1 (GACHA 12)
-					     (GACHA 10)
-					     (GACHA 10)))))
-
-(RPAQ? FE.iconFont (FONTCREATE (QUOTE HELVETICA)
-				 8
-				 (QUOTE BOLD)))
-
-(RPAQ? FE.iconTitleRegion (create REGION LEFT _ 8 BOTTOM _ 8 WIDTH _ 110 HEIGHT _ 40))
-
-(RPAQ? FE.titledIconTemplate (create TITLEDICON ICON _ FE.Icon MASK _ FE.IconMask TITLEREG _ 
-				       FE.iconTitleRegion))
-
-
-
-(* VARS)
-
-
-(ADDTOVAR BackgroundMenuCommands (Fortran% Edit (QUOTE (FE.TopLevel))
-						  "Start a Fortran Edit"))
-
-(RPAQQ BackgroundMenu NIL)
-(DECLARE: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS FE.defaultFont FE.iconFont FE.titledIconTemplate TEDIT.READTABLE)
-)
-(* * SERVERS -- Defines the Loops MathServer objects)
-
-(DEFCLASSES Cray FortranServer MathServer Server VMSServer)
-[DEFCLASS Cray
-   (MetaClass Class doc                                      (* If you want something to be done quickly, use this 
-							     class)
-	      Edited:                                        (* DSB "30-May-86 14:55"))
-   (Supers MathServer)]
-
-[DEFCLASS FortranServer
-   (MetaClass Class Edited:                                  (* DSB "13-May-86 16:09"))
-   (Supers Server)]
-
-[DEFCLASS MathServer
-   (MetaClass Class Edited:                                  (* DSB "20-May-86 17:21"))
-   (Supers Server)
-   (ClassVariables (jobManagerProcess NIL doc 
-
-          (* the current process on which the job manager is working. All processes alert the job manager by calling the 
-	  AlertManager method and giving this variable as an argument)
-
-))]
-
-[DEFCLASS Server
-   (MetaClass AbstractClass Edited:                          (* DSB "10-Nov-86 08:20"))
-   (Supers IndexedObject Object)
-   (InstanceVariables (host NIL doc                          (* network name of host ; eg., GSLVAX))
-		      (name NIL doc                          (* vernacular name of host;
-							     eg., GSLVAX))
-		      (description NIL doc                   (* short description of server))
-		      (serverDirectory NIL doc               (* directory for server command files))
-		      (queues NIL doc                        (* list of names of batch queues))
-		      (sourceExtension NIL doc               (* default extension, such as FOR, for source files)
-				       )
-		      (commandFileExtension NIL doc          (* default extension, such as COM, for command files)
-					    ))]
-
-[DEFCLASS VMSServer
-   (MetaClass Class doc                                      (* this is a DEC VMS machine)
-	      Edited:                                        (* DSB "10-Nov-86 08:22"))
-   (Supers MathServer FortranServer)
-   (InstanceVariables (sourceExtension FOR doc               (* VMS fortran extension))
-		      (commandFileExtension COM doc          (* VMS command file default extension))
-		      (comFileName (SUBMITJOB submitJob.com ABORTJOB abortJob.com RUNJOB runJob.com 
-					      STATUS status.com LINK link.com COMPLINK complink.com 
-					      COMPILE compile.com GETTIME getTime.com)
-				   doc                       (* VMS com files)
-				   )
-		      (resultFileName (SUBMITJOB submitJob.res ABORTJOB abortJob.res RUNJOB 
-						 runJob.res STATUS status.res COMPILE compile.res 
-						 LINK link.res COMPLINK complink.res GETTIME 
-						 getTime.res)
-				      doc                    (* VMS result files)
-				      ))]
-
-[METH FortranServer  Compile (filename)
-      (* compiles file, which must be on the host)]
-
-
-[METH FortranServer  Compiled? (host defaultDirectory filename)
-      (* Checks if an object file exists on the host. If so, returns T)]
-
-
-[METH FortranServer  Link (filename linkedFilesList)
-      (* links object files on the host into an executable file)]
-
-
-[METH FortranServer  Linked? (host defaultDirectory filename)
-      (* Checks if an executable file exists on the host. If so, returns T)]
-
-
-[METH MathServer  AlertManager NIL
-      (* This method is called by all job processes. It starts up the JobManager process if not 
-	 awakened, and passes the jobManagerProcess variable.)]
-
-
-[METH Server  AbortJob (jobNumber queue)
-      (* aborts specific batch job on stated queue)
-      (category MainOps)]
-
-
-[METH Server  CommandFileExtension NIL
-      (* returns the extension recognized by the system as a command file)]
-
-
-[METH Server  Description NIL
-      (* returns description of the server)]
-
-
-[METH Server  Error? (result)
-      (* checks if CAR of result list is "ERROR")
-      (category Results)]
-
-
-[METH Server  ErrorFile (result)
-      (* returns the full name of the error file, specified by the third element in the result list)
-      (category Results)]
-
-
-[METH Server  ErrorString (result)
-      (* returns the error string: the second element in result list)
-      (category Results)]
-
-
-[METH Server  ExecuteCommandFile (commandFile parameterList)
-      (* method to run a command file. The command string is assembled by the local method 
-	 CommandString)]
-
-
-[METH Server  ExtractFilename (result)
-      (* Extract error file name from result)]
-
-
-[METH Server  GetQueues NIL
-      (* returns the list of queues for the server)
-      (category Name)]
-
-
-[METH Server  GetTime NIL
-      (* gets the time from the server)
-      (category MainOps)]
-
-
-[METH Server  Host NIL
-      (* returns local server instance variable host)
-      (category Name)]
-
-
-[METH Server  MakeError (string fileName)
-      (* makes an ERROR ... list)
-      (category Results)]
-
-
-[METH Server  MakeFullName (fileName directory)
-      (* Constructs full name of file and host)
-      (category Name)]
-
-
-[METH Server  MakePartialName (fileName directory)
-      (* Constructs name of file with directory, but without host)]
-
-
-[METH Server  Name NIL
-      (* returns vernacular server name)
-      (category Name)]
-
-
-[METH Server  PutErrorInWindow (errorFile errorWindow mainWindow)
-      (* puts text of errorFile in a window)]
-
-
-[METH Server  PutTextInWindow (filename position)
-      (* Opens a scrollable TEDIT window for the file)]
-
-
-[METH Server  Result (result)
-      (* returns the second element in the result list when there is no error. This is typically the 
-	 jobID.)
-      (category Results)]
-
-
-[METH Server  RunFile (file parameterList resultFile noErrorFlg)
-      (* general method to run a command file and get result and errors)
-      (category MainOps)]
-
-
-[METH Server  RunJob (filename parameterList)
-      (* runs com file, "filename" , with additional parameters "parameterList" , all of which must 
-	 be on the host, as an interactive-type job)
-      (category MainOps)]
-
-
-[METH Server  ServerDirectory NIL
-      (* returns the name of the server directory for command files)
-      (category Name)]
-
-
-[METH Server  SourceExtension NIL
-      (* returns default extension for source files)]
-
-
-[METH Server  Status (jobNumber)
-      (* get machine status of batch jobs)
-      (category MainOps)]
-
-
-[METH Server  SubmitJob (filename queue parameterList)
-      (* submits file, which must be on the host, as a batch job)
-      (category MainOps)]
-
-
-[METH Server  UserDirectory NIL
-      (* Gets user name on appropriate host)
-      (category Name)]
-
-
-[METH VMSServer  MakeCommandString (commandFile parameterList)
-      (* assembles command string from given name of commandFile and parameterList)]
-
-
-(DEFINEQ
-
-(FortranServer.Compile
-  (Method ((FortranServer Compile)
-	   self filename)                                    (* DSB " 5-Aug-86 10:44")
-                                                             (* compiles file, which must be on the host)
-	  (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName)
-								 (QUOTE COMPILE))
-				 (_ self ServerDirectory))
-	       filename
-	       (_ self MakeFullName (LISTGET (@ resultFileName)
-						 (QUOTE COMPILE)))
-	       T)))
-
-(FortranServer.Compiled?
-  (Method ((FortranServer Compiled?)
-	   self host defaultDirectory filename)              (* DSB "12-Aug-86 09:46")
-                                                             (* Checks if an object file exists on the host.
-							     If so, returns T)
-	  (INFILEP (PACKFILENAME (QUOTE HOST)
-				     (_ host Name)
-				     (QUOTE DIRECTORY)
-				     defaultDirectory
-				     (QUOTE NAME)
-				     filename
-				     (QUOTE EXTENSION)
-				     (QUOTE OBJ)))))
-
-(FortranServer.Link
-  (Method ((FortranServer Link)
-	   self filename linkedFilesList)                    (* DSB " 8-Aug-86 09:33")
-                                                             (* links object files on the host into an executable 
-							     file)
-
-          (* * linkedFilesList is either NIL or a list composed of a single string. The parameterList sent to RunFile is thus
-	  a list composed of the filename and optional string of linked files.)
-
-
-	  (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName)
-								 (QUOTE LINK))
-				 (_ self ServerDirectory))
-	       (CONS filename linkedFilesList)
-	       (_ self MakeFullName (LISTGET (@ resultFileName)
-						 (QUOTE LINK)))
-	       T)))
-
-(FortranServer.Linked?
-  (Method ((FortranServer Linked?)
-	   self host defaultDirectory filename)              (* DSB "12-Aug-86 10:10")
-                                                             (* Checks if an executable file exists on the host.
-							     If so, returns T)
-	  (INFILEP (PACKFILENAME (QUOTE HOST)
-				     (_ host Name)
-				     (QUOTE DIRECTORY)
-				     defaultDirectory
-				     (QUOTE NAME)
-				     filename
-				     (QUOTE EXTENSION)
-				     (QUOTE EXE)))))
-
-(MathServer.AlertManager
-  (Method ((MathServer AlertManager)
-	   self)                                             (* DSB "22-May-86 16:54")
-                                                             (* This method is called by all job processes.
-							     It starts up the JobManager process if not awakened, 
-							     and passes the jobManagerProcess variable.)
-
-          (* * Start MS.JobManager if it isn't going)
-
-
-	  (COND
-	    ((NOT (PROCESSP (@ ::jobManagerProcess)))
-	      (_@
-		::jobManagerProcess
-		(ADD.PROCESS (QUOTE (MS.JobManager))
-			       (NAME (QUOTE JobManager)
-				     RESTARTABLE
-				     (QUOTE HARDRESET)))))
-	    (T NIL))))
-
-(Server.AbortJob
-  (Method ((Server AbortJob)
-	   self jobNumber queue)                             (* DSB "12-Aug-86 18:07")
-                                                             (* aborts specific batch job on stated queue)
-	  (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName)
-								 (QUOTE ABORTJOB))
-				 (_ self ServerDirectory))
-	       (LIST jobNumber queue)
-	       (_ self MakeFullName (LISTGET (@ resultFileName)
-						 (QUOTE ABORTJOB))))))
-
-(Server.CommandFileExtension
-  (Method ((Server CommandFileExtension)
-	   self)                                             (* DSB "10-Nov-86 08:19")
-                                                             (* returns the extension recognized by the system as a
-							     command file)
-	  (@ commandFileExtension)))
-
-(Server.Description
-  (Method ((Server Description)
-	   self)                                             (* DSB "19-Aug-86 14:29")
-                                                             (* returns description of the server)
-	  (@ description)))
-
-(Server.Error?
-  (Method ((Server Error?)
-	   self result)                                      (* DSB "21-May-86 11:44")
-                                                             (* checks if CAR of result list is "ERROR")
-	  (EQ (QUOTE ERROR)
-		(CAR result))))
-
-(Server.ErrorFile
-  (Method ((Server ErrorFile)
-	   self result)                                      (* DSB "21-May-86 11:50")
-                                                             (* returns the full name of the error file, specified 
-							     by the third element in the result list)
-	  (INFILEP (_ self MakeFullName (CADDR result)))))
-
-(Server.ErrorString
-  (Method ((Server ErrorString)
-	   self result)                                      (* DSB "21-May-86 11:46")
-                                                             (* returns the error string: the second element in 
-							     result list)
-	  (CADR result)))
-
-(Server.ExecuteCommandFile
-  (Method ((Server ExecuteCommandFile)
-	   self commandFile parameterList)                   (* DSB "10-Nov-86 10:59")
-                                                             (* method to run a command file.
-							     The command string is assembled by the local method 
-							     CommandString)
-	  (PROGRAMCHAT (_ self Host)
-			 (_ self MakeCommandString commandFile parameterList)
-			 NIL)))
-
-(Server.ExtractFilename
-  (Method ((Server ExtractFilename)
-	   self result)                                      (* DSB " 6-Aug-86 11:28")
-                                                             (* Extract error file name from result)
-	  (CAR (REVERSE result))))
-
-(Server.GetQueues
-  (Method ((Server GetQueues)
-	   self)                                             (* DSB " 9-Jun-86 08:41")
-                                                             (* returns the list of queues for the server)
-	  (@ queues)))
-
-(Server.GetTime
-  (Method ((Server GetTime)
-	   self)                                             (* DSB "13-Jun-86 13:17")
-                                                             (* gets the time from the server)
-                                                             (* RunFile returns a list whose CAR is OK)
-	  (_ self Result (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName)
-										  (QUOTE GETTIME))
-						  (_ self ServerDirectory))
-				NIL
-				(_ self MakeFullName (LISTGET (@ resultFileName)
-								  (QUOTE GETTIME)))
-				NIL))))
-
-(Server.Host
-  (Method ((Server Host)
-	   self)                                             (* DSB "23-May-86 13:52")
-                                                             (* returns local server instance variable host)
-	  (CANONICAL.HOSTNAME (@ host))))
-
-(Server.MakeError
-  (Method ((Server MakeError)
-	   self string fileName)                             (* DSB "21-May-86 15:49")
-                                                             (* makes an ERROR ... list)
-	  (LIST (QUOTE ERROR)
-		  string fileName)))
-
-(Server.MakeFullName
-  (Method ((Server MakeFullName)
-	   self fileName directory)                          (* DSB "22-May-86 14:54")
-                                                             (* Constructs full name of file and host)
-
-          (* * if directory is not specified, it uses the user's login name on the host; i.e., the user's directory)
-
-
-	  (COND
-	    ((NOT directory)
-	      (PACKFILENAME (QUOTE HOST)
-			      (_ self Host)
-			      (QUOTE DIRECTORY)
-			      (_ self UserDirectory)
-			      (QUOTE BODY)
-			      fileName))
-	    (T 
-
-          (* * otherwise, it uses the specified directory name)
-
-
-	       (PACKFILENAME (QUOTE HOST)
-			       (_ self Host)
-			       (QUOTE DIRECTORY)
-			       directory
-			       (QUOTE BODY)
-			       fileName)))))
-
-(Server.MakePartialName
-  (Method ((Server MakePartialName)
-	   self fileName directory)                          (* DSB "13-Jun-86 13:07")
-                                                             (* Constructs name of file with directory, but without
-							     host)
-
-          (* * if directory is not specified, it uses the user's login name on the host; i.e., the user's root directory)
-
-
-	  (COND
-	    ((NOT directory)
-	      (PACKFILENAME (QUOTE DIRECTORY)
-			      (_ self UserDirectory)
-			      (QUOTE BODY)
-			      fileName))
-	    (T 
-
-          (* * otherwise, it uses the specified directory name)
-
-
-	       (PACKFILENAME (QUOTE DIRECTORY)
-			       directory
-			       (QUOTE BODY)
-			       fileName)))))
-
-(Server.Name
-  (Method ((Server Name)
-	   self)                                             (* DSB " 9-Jun-86 08:34")
-                                                             (* returns vernacular server name)
-	  (@ name)))
-
-(Server.PutErrorInWindow
-  (Method ((Server PutErrorInWindow)
-	   self errorFile errorWindow mainWindow)            (* DSB "15-Aug-86 17:42")
-                                                             (* puts text of errorFile in a window)
-
-          (* * put the errorFile in the errorWindow and set errorWindow props)
-
-
-	  (OPENTEXTSTREAM errorFile errorWindow NIL NIL (QUOTE (PROMPTWINDOW (WINDOWPROP
-										   mainWindow
-										   (QUOTE 
-										     PROMPTWINDOW)))))
-	  (WINDOWPROP errorWindow (QUOTE ERRORFILE)
-			errorFile)
-	  (WINDOWADDPROP errorWindow (QUOTE CLOSEFN)
-			   (QUOTE MS.CleanupErrorFile))))
-
-(Server.PutTextInWindow
-  (Method ((Server PutTextInWindow)
-	   self filename position)                           (* DSB "21-Jul-86 14:23")
-                                                             (* Opens a scrollable TEDIT window for the file)
-	  (TEDIT filename NIL NIL (QUOTE (READONLY T)))))
-
-(Server.Result
-  (Method ((Server Result)
-	   self result)                                      (* DSB "21-May-86 17:52")
-                                                             (* returns the second element in the result list when 
-							     there is no error. This is typically the jobID.)
-	  (CADR result)))
-
-(Server.RunFile
-  (Method ((Server RunFile)
-	   self file parameterList resultFile noErrorFlg)    (* DSB " 9-Nov-86 13:49")
-                                                             (* general method to run a command file and get result
-							     and errors)
-
-          (* * "file" is the name of the command file given to PROGRAMCHAT to be run on the host, and it must be in the 
-	  proper host format (eg, <gslws.server>submitjob) whereas "resultFile" is the name of the result file returned on 
-	  the host, but it must be in the proper LISP naming format (eg, {GSLVAX10}<bloomberg>submitjob.res))
-
-
-	  (LET (f result fullResultFile newFile)
-
-          (* * runs a command file)
-
-
-	       (_ self ExecuteCommandFile file parameterList)
-
-          (* * look for result file)
-
-
-	       (COND
-		 ((SETQ fullResultFile (INFILEP (_ self MakeFullName resultFile)))
-		   (SETQ f (OPENFILE fullResultFile (QUOTE INPUT)))
-		   (SETQ result (READ f))
-		   (CLOSEF f)                              (* (DELFILE f))
-		   )
-		 (T (SETQ result (_ self MakeError "no result" NIL))))
-
-          (* * handle the errors)
-
-
-
-          (* * default case (noErrorFlg=NIL) is not to return on errors. In this case, generate a break with an error 
-	  message.)
-
-
-
-          (* * Otherwise, do not break (if noErrorFlg=T). Instead, copy the error file to a file on core, and return its 
-	  filename (e.g., {core}compile.err))
-
-
-
-          (* * after this runs, start up Job Manager, using (_ self AlertManager))
-
-
-	       (COND
-		 ((NOT noErrorFlg)
-		   (COND
-		     ((_ self Error? result)
-		       (DELFILE (_ self ErrorFile result))
-		       (ERROR (CONCAT (_ self Name)
-					  ": "
-					  (_ self ErrorString result))))
-		     (T (SETQ result (_ self Result result)))))
-		 (T                                          (* return complete result to user)
-		    (COND
-		      ((_ self Error? result)
-			(COND
-			  ((SETQ f (_ self ErrorFile result))
-			    (SETQ newFile (COPYFILE f (PACKFILENAME (QUOTE HOST)
-									  (QUOTE CORE)
-									  (QUOTE BODY)
-									  (_ self ExtractFilename 
-									       result))))
-                                                             (* (DELFILE f))
-			    (SETQ result (_ self MakeError (_ self ErrorString result)
-						newFile)))
-			  (T result)))
-		      (T result))))
-
-          (* * starts up JobManager, etc. Not yet implemented)
-
-                                                             (* (_ self AlertManager))
-	   result)))
-
-(Server.RunJob
-  (Method ((Server RunJob)
-	   self filename parameterList)                      (* DSB "11-Aug-86 11:06")
-                                                             (* runs com file, "filename", with additional 
-							     parameters "parameterList", all of which must be on 
-							     the host, as an interactive-type job)
-
-          (* * parameterList is in RunJob either NIL or a list of parameters composed of a single string.
-	  The parameterList sent to RunFile is thus a list composed of the filename and optional string of associated 
-	  parameters.)
-
-
-	  (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName)
-								 (QUOTE RUNJOB))
-				 (_ self ServerDirectory))
-	       (CONS filename parameterList)
-	       (_ self MakeFullName (LISTGET (@ resultFileName)
-						 (QUOTE RUNJOB)))
-	       T)))
-
-(Server.ServerDirectory
-  (Method ((Server ServerDirectory)
-	   self)                                             (* DSB "22-May-86 15:37")
-                                                             (* returns the name of the server directory for 
-							     command files)
-	  (@ serverDirectory)))
-
-(Server.SourceExtension
-  (Method ((Server SourceExtension)
-	   self)                                             (* DSB "21-Aug-86 16:46")
-                                                             (* returns default extension for source files)
-	  (@ sourceExtension)))
-
-(Server.Status
-  (Method ((Server Status)
-	   self jobNumber)                                   (* DSB "12-Aug-86 13:51")
-                                                             (* get machine status of batch jobs)
-
-          (* if a jobNumber is specified it returns either the CPU time elapsed (if running) or the error message if it 
-	  bombed, or NIL if neither.)
-
-
-
-          (* if no jobNumber is specified, returns a list, each element of which is a prop list of the form 
-	  ((JOB jobNumber) (CPU timeElapsed)))
-
-
-	  (LET (errorFile f result)
-
-          (* * if a jobNumber is specified, return its status)
-
-
-	       (COND
-		 (jobNumber (OR (CAR (_ self RunFile (_ self MakePartialName
-								(LISTGET (@ comFileName)
-									   (QUOTE STATUS))
-								(_ self ServerDirectory))
-					      jobNumber
-					      (_ self MakeFullName (LISTGET (@ resultFileName)
-										(QUOTE STATUS)))
-					      NIL))
-				  (COND
-				    ((SETQ errorFile (INFILEP (_ self MakeFullName
-								       (CONCAT jobNumber ".res"))))
-				      (SETQ f (OPENFILE errorFile (QUOTE INPUT)))
-				      (SETQ result (READ f))
-				      (CLOSEF f)           (* (DELFILE f))
-				      result)
-				    (T NIL))))
-		 (T 
-
-          (* * else, return the status of all active jobs)
-
-
-		    (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName)
-									   (QUOTE STATUS))
-					   (_ self ServerDirectory))
-			 jobNumber
-			 (LISTGET (@ resultFileName)
-				    (QUOTE STATUS))
-			 NIL))))))
-
-(Server.SubmitJob
-  (Method ((Server SubmitJob)
-	   self filename queue parameterList)                (* DSB " 8-Aug-86 11:47")
-                                                             (* submits file, which must be on the host, as a batch
-							     job)
-
-          (* * parameterList in SubmitJob is either NIL or a list of parameters composed of a single string.
-	  The parameterList sent to RunFile is thus a list ocmposed of the filename, queue, and optional string of associated
-	  parameters.)
-
-
-	  (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName)
-								 (QUOTE SUBMITJOB))
-				 (_ self ServerDirectory))
-	       (CONS filename (CONS queue parameterList))
-	       (_ self MakeFullName (LISTGET (@ resultFileName)
-						 (QUOTE SUBMITJOB)))
-	       NIL)))
-
-(Server.UserDirectory
-  (Method ((Server UserDirectory)
-	   self)                                             (* DSB "13-Jun-86 11:34")
-                                                             (* Gets user name on appropriate host)
-                                                             (* Forces login if not logged in)
-	  (OR (MKATOM (CAAR (GETHASH (CANONICAL.HOSTNAME (_ self Host))
-					     LOGINPASSWORDS)))
-		(LOGIN (_ self Host)))))
-
-(VMSServer.MakeCommandString
-  (Method ((VMSServer MakeCommandString)
-	   self commandFile parameterList)                   (* DSB "22-May-86 16:05")
-                                                             (* assembles command string from given name of 
-							     commandFile and parameterList)
-                                                             (* Note that the commandFile and the parameterList 
-							     must be quoted when this function is called)
-	  (CONCAT "@" commandFile (for p in (MKLIST parameterList) bind (s _ "")
-				       do (SETQ s (CONCAT s " " p)) finally (RETURN s)))))
-)
-(DEFINEQ
-
-(MS.MakeInstances
-  (LAMBDA NIL                                                (* DSB " 9-Oct-86 11:18")
-                                                             (* Initialization routine: makes browser and instances
-							     of servers)
-
-          (* * make class browser for Server)
-
-
-    (LET (newBrowser)
-         (SETQ newBrowser (_ ($ ClassBrowser)
-				 New))
-         (_ newBrowser AddRoot ($ Server)))
-
-          (* * make $GSLVAX instance of VMSServer)
-
-
-    (_ ($ VMSServer)
-	 New
-	 (QUOTE GSLVAX))
-    (_@
-      ($ GSLVAX)
-      host
-      (QUOTE GSLVAX))
-    (_@
-      ($ GSLVAX)
-      name
-      (QUOTE GSLVAX))
-    (_@
-      ($ GSLVAX)
-      description "The GSL 11/780 VMS Server")
-    (_@
-      ($ GSLVAX)
-      serverDirectory
-      (QUOTE <GSLWS.SERVER>))
-    (_@
-      ($ GSLVAX)
-      queues
-      (QUOTE (Fast Medium Slow)))
-
-          (* * make $SITKA instance of VMSServer)
-
-                                                             (* the host value, SITKA, refers to the pup address 
-							     204#156#)
-    (_ ($ VMSServer)
-	 New
-	 (QUOTE SITKA))
-    (_ ($ SITKA)
-	 PutValue
-	 (QUOTE host)
-	 (QUOTE SITKA))
-    (_@
-      ($ SITKA)
-      name
-      (QUOTE SITKA))
-    (_@
-      ($ SITKA)
-      description "The GSL microVAX VMS Server")
-    (_@
-      ($ SITKA)
-      serverDirectory
-      (QUOTE <bloomberg.gslws>))
-    (_@
-      ($ SITKA)
-      queues
-      (QUOTE (Fast Slow)))
-    (_@
-      ($ SITKA)
-      comFileName
-      (QUOTE (SUBMITJOB submitJob.com ABORTJOB abortJob.com RUNJOB runJob.com STATUS status.com 
-			  COMPILE compile.com LINK link.com GETTIME getTime.com)))
-    (_@
-      ($ SITKA)
-      resultFileName
-      (QUOTE (SUBMITJOB submitJob.res ABORTJOB abortJob.res RUNJOB runJob.res STATUS status.res 
-			  COMPILE compile.res LINK link.res GETTIME getTime.res)))
-
-          (* * make $MADVAX instance of VMSServer)
-
-
-    (_ ($ VMSServer)
-	 New
-	 (QUOTE MADVAX))
-    (_@
-      ($ MADVAX)
-      host
-      (QUOTE MADVAX))
-    (_@
-      ($ MADVAX)
-      name
-      (QUOTE MADVAX))
-    (_@
-      ($ MADVAX)
-      description "The AIS 11/750 VMS Server")
-    (_@
-      ($ MADVAX)
-      serverDirectory
-      (QUOTE <bloomberg.gslws>))
-    (_@
-      ($ MADVAX)
-      queues
-      (QUOTE (Fast Medium Slow)))
-
-          (* * make $CRAYZY instance of Cray VaporServer)
-
-
-    (_ ($ Cray)
-	 New
-	 (QUOTE CRAYZY))
-    (_ ($ CRAYZY)
-	 PutValue
-	 (QUOTE host)
-	 (QUOTE CRAYZY))
-    (_@
-      ($ CRAYZY)
-      name
-      (QUOTE CRAYZY))
-    (_@
-      ($ CRAYZY)
-      description "Not yet plugged in...")))
-
-(StripPA
-  (LAMBDA (username)                                         (* DSB "22-May-86 11:50")
-    (SUBATOM username 1 (LET ((POS (STRPOS "." username)))
-			       (COND
-				 ((FIXP POS)
-				   (SUB1 POS))
-				 (T NIL))))))
-)
-(MS.DestroyInstances)
-(MS.MakeInstances)
-(* * PROGRAMCHAT - Windowless CHAT for communication)
-
-(DEFINEQ
-
-(OPENCHATSTREAM
-  (LAMBDA (HOST)                                             (* ejs: "23-Feb-85 19:22")
-    (PROG (OPENFUNCTION)
-	    (COND
-	      ((BOUNDP (QUOTE CHAT.PROTOCOLTYPES))
-		(COND
-		  ((for PROTOCOL in CHAT.PROTOCOLTYPES thereis (SETQ OPENFUNCTION
-								       (APPLY* (CDR PROTOCOL)
-										 HOST)))
-		    (RETURN (APPLY* (CADR OPENFUNCTION)
-					(CAR OPENFUNCTION))))))
-	      ((BOUNDP (QUOTE CHAT.PROTOCOLS))
-		(COND
-		  ((for PROTOCOL in CHAT.PROTOCOLS thereis (SETQ OPENFUNCTION
-								   (APPLY* PROTOCOL HOST)))
-		    (RETURN (APPLY* (CADR OPENFUNCTION)
-					(CAR OPENFUNCTION))))))))))
-
-(PROGRAMCHAT
-  (LAMBDA (HOST CMDSTREAM LOGSTREAM)                         (* DSB " 9-Nov-86 13:02")
-    (PROG ((STREAMPAIR (OPENCHATSTREAM HOST))
-	     INCHAT OUTCHAT)
-	    (COND
-	      (STREAMPAIR (SETQ INCHAT (CAR STREAMPAIR))
-			  (SETQ OUTCHAT (CDR STREAMPAIR))
-			  (SETFILEINFO OUTCHAT (QUOTE ENDOFSTREAMOP)
-					 (FUNCTION CHAT.ENDOFSTREAMOP))
-			  (SETFILEINFO INCHAT (QUOTE ENDOFSTREAMOP)
-					 (FUNCTION CHAT.ENDOFSTREAMOP))
-			  (ADD.PROCESS (BQUOTE (PROGRAMCHAT.OUTPUT (QUOTE , INCHAT)
-									 (QUOTE , LOGSTREAM))))
-			  (BLOCK)
-			  (PROGRAMCHAT.LOGIN HOST INCHAT OUTCHAT)
-			  (COND
-			    ((STRINGP CMDSTREAM)
-			      (SETQ CMDSTREAM (OPENSTRINGSTREAM CMDSTREAM (QUOTE INPUT)))))
-			  (COND
-			    ((NULL LOGSTREAM)
-			      (SETQ LOGSTREAM (OPENSTREAM (QUOTE {NULL})
-							      (QUOTE OUTPUT)))))
-			  (while (AND (OPENP OUTCHAT (QUOTE OUTPUT))
-					  (NOT (EOFP CMDSTREAM)))
-			     do (BOUT OUTCHAT (BIN CMDSTREAM))
-				  (BLOCK)
-			     finally (COND
-					 ((EOFP CMDSTREAM)
-					   (CLOSEF CMDSTREAM)
-					   (BOUT OUTCHAT (CHARCODE CR))
-					   (PROGRAMCHAT.LOGIN HOST INCHAT OUTCHAT (QUOTE LOGOUT))
-					   (FORCEOUTPUT OUTCHAT T)
-					   (until (NOT (OPENP INCHAT (QUOTE INPUT)))
-					      do (BLOCK) finally (CLOSEF OUTCHAT))))))))))
-
-(PROGRAMCHAT.LOGIN
-  (LAMBDA (HOST INSTREAM OUTSTREAM OPTION)                   (* ejs: "24-Jan-85 18:52")
-
-          (* * Login to HOST. If a job already exists on HOST, Attach to it unless OPTION overrides.)
-
-
-    (PROG ((LOGINFO (CDR (ASSOC (OR (GETOSTYPE HOST)
-					    (QUOTE IFS))
-				      NETWORKLOGINFO)))
-	     NAME/PASS COM)
-	    (OR LOGINFO (RETURN))
-	    (SETQ NAME/PASS (\INTERNAL/GETPASSWORD HOST))
-	    (SETQ COM (COND
-		(OPTION)
-		((ASSOC (QUOTE ATTACH)
-			  LOGINFO)
-		  (OR (CHAT.LOGINFO INSTREAM HOST (CAR NAME/PASS))
-			(QUOTE LOGIN)))
-		(T                                           (* Don't know how to do anything but login, so silly 
-							     to try anything else)
-		   (QUOTE LOGIN))))
-	    (COND
-	      ((NULL (SETQ LOGINFO (ASSOC COM LOGINFO)))
-		(printout PROMPTWINDOW T "Login option " COM " not implemented for this type of host")
-		)
-	      (T (for X in (CDR LOGINFO) do (SELECTQ X
-							       (CR (BOUT OUTSTREAM (CHARCODE
-									     CR))
-								   (FORCEOUTPUT OUTSTREAM))
-							       (USERNAME (PRIN3 (CAR NAME/PASS)
-										    OUTSTREAM))
-							       (PASSWORD (PRIN3
-									   (\DECRYPT.PWD
-									     (CDR NAME/PASS))
-									   OUTSTREAM))
-							       (WAIT 
-                                                             (* Some systems do not permit typeahead)
-								     (COND
-								       ((NOT (CHAT.FLUSH&WAIT
-										 INSTREAM))
-                                                             (* Couldn't sync, so wait longer.)
-									 (DISMISS CHAT.WAIT.TIME)))
-								     (DISMISS CHAT.WAIT.TIME))
-							       (PRIN3 X OUTSTREAM)))
-		 (FORCEOUTPUT OUTSTREAM))))))
-
-(PROGRAMCHAT.OUTPUT
-  (LAMBDA (INCHATSTREAM LOGSTREAM)                           (* ejs: "23-Feb-85 19:18")
-    (bind CH while (AND (NEQ CH -1)
-			      (OPENP INCHATSTREAM (QUOTE INPUT)))
-       do (SETQ CH (BIN INCHATSTREAM))
-	    (COND
-	      ((NEQ CH -1)
-		(COND
-		  (LOGSTREAM (BOUT LOGSTREAM CH)))))
-       finally (COND
-		   ((OPENP INCHATSTREAM)
-		     (CLOSEF INCHATSTREAM))))))
-)
-
-
-
-(* VARS for our site)
-
-
-(RPAQQ NETWORKLOGINFO ((TENEX (LOGIN "LOGIN " USERNAME " " PASSWORD " 
-")
-				(ATTACH "ATTACH " USERNAME " " PASSWORD " 
-")
-				(WHERE "WHERE " USERNAME CR "ATTACH " USERNAME " " PASSWORD CR)
-				(LOGOUT "LOGOUT" CR))
-	(TOPS20 (LOGIN "LOGIN " USERNAME CR PASSWORD CR)
-		(ATTACH "ATTACH " USERNAME "" CR PASSWORD CR)
-		(WHERE "LOGIN " USERNAME CR PASSWORD CR)
-		(LOGOUT "LOGOUT" CR))
-	(UNIX (LOGIN WAIT CR WAIT USERNAME CR WAIT PASSWORD CR WAIT WAIT WAIT WAIT CR)
-	      (LOGOUT WAIT CR "logout" CR))
-	(IFS (LOGIN "Login " USERNAME " " PASSWORD CR)
-	     (ATTACH)
-	     (LOGOUT "Quit" CR))
-	(VMS (LOGIN USERNAME CR PASSWORD CR)
-	     (LOGOUT "LOGOUT" CR))
-	(NS (LOGIN "Logon" CR USERNAME CR PASSWORD CR)
-	    (LOGOUT "LOGOFF" CR))))
-(pushnew NETWORKOSTYPES (QUOTE (GSLVAX . VMS))
-	 (QUOTE (SITKA . VMS))
-	 (QUOTE (MADVAX . VMS)))
-(* * PROGRAMMER'S INTERFACE - use remote servers with LISP calls)
-
-(DEFINEQ
-
-(PRIN.RunRemote
-  (LAMBDA (hostname filename parameterList)                  (* DSB "25-Nov-86 09:41")
-                                                             (* Main Programmer's Interface 
-							     (PRIN) function)
-    (PROG (host file result)
-
-          (* * check preliminaries)
-
-
-	    (SETQ host (PRIN.ValidateHost hostname))
-	    (COND
-	      ((NOT host)
-		(RETURN (PRIN.Error (CONCAT "Host " (U-CASE hostname)
-						  " is not valid")))))
-	    (SETQ file (PRIN.ValidateFilename filename host hostname))
-	    (COND
-	      ((NOT file)
-		(RETURN (PRIN.Error (CONCAT "Command file " filename " does not exist")))))
-
-          (* * run the job)
-
-
-	    (SETQ result (_ host RunJob file parameterList))
-
-          (* * handle the results)
-
-
-	    (COND
-	      ((EQUAL (CAR result)
-			(QUOTE ERROR))
-		(PRIN.Error "Run-time warning or error" host file result))
-	      (T (PROMPTPRINT (CONCAT "Call to remote host " (U-CASE hostname)
-					  " succeeded without error"))
-		 (RETURN T))))))
-
-(PRIN.ValidateHost
-  (LAMBDA (hostname)                                         (* DSB "10-Nov-86 08:06")
-                                                             (* returns the host, or NIL if nonexistant)
-    (PROG (host)
-	    (SETQ host (FE.GetServer (U-CASE hostname)))
-	    (RETURN host))))
-
-(PRIN.ValidateFilename
-  (LAMBDA (filename host hostname)                           (* DSB "10-Nov-86 08:40")
-                                                             (* returns file if command file exists, or NIL 
-							     otherwise)
-    (PROG (directory name extension wholename fileExists?)
-	    (SETQ directory (UNPACKFILENAME filename (QUOTE DIRECTORY)))
-	    (SETQ name (UNPACKFILENAME filename (QUOTE NAME)))
-	    (SETQ extension (_ host CommandFileExtension))
-	    (SETQ wholename (PACKFILENAME (QUOTE HOST)
-					      (U-CASE hostname)
-					      (QUOTE DIRECTORY)
-					      directory
-					      (QUOTE NAME)
-					      name
-					      (QUOTE EXTENSION)
-					      extension))
-	    (SETQ fileExists? (INFILEP wholename))
-	    (COND
-	      ((NOT fileExists?)
-		(RETURN NIL))
-	      (T (RETURN (PACKFILENAME (QUOTE DIRECTORY)
-					   directory
-					   (QUOTE NAME)
-					   name)))))))
-
-(PRIN.Error
-  (LAMBDA (errorString host file result)                     (* DSB "10-Nov-86 11:17")
-                                                             (* opens an error window and prints the error string 
-							     and any run-time error messages)
-    (PROG (hostname errorWindow errorFile)
-	    (COND
-	      ((AND host file)
-		(SETQ hostname (_ host Name))
-		(SETQ errorWindow (CREATEW (QUOTE (300 300 420 200))
-					       (CONCAT "PRIN: " errorString " on host " hostname)))
-		(SETQ errorFile (_ host ExtractFilename result))
-		(_ host PutErrorInWindow errorFile errorWindow))
-	      (T (SETQ errorWindow (CREATEW (QUOTE (300 300 300 80))
-						"Programmer's Interface Error Window"))
-		 (PRIN1 errorString errorWindow))))))
-)
-(PUTPROPS MATHSERVER COPYRIGHT ("Xerox Corporation" 1986 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (4197 14885 (MS.TopLevel 4207 . 5531) (MS.CreateFreeMenu 5533 . 8329) (MS.SelectHost 
-8331 . 9538) (MS.ExpandFilename 9540 . 10736) (MS.CloseErrorWindow 10738 . 11298) (MS.CleanupErrorFile
- 11300 . 11832) (MS.AttachErrorWindow 11834 . 12844) (MS.MostRoom 12846 . 13508) (MS.GetMessageWindow 
-13510 . 13852) (MS.MakeIconWindow 13854 . 14099) (PrintMsg 14101 . 14883)) (14925 15698 (
-MS.MakeMenuOfKnownHosts 14935 . 15351) (MS.DestroyInstances 15353 . 15696)) (15733 38409 (
-MS.SubmitBatchJob 15743 . 18415) (MS.AbortBatchJob 18417 . 20283) (MS.Status 20285 . 21644) (
-MS.DisplayStatus 21646 . 22635) (MS.RunInteractiveJob 22637 . 25063) (MS.Compile 25065 . 27193) (
-MS.Link 27195 . 29585) (MS.CompileLink 29587 . 32889) (MS.CLR.Check 32891 . 33195) (MS.CLR.NoCheck 
-33197 . 33507) (MS.CompileLinkRun 33509 . 38407)) (38447 42814 (MS.StartNewFE 38457 . 38753) (
-MS.StartDefaultFE 38755 . 40730) (MS.FindFortranEdit 40732 . 41673) (MS.CheckForDirtyFile 41675 . 
-42812)) (42852 47051 (MS.BatchErrors? 42862 . 45339) (MS.BatchLog 45341 . 47049)) (50865 60017 (
-FE.TopLevel 50875 . 52556) (FE.AdjustProps 52558 . 53265) (FE.CaretPosition 53267 . 55145) (
-TEDIT.PARA&CHAR 55147 . 56522) (FE.CharFn 56524 . 56830) (FE.GetEditProps 56832 . 57951) (
-FE.GetSourceFileName 57953 . 59635) (FE.LoopFn 59637 . 60015)) (60047 64784 (FE.GetPositionWindow 
-60057 . 61139) (FE.GetEditWindow 61141 . 62925) (FE.GetMessageWindow 62927 . 63409) (FE.ReshapeFn 
-63411 . 63721) (FE.ShadeWindow 63723 . 64782)) (64817 84050 (FE.CreateLocalMenu 64827 . 66468) (
-FE.SetHost 66470 . 67980) (FE.SetDirectory 67982 . 69411) (FE.MyGet 69413 . 70543) (FE.MyPut 70545 . 
-72589) (FE.StripVersion 72591 . 73415) (FE.Compile 73417 . 75646) (FE.Link 75648 . 77825) (
-FE.CompileLinkRun 77827 . 81823) (FE.RunInteractive 81825 . 84048)) (84090 85128 (FE.ValidHostname 
-84100 . 84668) (FE.GetServer 84670 . 85126)) (85152 87199 (FE.ShrinkIconCreate 85162 . 87197)) (99037 
-117564 (FortranServer.Compile 99047 . 99571) (FortranServer.Compiled? 99573 . 100108) (
-FortranServer.Link 100110 . 100890) (FortranServer.Linked? 100892 . 101427) (MathServer.AlertManager 
-101429 . 102140) (Server.AbortJob 102142 . 102665) (Server.CommandFileExtension 102667 . 103004) (
-Server.Description 103006 . 103269) (Server.Error? 103271 . 103560) (Server.ErrorFile 103562 . 103938)
- (Server.ErrorString 103940 . 104248) (Server.ExecuteCommandFile 104250 . 104711) (
-Server.ExtractFilename 104713 . 105001) (Server.GetQueues 105003 . 105265) (Server.GetTime 105267 . 
-105888) (Server.Host 105890 . 106167) (Server.MakeError 106169 . 106451) (Server.MakeFullName 106453
- . 107300) (Server.MakePartialName 107302 . 108087) (Server.Name 108089 . 108328) (
-Server.PutErrorInWindow 108330 . 109007) (Server.PutTextInWindow 109009 . 109329) (Server.Result 
-109331 . 109668) (Server.RunFile 109670 . 112378) (Server.RunJob 112380 . 113285) (
-Server.ServerDirectory 113287 . 113604) (Server.SourceExtension 113606 . 113890) (Server.Status 113892
- . 115534) (Server.SubmitJob 115536 . 116388) (Server.UserDirectory 116390 . 116888) (
-VMSServer.MakeCommandString 116890 . 117562)) (117565 120654 (MS.MakeInstances 117575 . 120398) (
-StripPA 120400 . 120652)) (120756 125312 (OPENCHATSTREAM 120766 . 121492) (PROGRAMCHAT 121494 . 122998
-) (PROGRAMCHAT.LOGIN 123000 . 124845) (PROGRAMCHAT.OUTPUT 124847 . 125310)) (126250 129561 (
-PRIN.RunRemote 126260 . 127389) (PRIN.ValidateHost 127391 . 127722) (PRIN.ValidateFilename 127724 . 
-128739) (PRIN.Error 128741 . 129559)))))
-STOP
diff --git a/obsolete/lispusers/MATHSERVER.COMMANDFILES b/obsolete/lispusers/MATHSERVER.COMMANDFILES
deleted file mode 100644
index 41e6e624..00000000
--- a/obsolete/lispusers/MATHSERVER.COMMANDFILES
+++ /dev/null
@@ -1,13 +0,0 @@
-ABORTJOB.COM

$ !  abortJob.com
$ ! this file is used to abort a batch job
$ !  p1 is the jobNumber; p2 is the queue
$ ! The "show batch" command is used to determine if the job exists.  If 
$ !    it does not, the message NIL is returned; otherwise, the job is
$ !   aborted.
$ ! All messages are returned to the user's root directory.
$ ! If there is a serious error, ...
$ ! if there is an error in the running of this com file, the detailed
$ !   error message gets sent to abortJob.err in the user's root directory.


$ !SET VERIFY
$	delete sys$login:abortJob.err.*
$	delete sys$login:abortJob.res.*
$ SET NOVERIFY
$	define sys$output abortJob.tmp
$	show queue 'P2'
$	deassign sys$output
$ !SET VERIFY
$	open/write result sys$login:abortJob.res
$
$ loop:
$	open/read file abortJob.tmp
$	read/end_of_file=done file line
$	jobNumber = f$integer(f$extract(32,4,line))
$	if jobNumber .eq. P1 then goto found
$	goto loop
$
$ done:
$	write result "( OK NIL)"   ! job not found
$	goto finish
$
$ found:
$	define sys$error sys$login:abortJob.err
$	on error then goto error
$ 	stop/entry='P1' 'P2'
$	deassign sys$error
$	write result "( OK ( Job ",P1," on queue ",P2,-
         " has been aborted))"
$	
$ finish:
$	close result
$	close file
$	delete abortJob.tmp.*
$ 	exit

$  error:
$ 	@[gslws.server]error sys$login:abortJob.res '$STATUS'
$	deassign sys$error
$	close result
$	close file
$	delete abortJob.tmp.*
-----------------------------------

COMPILE.COM

$ !  COMPILE.COM      8/7/86
$ ! this file is used to compile a job interactively.
$ !  job is the name of the user's fortran source file
$ ! the file exists in the user's local directory, which may be a
$ !  subdirectory of the root directory.
$ ! the object file is made in the user's local directory.
$ ! if there is no error in compilation, the name and date of the
$ !   object file are returned in sys$login:compile.res.
$ ! if there is an error in compilation, the abbreviated error message
$ !   is returned in sys$login:compile.res, and the detailed
$ !   error message is written to sys$login:compile.err.
$
$
$ !SET VERIFY
$ 	job = f$parse("''P1'",,,"name")
$	userDirectory = f$parse("''P1'",,,"directory")
$       length=f$length(job)
$ !	show symbol job
$ !	show symbol userDirectory
$ !     show sym length
$	delete sys$login:compile.err.*
$	delete sys$login:compile.res.*
$	delete 'P1'.obj.*
$ 	define sys$error sys$login:compile.err
$ !	define sys$error sys$login:'job'.err
$	on error then goto error
$
$ 	fortran/object='userDirectory''job' 'P1'
$	deassign sys$error
$  SET NOVERIFY
$       define sys$output sys$login:objFile.tmp
$       dir/date 'P1'.obj
$       deassign sys$output
$  !SET VERIFY
$ 	open/write resultFile sys$login:compile.res
$       open/read file sys$login:objFile.tmp
$
$ loop:
$       read/end_of_file=done file line
$ !      show sym line
$       name=f$extract(0,length,line)
$ !      show sym name
$       if name .eqs. job then goto found
$       goto loop
$
$ done:
$       write resultFile "( OK NIL)"   ! object file not found
$       goto finish
$
$ found:
$	write resultFile "( OK (",line,"))"
$
$ finish:
$	close resultFile
$       close file
$       delete objFile.tmp.*
$ 	exit
$
$  error:
$ 	@[gslws.server]error sys$login:compile.res '$STATUS'
$	deassign sys$error
-----------------------

ERROR.COM
$ ! lists error status message in specified file
$ ! call by: @error resultFile errorStatus
$
$	open/write result 'P1'
$	errorFile = f$logical("sys$error")
$ !            show sym errorFile
$       shortName=f$parse(errorFile,,,"name")
$ !            show sym shortName
$	write result "(ERROR ""''f$message(P2)'"" ''shortName'.ERR)"
$	close result
----------------------------

LINK.COM

$ !  LINK.COM     8/8/86
$ ! This file is used to link a series of object files to form an
$ !   executable file.
$ ! The parameter P1 is the object code filename of the main file.
$ ! The parameter P2 is a string composed of all object files to
$ !   be linked with P1.  There must be a comma between these files
$ !   within P2.
$ ! Job is the extracted name of the user's main object code file.
$ !   This file exists in the user's local directory, which may be a
$ !   subdirectory of the root directory.
$ ! The executable file is made in the user's local directory.
$ ! If there is no error in linking, the name and date of the
$ !   executable file are returned in sys$login:link.res.
$ ! If there is no error in linking but no .exe file is made, a
$ !   message to that effect is returned in sys$login:link.res.
$ ! If there is a link warning during linking, an error message is returned
$ !   in sys$login:link.res, and the detailed link warning messages are
$ !   written to sys$login:link.err.
$ ! If there is an error in linking, such as no existing object file,
$ !   the abbreviated error message is returned, from the ERROR.COM file,
$ !   in sys$login:link.res, and the detailed error message is written
$ !   to sys$login:link.err.


$ !SET VERIFY
$ 	job = f$parse("''P1'",,,"name")
$	userDirectory = f$parse("''P1'",,,"directory")
$	length=f$length(job)
$ !	show symbol job
$ !	show symbol userDirectory
$ !	show symbol length
$	delete sys$login:link.err.*
$	delete sys$login:link.res.*
$ 	delete 'P1'.exe.*
$ 	define sys$error sys$login:link.err
$ !	define sys$error sys$login:'job'.err
$	on error then goto error
$ !
$ !  Note: link warnings can be very serious, such as the absence of object
$ !    code modules, in which case a useless .exe file is made.  Because
$ !    errors (as opposed to warnings) get trapped through the error routine,
$ !    these serious link warnings must be handled specially.
$ !
$ !	show symbol P2
$	if P2 .eqs. "" then goto simple
$ 	link/exe='userDirectory''job' 'P1','P2'
$	goto continue1
$ !
$ simple:
$ 	link/exe='userDirectory''job' 'P1'
$ !
$ continue1:
$	deassign sys$error
$ 	open/write resultFile sys$login:link.res
$ !
$ ! If we've gotten this far, it means no errors occurred.
$ !   First, check if link warnings occurred, by determining if a
$ !   LINK.ERR file was written.  If so, continue through linkerror1.
$ !
$ SET NOVERIFY
$	define sys$output sys$login:linkFile.tmp
$	dir/date/siz sys$login:link.err
$	deassign sys$output
$ !SET VERIFY
$	open/read file sys$login:linkFile.tmp
$ !
$ loop1:
$	read/end_of_file=continue2 file line
$	show sym line
$	name=f$extract(0,4,line)
$	show sym name
$	if name .eqs. "LINK" then goto linkerror1
$	goto loop1
$ !
$ continue2:
$	close file
$ !
$ ! Second, check if an executable file was made.  (Executable files are
$ !   made in spite of link warnings.  The following check flags a
$ !   situation where neither a link warning nor an executable file is made.)
$ !
$ SET NOVERIFY
$	define sys$output sys$login:exeFile.tmp
$	dir/date 'P1'.exe
$	deassign sys$output
$ !SET VERIFY
$	open/read file sys$login:exeFile.tmp
$ !
$ loop2:
$	read/end_of_file=linkerror2 file line
$	show sym line
$	name=f$extract(0,length,line)
$	show sym name
$	if name .eqs. job then goto found
$	goto loop2
$ !
$ linkerror1:
$	message="error during linking"
$	write resultFile "(ERROR ""''message'"" LINK.ERR)"  ! link warning
$	goto finish1
$ !
$ linkerror2:
$	message="executable file not made"
$	write resultFile "( OK (",message,"))"   ! exe file not made
$	goto finish2
$ !
$ found:
$	write resultFile "( OK (",line,"))"
$       goto finish2
$ !
$ finish1:
$	close resultFile
$	delete sys$login:linkFile.tmp.*
$ 	exit
$ !
$ finish2:
$	close resultFile
$	close file
$	delete sys$login:exeFile.tmp.*
$	delete sys$login:linkFile.tmp.*
$ 	exit
$ !
$  error:
$ 	@[gslws.server]error sys$login:link.res '$STATUS'
$	deassign sys$error
----------------------------------------------

RUNJOB.COM

$ !  runjob.com  8/11/86
$ ! this file is used to run an interactive job
$ !  job is the name of the user's com file
$ !  P2 is the list of appended parameters (optional)
$ ! If there is no error in running the job, an OK message is
$ !   written out to sys$login:runjob.res.
$ ! If there are warnings during the running of the job, an ERROR message
$ !   is returned in sys$login:runjob.res, and the detailed warning
$ !   messages are returned in sys$login:runjob.err
$ ! If there is an error in the running of the job, the abbreviated
$ !   error message is returned, from the ERROR.COM file, in
$ !   sys$login:runjob.res, and the detailed error message is written
$ !   to sys$login:runjob.err.

$ !SET VERIFY
$ 	job = f$parse("''P1'",,,"name")
$	delete sys$login:runJob.err.*
$	delete sys$login:runJob.res.*
$	define sys$error sys$login:runJob.err
$	on error then goto error

$ 	@'P1' 'P2'
$	deassign sys$error
$	open/write resultFile sys$login:runJob.res
$ !
$ !  If a warning occurs, it is written out to runJob.err
$ !    Such warnings are handled specially, through the
$ !    runwarning entry.
$ !
$ SET NOVERIFY
$	define sys$output sys$login:runFile.tmp
$	dir/date/siz sys$login:runJob.err
$	deassign sys$output
$ !SET VERIFY
$	open/read file sys$login:runFile.tmp
$ !
$ loop:
$	read/end_of_file=continue file line
$	show sym line
$	name=f$extract(0,6,line)
$	show sym name
$	if name .eqs. "RUNJOB" then goto runwarning
$	goto loop
$ !
$ continue:
$	write resultFile "( OK (",job,"   ",P1," ))"
$	goto finish
$ !
$ runwarning:
$	message="warning(s) occurred"
$	write resultFile "(ERROR ""''message'"" RUNJOB.ERR)"
$ !
$ finish:
$	close file
$	close resultFile
$	delete sys$login:runFile.tmp.*
$	exit
$ !
$  error:
$ 	@[gslws.server]error sys$login:runJob.res '$STATUS'
$	deassign sys$error
-------------------------------------------

STATUS.COM

$ ! get status of batch jobs
$ ! If jobNumber is specified, return only status of that job
$ ! If jobNumber is not specified, return all jobs
$ ! called by: @status jobNumber
$
$	delete status.res.*
$
$	define sys$output status.tmp
$	show system/batch
$	deassign sys$output
$ !SET VERIFY
$
$	open/read file status.tmp
$	open/write result status.res
$       write result "( OK ("
$       if P1 .eq. "" then goto writeall
$
$ loop:
$	read/end_of_file=done file line
$	job = f$integer(f$extract(15,4,line))
$	if job .eq. P1 then goto found
$	goto loop
$
$ done:
$	write result "NIL"	! no data for specified job
$	goto finish
$
$ found:
$	time = f$extract(49,11,line)
$	write result "( (JOB ''P1') (CPU ''time') )"
$	goto finish
$
$ writeall:
$	read/end_of_file=finish file line
$	jobType = f$extract(9,5,line)
$	if jobType .nes. "BATCH" then goto writeall
$	job = f$integer(f$extract(15,4,line))
$	time = f$extract(49,11,line)
$	write result "( (JOB ''job') (CPU ''time') )"
$       goto writeall
$
$ finish:
$	write result ") )"
$	close result
$	close file
$	delete status.tmp;
$	exit
----------------------------------------

SUBCOM.COM

$ !  subcom.com
$ ! this is the file actually submitted by submitjob.com
$ ! Parameter P1 is the name of the user's COM file to be run
$ ! Parameters P2,P3, etc are passed from P3,P4, etc. in SubmitJob.com
$ !  jobname is in the form BATCH_xxx
$ !  job is the number (xxx)
$ ! if there is an error in the running of the batch job, the detailed
$ !   error message gets sent to 'job'.err.
$ !   The abbreviated error message gets sent to 'job'.res

$ !  SET VERIFY
$	jobname = f$process()
$	job = f$extract(6,f$length(jobname)-6,jobname)
$ !	open/write outfile junk.
$ !	write outfile jobname,"  ",job
$ !	close outfile
$	define sys$error 'job'.err
$	on error then goto error

$ 	@'P1' 'P2' 'P3' 'P4' 'P5' 'P6'
$ 	exit
$  error:
$ 	@[gslws.server]error 'job'.res '$STATUS'
------------------------------------------

SUBMITJOB.COM

$ !   submitjob.com  8/11/86
$ ! submit a job on specified queue
$ ! call by: @submitjob file queue parameterString
$ !      P1 is the file name of the job to be submitted
$ !      P2 is the queue (eg., fast, medium)
$ !      P3, P4, P5, etc. are subsidiary parameters, such as file
$ !         names (eg., file1.dat, file2.sav).
$ ! these files are returned in the user's root directory:
$ !        P1.log  for log file
$ !        submitjob.res for result (job # or error message)
$ !        submitjob.err for detailed errors (from sys$error)
$ !        submitjob.tmp for temporary output
$ ! these files are returned in the user's running (sub)directory:
$ !        'jobnumber'.res for error message to be returned
$ !	   'jobnumber'.err for detailed error message

$ !SET VERIFY
$	job=f$parse("''P1'",,,"name")
$	delete sys$login:'job'.log.*
$	delete sys$login:submitjob.err.*
$	delete sys$login:submitjob.res.*
$	delete sys$login:submitjob.tmp.*
$	errorFile = "submitjob.err"
$	tempFile = "submitjob.tmp"
$	resultFile = "submitjob.res"
$	define sys$error 'errorFile'
$	on error then goto error

$ ! submit the batch job
$ SET NOVERIFY
$       if P3.eqs."" then goto zeropar
$       if P4.eqs."" then goto onepar
$       if P5.eqs."" then goto twopar
$       if P6.eqs."" then goto threepar
$       if P7.eqs."" then goto fourpar
$       if P8.eqs."" then goto fivepar
$       goto abort

$ zeropar:
$	define sys$output 'tempFile'
$ 	submit/noprint/name='job'/parameters=('P1')-
            /queue='P2' [gslws.server]subcom.com
$	deassign sys$output
$       goto finish

$ onepar:
$	define sys$output 'tempFile'
$	submit/noprint/name='job'/parameters=('P1','P3')-
            /queue='P2' [gslws.server]subcom.com
$	deassign sys$output
$       goto finish

$ twopar:
$	define sys$output 'tempFile'
$	submit/noprint/name='job'/parameters=('P1','P3','P4')-
            /queue='P2' [gslws.server]subcom.com
$	deassign sys$output
$       goto finish

$ threepar:
$	define sys$output 'tempFile'
$	submit/noprint/name='job'/parameters=('P1','P3','P4','P5')-
            /queue='P2' [gslws.server]subcom.com
$	deassign sys$output
$       goto finish

$ fourpar:
$	define sys$output 'tempFile'
$	submit/name='job'/parameters=('P1','P3','P4','P5','P6')-
            /noprint/queue='P2' [gslws.server]subcom.com
$	deassign sys$output
$       goto finish

$ fivepar:
$	define sys$output 'tempFile'
$	submit/name='job'/parameters=('P1','P3','P4','P5','P6','P7')-
            /noprint/queue='P2' [gslws.server]subcom.com
$	deassign sys$output

$ finish:
$ !SET VERIFY
$ ! get job number of submitted job from string in submit.tmp
$	open/read infile 'tempFile'
$	read infile line
$ ! line now equals " Job xxxx entered on queue ----"
$	startPosition = f$locate("entry",line)+5
$	endPosition = f$locate(")",line)
$	numDigits = endPosition - startPosition
$	jobNumber = f$extract(startPosition,numDigits,line)
$	close infile
$ ! 	delete 'tempFile';*
$	open/write outfile 'resultFile'
$	write outfile "( OK (",jobNumber, "   ", P1," ))"
$	close outfile

$ ! no (ERROR ...) message, so deassign the error file
$	deassign	sys$error
$	exit


$ abort:
$       open/write outfile 'errorFile'
$       write outfile "Too many job parameters (more than five)"
$       close outfile
$       deassign sys$error
$       exit

$ ! get error message
$ error:
$	@user1:[gslws.server]error 'resultFile' '$STATUS'
$	deassign	sys$output
$	deassign	sys$error
$ ! 	delete 'tempFile';*
$	exit
-----------------------+@(GACHA
˜67B);B9G=9#1!!*),0/-(&*?	&
-
-8
-1+%"."?	BCADCE*?>:@@LH%FJG#1')LIN>"+
-&
,;BF+"(	',


ICN*'	( $
!E%?	&"
!"
-5/0,6>+JD4D=F#  (-:8*$'&./ 7
-
!
-7,>3!)"(!1	/$ .(0
-
)9>G&G,;1#"
-,+$38-B/; =>.C<2 ###'&&(''01
-41
-91>1;9@9
->6+#*6"47	'A
	4:Œ®zº
\ No newline at end of file
diff --git a/obsolete/lispusers/MATHSERVER.LCOM b/obsolete/lispusers/MATHSERVER.LCOM
deleted file mode 100644
index 8ff5177b..00000000
Binary files a/obsolete/lispusers/MATHSERVER.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/MATHSERVERPLOT.LCOM b/obsolete/lispusers/MATHSERVERPLOT.LCOM
deleted file mode 100644
index 0e01602d..00000000
Binary files a/obsolete/lispusers/MATHSERVERPLOT.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/MATHTONS b/obsolete/lispusers/MATHTONS
deleted file mode 100644
index ea832a0b..00000000
--- a/obsolete/lispusers/MATHTONS
+++ /dev/null
@@ -1,28 +0,0 @@
-(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
-(FILECREATED "13-Feb-87 11:01:14" {ERIS}<LISPUSERS>LYRIC>MATHTONS.;1 1284   
-
-      previous date%: "12-Dec-86 14:37:39" {PHYLUM}<LISPUSERS>KOTO>MATHTONS.;2)
-
-
-(* "
-Copyright (c) 1986, 1987 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT MATHTONSCOMS)
-
-(RPAQQ MATHTONSCOMS ((UGLYVARS \MATHTONSARRAY)
-                     (ADDVARS (ASCIITONSTRANSLATIONS (MATH \MATHTONSARRAY CLASSIC)))))
-(READVARS \MATHTONSARRAY)
-({Y256 SMALLPOSP 0 0 61307 61234 61235 0 163 61301 61302 0 0 0 182 0 0 0 61286 0 0 0 61306 0 0 61295 
-{R9 0} 32 61232 61287 8551 162 184 61366 61299 194 61308 199 177 61260 61309 8552 61285 61287 8738 
-8740 8574 61282 61283 61284 61292 8570 199 167 0 8549 8546 8550 2 61248 61365 61258 61356 61369 61364 
-61233 61275 61279 61273 61274 61278 61272 61629 61259 61281 61297 61265 61358 61305 61296 61271 61367 
-61298 180 61626 61368 0 0 0 175 174 0 61351 61267 211 61370 61303 61266 61263 61288 61360 61361 61362 
-61363 61256 61290 61287 61238 61240 210 61246 61244 61247 61245 61250 61251 61270 61239 188 189 190 
-61264 {R129 0} })
-
-(ADDTOVAR ASCIITONSTRANSLATIONS (MATH \MATHTONSARRAY CLASSIC))
-(PUTPROPS MATHTONS COPYRIGHT ("Xerox Corporation" 1986 1987))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
diff --git a/obsolete/lispusers/MATHTONS.TEDIT b/obsolete/lispusers/MATHTONS.TEDIT
deleted file mode 100644
index 69ddefb6..00000000
Binary files a/obsolete/lispusers/MATHTONS.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/MATRIXOPS b/obsolete/lispusers/MATRIXOPS
deleted file mode 100644
index 96ae7255..00000000
--- a/obsolete/lispusers/MATRIXOPS
+++ /dev/null
@@ -1,1005 +0,0 @@
-(FILECREATED " 4-Jun-86 18:27:59" {QV}<PEDERSEN>LISP>MATRIXOPS.;12 48308  
-
-      changes to:  (VARS MATRIXOPSCOMS)
-		   (FNS QRSOLV MTIMES TRANSPOSE MTRANSPOSE MINVERT MSOLVE MOLS MREGRESS)
-
-      previous date: "29-May-86 12:39:55" {QV}<PEDERSEN>LISP>MATRIXOPS.;10)
-
-
-(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT MATRIXOPSCOMS)
-
-(RPAQQ MATRIXOPSCOMS ((FNS CHOLESKYFACTOR MTRANSPOSE MINVERT LSOLV LUFACTOR LUINVERSE LUSOLV MTIMES 
-			     QRFACTOR QROLS QRQTY QRQY QRSOLV MREGRESS RSOLV MSOLVE SVDFACTOR SVDTEST 
-			     \FLOATAREFMACRO \FLOATASETMACRO)
-	(VARS STACK)
-	(MACROS \FLOATAREF \FLOATASET)
-	(FILES BLAS)))
-(DEFINEQ
-
-(CHOLESKYFACTOR
-  [LAMBDA (MATRIX FACTORMATRIX)                              (* jop: "28-May-86 12:38")
-          
-          (* * Lifted from LINPACK algorithm SCHDC)
-
-    (BLAS.CHECKARRAY MATRIX)
-    (LET ((P (ARRAY-DIMENSION MATRIX 0)))
-          
-          (* * Arg Checks)
-
-         (if [NOT (AND (EQL 2 (ARRAY-RANK MATRIX))
-                       (EQL P (ARRAY-DIMENSION MATRIX 1]
-             then (HELP "Matrix not sqaure" MATRIX))
-         (if (NULL FACTORMATRIX)
-             then (SETQ FACTORMATRIX (MAKE-ARRAY (ARRAY-DIMENSIONS MATRIX)
-                                            (QUOTE :ELEMENT-TYPE)
-                                            (QUOTE FLOAT)))
-           else (BLAS.CHECKARRAY FACTORMATRIX)
-                (if (NOT (EQUAL (ARRAY-DIMENSIONS FACTORMATRIX)
-                                (ARRAY-DIMENSIONS MATRIX)))
-                    then (HELP "Illegal FACTORMATRIX" FACTORMATRIX)))
-                                                             (* Copy MATRIX to FACTORMATRIX)
-         (BLAS.ARRAYBLT MATRIX 0 1 FACTORMATRIX 0 1)
-          
-          (* * Compute the cholesky decomposition of FACTORMATRIX)
-
-         [bind (WORK _ (MAKE-ARRAY P (QUOTE :ELEMENT-TYPE)
-                              (QUOTE FLOAT)))
-               TEMP for K from 0 to (SUB1 P)
-            do (if (LEQ (\FLOATAREF FACTORMATRIX K K)
-                        0.0)
-                   then (HELP "Zero pivot element"))
-               (\FLOATASET (SQRT (\FLOATAREF FACTORMATRIX K K))
-                      WORK K)
-               (\FLOATASET (\FLOATAREF WORK K)
-                      FACTORMATRIX K K)
-               (if (NOT (EQL K (SUB1 P)))
-                   then (for J from (ADD1 K) to (SUB1 P)
-                           do (\FLOATASET (FQUOTIENT (\FLOATAREF FACTORMATRIX K J)
-                                                 (\FLOATAREF WORK K))
-                                     FACTORMATRIX K J)
-                              (\FLOATASET (\FLOATAREF FACTORMATRIX K J)
-                                     WORK J)
-                              (SETQ TEMP (FMINUS (\FLOATAREF FACTORMATRIX K J)))
-                              (BLAS.AXPY TEMP WORK (ADD1 K)
-                                     1 FACTORMATRIX (IPLUS J (ITIMES P (ADD1 K)))
-                                     P
-                                     (IDIFFERENCE J K]
-     FACTORMATRIX])
-
-(MTRANSPOSE
-  [LAMBDA (SOURCEMATRIX DESTMATRIX)                          (* jop: " 4-Jun-86 14:07")
-
-          (* * Transpose the M x N matrix SOURCEMATRIX. DESTMATRIX should be N x M. Returns DESTMATRIX)
-
-
-    (BLAS.CHECKARRAY SOURCEMATRIX)
-    (PROG ((M (ARRAY-DIMENSION SOURCEMATRIX 0))
-	     (N (ARRAY-DIMENSION SOURCEMATRIX 1)))
-	    (if (NULL DESTMATRIX)
-		then (SETQ DESTMATRIX (MAKE-ARRAY (LIST N M)
-							(QUOTE :ELEMENT-TYPE)
-							(QUOTE FLOAT)))
-	      else (BLAS.CHECKARRAY DESTMATRIX)
-		     (if (NOT (EQUAL (ARRAY-DIMENSIONS DESTMATRIX)
-					   (LIST N M)))
-			 then (HELP "DESTMATRIX of incorrect size" DESTMATRIX)))
-	    (if (ILESSP M N)
-		then (bind (SOURCEBASE _(ARRAYBASE SOURCEMATRIX))
-			       (DESTBASE _(ARRAYBASE DESTMATRIX)) for I from 0
-			  to (SUB1 M) do (\FLOATARRAYBLT SOURCEBASE (ITIMES N I)
-								 1 DESTBASE I M N))
-	      else (bind (SOURCEBASE _(ARRAYBASE SOURCEMATRIX))
-			     (DESTBASE _(ARRAYBASE DESTMATRIX)) for J from 0
-			to (SUB1 N) do (\FLOATARRAYBLT SOURCEBASE J N DESTBASE
-							       (ITIMES J M)
-							       1 M)))
-	    (RETURN DESTMATRIX])
-
-(MINVERT
-  [LAMBDA (MATRIX SOLUTION)                                  (* jop: "26-May-86 18:35")
-
-          (* * Solves to system A x = b. BVECTOR should to the RHS of the system. Returns SOLUTION)
-
-
-    (LET [(PIVOTVECTOR (MAKE-ARRAY (ARRAY-DIMENSION MATRIX 0]
-         (LUINVERSE (LUFACTOR MATRIX PIVOTVECTOR)
-		      PIVOTVECTOR SOLUTION])
-
-(LSOLV
-  [LAMBDA (LMATRIX CVECTOR BVECTOR)                          (* jop: "27-May-86 16:25")
-          
-          (* * Calcluate the solution vector BVECTOR for the system of linear equations 
-          R*B=C, where LMATRIX is lower triangular M X N with non-zero diagonal elements.
-          BVECTOR and CVECTOR must be of size N. Always returns BVECTOR)
-
-    (BLAS.CHECKARRAY LMATRIX)
-    (BLAS.CHECKARRAY CVECTOR)
-    (PROG ((M (ARRAY-DIMENSION LMATRIX 0))
-           (N (ARRAY-DIMENSION LMATRIX 1)))
-          
-          (* * Arg Checks)
-
-          (if (ILESSP M N)
-              then (HELP "Order of system less than" N))
-          (if (NOT (EQL (ARRAY-TOTAL-SIZE CVECTOR)
-                        N))
-              then (HELP "CVECTOR not of size" N))
-          (if (NULL BVECTOR)
-              then (SETQ BVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE)
-                                        (QUOTE FLOAT)))
-            else (BLAS.CHECKARRAY BVECTOR)
-                 (if (NOT (EQL (ARRAY-TOTAL-SIZE BVECTOR)
-                               N))
-                     then (HELP "BVECTOR not of size" N)))   (* Check for zero diagonal elements)
-          (if (for I from 0 to (SUB1 N) thereis (UFEQP 0.0 (\FLOATAREF LMATRIX I I)))
-              then (HELP "LMATRIX has a zero diagonal element"))
-          
-          (* * Solution by forward substitution)
-                                                             (* Copy CVECTOR to BVECTOR)
-          (BLAS.ARRAYBLT CVECTOR 0 1 BVECTOR 0 1 N)          (* Compute the first value)
-          (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR 0)
-                             (\FLOATAREF LMATRIX 0 0))
-                 BVECTOR 0)
-          (for J from 1 to (SUB1 N) do (BLAS.AXPY (FMINUS (\FLOATAREF BVECTOR (SUB1 J)))
-                                              LMATRIX
-                                              (IPLUS (SUB1 J)
-                                                     (ITIMES J N))
-                                              N BVECTOR J 1 (IDIFFERENCE N J))
-                                       (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR J)
-                                                          (\FLOATAREF LMATRIX J J))
-                                              BVECTOR J))
-          (RETURN BVECTOR])
-
-(LUFACTOR
-  [LAMBDA (MATRIX PIVOTVECTOR FACTORMATRIX)                  (* jop: "27-May-86 20:21")
-          
-          (* * Computes the LU decomposition of the N x N matrix MATRIX by Gauss 
-          elimination with row pivoting. FACTORMATRIX will be overwritten with the packed 
-          result. PIVOTVECTOR will be a vector of smallposp's, holding the pivot 
-          permutation, and must be supplied. Returns NIL in the normal case, else returns 
-          the row index)
-          
-          (* * Lifted from LINPACK algorithm SGESL)
-
-    (BLAS.CHECKARRAY MATRIX)
-    (if (NOT (AND (type? ARRAY PIVOTVECTOR)
-                  (EQ (ARRAY-ELEMENT-TYPE PIVOTVECTOR)
-                      T)))
-        then (HELP "Must be a pointer array" PIVOTVECTOR))
-    (LET ((N (ARRAY-DIMENSION MATRIX 0)))
-          
-          (* * Arg Checks)
-
-         (if [AND (EQL 2 (ARRAY-RANK MATRIX))
-                  (NOT (EQL N (ARRAY-DIMENSION MATRIX 1]
-             then (HELP "MATRIX not square" MATRIX))
-         (if [NOT (AND (EQL 1 (ARRAY-RANK PIVOTVECTOR))
-                       (EQL N (ARRAY-TOTAL-SIZE PIVOTVECTOR]
-             then (HELP "PIVOTVECTOR not of size N" PIVOTVECTOR))
-         (if (NULL FACTORMATRIX)
-             then (SETQ FACTORMATRIX (MAKE-ARRAY (LIST N N)
-                                            (QUOTE :ELEMENT-TYPE)
-                                            (QUOTE FLOAT)))
-           else (BLAS.CHECKARRAY FACTORMATRIX)
-                (if (NOT (EQUAL (ARRAY-DIMENSIONS FACTORMATRIX)
-                                (ARRAY-DIMENSIONS MATRIX)))
-                    then (HELP "Illegal FACTORMATRIX" FACTORMATRIX)))
-                                                             (* Copy MATRIX to FACTORMATRIX)
-         (BLAS.ARRAYBLT MATRIX 0 1 FACTORMATRIX 0 1)
-          
-          (* * Compute the LU decomposition of FACTORMATRIX)
-
-         [bind PIVOTINDEX TEMP for K from 0 to (IDIFFERENCE N 2)
-            do                                               (* find pivot index)
-               (SETQ PIVOTINDEX (IPLUS (BLAS.MAX FACTORMATRIX (IPLUS K (ITIMES N K))
-                                              N
-                                              (IDIFFERENCE N K))
-                                       K))
-               (PASET PIVOTINDEX PIVOTVECTOR K)
-               (if (NOT (FEQP (\FLOATAREF FACTORMATRIX PIVOTINDEX K)
-                              0.0))
-                   then (if (NOT (EQL PIVOTINDEX K))
-                            then                             (* Interchange)
-                                 (SETQ TEMP (\FLOATAREF FACTORMATRIX PIVOTINDEX K))
-                                 (\FLOATASET (\FLOATAREF FACTORMATRIX K K)
-                                        FACTORMATRIX PIVOTINDEX K)
-                                 (\FLOATASET TEMP FACTORMATRIX K K)) 
-                                                             (* compute Multpliers)
-                        (BLAS.SCAL (FMINUS (FQUOTIENT 1.0 (\FLOATAREF FACTORMATRIX K K)))
-                               FACTORMATRIX
-                               (IPLUS K (ITIMES N (ADD1 K)))
-                               N
-                               (SUB1 (IDIFFERENCE N K)))     (* Row eliminate with column indexing)
-                        (bind (KPLUS1 _ (ADD1 K)) for J from (ADD1 K) to (SUB1 N)
-                           do (SETQ TEMP (\FLOATAREF FACTORMATRIX PIVOTINDEX J))
-                              (if (NOT (EQL PIVOTINDEX K))
-                                  then                       (* Interchange)
-                                       (\FLOATASET (\FLOATAREF FACTORMATRIX K J)
-                                              FACTORMATRIX PIVOTINDEX J)
-                                       (\FLOATASET TEMP FACTORMATRIX K J))
-                              (BLAS.AXPY TEMP FACTORMATRIX (IPLUS K (ITIMES N KPLUS1))
-                                     N FACTORMATRIX (IPLUS J (ITIMES N KPLUS1))
-                                     N
-                                     (IDIFFERENCE N KPLUS1]  (* No row elimination on last column)
-         (PASET (SUB1 N)
-                PIVOTVECTOR
-                (SUB1 N))
-     FACTORMATRIX])
-
-(LUINVERSE
-  [LAMBDA (LUMATRIX PIVOTVECTOR SOLUTION)                    (* jop: "26-May-86 18:17")
-          
-          (* * Forms MATRIX inverse where LUMATRIX and PIVOTVECTOR are the outputs of 
-          LUFACTOR.)
-          
-          (* * lifted from LINPACK SGEDI)
-
-    (BLAS.CHECKARRAY LUMATRIX)
-    (if (NOT (AND (type? ARRAY PIVOTVECTOR)
-                  (EQ (ARRAY-ELEMENT-TYPE PIVOTVECTOR)
-                      T)))
-        then (HELP "Must be an array of pointers" PIVOTVECTOR))
-    (PROG ((N (ARRAY-DIMENSION LUMATRIX 0)))
-          
-          (* * Arg Checks)
-
-          (if [AND (EQL 2 (ARRAY-RANK LUMATRIX))
-                   (NOT (EQL N (ARRAY-DIMENSION LUMATRIX 1]
-              then (HELP "MATRIX not square" LUMATRIX))
-          (if [NOT (AND (EQL 1 (ARRAY-RANK PIVOTVECTOR))
-                        (EQL N (ARRAY-TOTAL-SIZE PIVOTVECTOR]
-              then (HELP "PIVOTVECTOR  not a vector of size N" PIVOTVECTOR))
-          (if (NULL SOLUTION)
-              then (SETQ SOLUTION (MAKE-ARRAY (LIST N N)
-                                         (QUOTE :ELEMENT-TYPE)
-                                         (QUOTE FLOAT)))
-            else (BLAS.CHECKARRAY SOLUTION)
-                 (if [NOT (AND (EQL 2 (ARRAY-RANK SOLUTION))
-                               (EQUAL (ARRAY-DIMENSIONS LUMATRIX)
-                                      (ARRAY-DIMENSIONS SOLUTION]
-                     then (HELP "SOLUTION not an N x N array" SOLUTION)))
-                                                             (* copy LUMATRIX to SOLUTION)
-          (BLAS.ARRAYBLT LUMATRIX 0 1 SOLUTION 0 1)
-          
-          (* * first compute INVERSE (U))
-
-          [bind TEMP for K from 0 to (SUB1 N)
-             do (\FLOATASET (FQUOTIENT 1.0 (\FLOATAREF SOLUTION K K))
-                       SOLUTION K K)
-                (SETQ TEMP (FMINUS (\FLOATAREF SOLUTION K K)))
-                (BLAS.SCAL TEMP SOLUTION K N K)
-                (bind TEMP for J from (ADD1 K) to (SUB1 N)
-                   do (SETQ TEMP (\FLOATAREF SOLUTION K J))
-                      (\FLOATASET 0.0 SOLUTION K J)
-                      (BLAS.AXPY TEMP SOLUTION K N SOLUTION J N (ADD1 K]
-          
-          (* * Form INVERSE (U) *INVERSE (L))
-
-          (bind (TEMPARRAY _ (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE)
-                                    (QUOTE FLOAT)))
-                L for K from (IDIFFERENCE N 2) to 0 by -1
-             do (for I from (ADD1 K) to (SUB1 N) do (\FLOATASET (\FLOATAREF SOLUTION I K)
-                                                           TEMPARRAY I)
-                                                    (\FLOATASET 0.0 SOLUTION I K))
-                (bind TEMP for J from (ADD1 K) to (SUB1 N)
-                   do (SETQ TEMP (\FLOATAREF TEMPARRAY J))
-                      (BLAS.AXPY TEMP SOLUTION J N SOLUTION K N N))
-                (SETQ L (PAREF PIVOTVECTOR K))
-                (if (NEQ L K)
-                    then (BLAS.SWAP SOLUTION K N SOLUTION L N N)))
-          (RETURN SOLUTION])
-
-(LUSOLV
-  [LAMBDA (LUMATRIX PIVOTVECTOR CVECTOR SOLUTION)            (* jop: "27-May-86 20:39")
-          
-          (* * Solves to system A x = b. LUMATRIX and PIVOTVECTOR should be the outputs 
-          of LUFACTOR. CVECTOR should to the RHS of the system.
-          Returns SOLUTION)
-          
-          (* * lifted from LINPACK SGESL)
-
-    (BLAS.CHECKARRAY LUMATRIX)
-    (if (NOT (AND (type? ARRAY PIVOTVECTOR)
-                  (EQ (ARRAY-ELEMENT-TYPE PIVOTVECTOR)
-                      T)))
-        then (HELP "Must be an array of pointers" PIVOTVECTOR))
-    (BLAS.CHECKARRAY CVECTOR)
-    (PROG ((N (ARRAY-DIMENSION LUMATRIX 0)))
-          
-          (* * Arg Checks)
-
-          (if [AND (EQL 2 (ARRAY-RANK LUMATRIX))
-                   (NOT (EQL N (ARRAY-DIMENSION LUMATRIX 1]
-              then (HELP "MATRIX not square" LUMATRIX))
-          (if [NOT (AND (EQL 1 (ARRAY-RANK PIVOTVECTOR))
-                        (EQL N (ARRAY-TOTAL-SIZE PIVOTVECTOR]
-              then (HELP "PIVOTVECTOR  not a vector of size N" PIVOTVECTOR))
-          (if [NOT (AND (EQL 1 (ARRAY-RANK CVECTOR))
-                        (EQL N (ARRAY-TOTAL-SIZE CVECTOR]
-              then (HELP "CVECTOR not a vector of size N" CVECTOR))
-          (if (NULL SOLUTION)
-              then (SETQ SOLUTION (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE)
-                                         (QUOTE FLOAT)))
-            else (BLAS.CHECKARRAY SOLUTION)
-                 (if [NOT (AND (EQL 1 (ARRAY-RANK SOLUTION))
-                               (EQL N (ARRAY-TOTAL-SIZE SOLUTION]
-                     then (HELP "SOLUTION not avector of size N" SOLUTION)))
-                                                             (* Copy CVECTOR to SOLUTION)
-          (BLAS.ARRAYBLT CVECTOR 0 1 SOLUTION 0 1 N)
-          
-          (* * First solve L*y = b)
-
-          [bind PIVOTINDEX TEMP for K from 0 to (IDIFFERENCE N 2)
-             do (SETQ PIVOTINDEX (PAREF PIVOTVECTOR K))
-                (SETQ TEMP (\FLOATAREF SOLUTION PIVOTINDEX))
-                (if (NOT (EQL PIVOTINDEX K))
-                    then                                     (* interchange)
-                         (\FLOATASET (\FLOATAREF SOLUTION K)
-                                SOLUTION PIVOTINDEX)
-                         (\FLOATASET TEMP SOLUTION K))
-                (BLAS.AXPY TEMP LUMATRIX (IPLUS K (ITIMES N (ADD1 K)))
-                       N SOLUTION (ADD1 K)
-                       1
-                       (IDIFFERENCE N (ADD1 K]
-          
-          (* * Then solve U*x = y)
-
-          (bind TEMP for K from (SUB1 N) to 0 by -1
-             do (SETQ TEMP (FMINUS (\FLOATASET (FQUOTIENT (\FLOATAREF SOLUTION K)
-                                                      (\FLOATAREF LUMATRIX K K))
-                                          SOLUTION K)))
-                (BLAS.AXPY TEMP LUMATRIX K N SOLUTION 0 1 K))
-          (RETURN SOLUTION])
-
-(MTIMES
-  [LAMBDA (A B PRODUCT)                                      (* jop: " 4-Jun-86 13:08")
-
-          (* * Matrix multiply. A may be an N vector or a (M x N) matrix and B may be a N vector or a N x P matrix.
-	  PRODUCT defualts to a M x P array. RETURNS PRODUCT)
-
-
-    (BLAS.CHECKARRAY A)
-    (BLAS.CHECKARRAY B)
-    (LET ((RANKA (ARRAY-RANK A))
-	  (RANKB (ARRAY-RANK B))
-	  M N P RESULTDIMS)
-         (if (NOT (OR (EQ RANKA 1)
-			    (EQ RANKA 2)))
-	     then (HELP "A not a one-d or two-d array" A))
-         (if (NOT (OR (EQ RANKB 1)
-			    (EQ RANKB 2)))
-	     then (HELP "B not a one-d or two-d array" B))
-         (SETQ M (if (EQ RANKA 1)
-		       then 1
-		     else (ARRAY-DIMENSION A 0)))
-         (SETQ N (if (EQ RANKA 1)
-		       then (ARRAY-DIMENSION A 0)
-		     else (ARRAY-DIMENSION A 1)))
-         (SETQ P (if (EQ RANKB 1)
-		       then 1
-		     else (ARRAY-DIMENSION B 1)))
-         [SETQ RESULTDIMS (if (EQ M 1)
-				then (if (EQ P 1)
-					   then NIL
-					 else (LIST P))
-			      else (if (EQ P 1)
-					 then (LIST M)
-				       else (LIST M P]
-
-          (* * Check args)
-
-
-         (if (NOT (EQ (ARRAY-DIMENSION B 0)
-			    N))
-	     then (HELP "Leading dimension of B not N" B))
-         (if (NULL PRODUCT)
-	     then (SETQ PRODUCT (MAKE-ARRAY RESULTDIMS (QUOTE :ELEMENT-TYPE)
-						  (QUOTE FLOAT)))
-	   elseif (NOT (EQUAL (ARRAY-DIMENSIONS PRODUCT)
-				    RESULTDIMS))
-	     then (HELP "C of incorrect size" PRODUCT))
-
-          (* * Do the multiply)
-
-
-         [bind (ABASE _(ARRAYBASE A))
-		 (BBASE _(ARRAYBASE B))
-		 (CBASE _(ARRAYBASE PRODUCT)) for I from 0 to (SUB1 M)
-	    do (for J from 0 to (SUB1 P) as COFFSET from (MUL2 (ITIMES P I))
-		    by 2 do (bind (FTEMP _ 0.0) declare (TYPE FLOATP FTEMP) for K
-				   from 0 to (SUB1 N) as AOFFSET
-				   from (MUL2 (ITIMES N I)) by 2 as BOFFSET
-				   from (MUL2 J) by (MUL2 P)
-				   do [SETQ FTEMP (FPLUS FTEMP (FTIMES (\GETBASEFLOATP
-										 ABASE AOFFSET)
-									       (\GETBASEFLOATP
-										 BBASE BOFFSET]
-				   finally (\PUTBASEFLOATP CBASE COFFSET FTEMP]
-     PRODUCT])
-
-(QRFACTOR
-  [LAMBDA (MATRIX QRAUX FACTORMATRIX)                        (* jop: "27-May-86 16:27")
-          
-          (* * Computes the LU decomposition of the N x N matrix MATRIX by Gauss 
-          elimination with row pivoting. FACTORMATRIX will be overwritten with the packed 
-          result. QRAUX will be a vector of smallposp's, holding the pivot permutation, 
-          and must be supplied. Returns NIL in the normal case, else returns the row 
-          index)
-          
-          (* * Lifted from LINPACK algorithm SGESL)
-
-    (BLAS.CHECKARRAY MATRIX)
-    (BLAS.CHECKARRAY QRAUX)
-    (LET ((N (ARRAY-DIMENSION MATRIX 0))
-          (P (ARRAY-DIMENSION MATRIX 1)))
-          
-          (* * Arg Checks)
-
-         (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX))
-                       (EQL P (ARRAY-TOTAL-SIZE QRAUX]
-             then (HELP "QRAUX not of size P" QRAUX))
-         (if (NULL FACTORMATRIX)
-             then (SETQ FACTORMATRIX (MAKE-ARRAY (ARRAY-DIMENSIONS MATRIX)
-                                            (QUOTE :ELEMENT-TYPE)
-                                            (QUOTE FLOAT)))
-           else (BLAS.CHECKARRAY FACTORMATRIX)
-                (if (NOT (EQUAL (ARRAY-DIMENSIONS FACTORMATRIX)
-                                (ARRAY-DIMENSIONS MATRIX)))
-                    then (HELP "Illegal FACTORMATRIX" FACTORMATRIX)))
-                                                             (* Copy MATRIX to FACTORMATRIX)
-         (BLAS.ARRAYBLT MATRIX 0 1 FACTORMATRIX 0 1)
-          
-          (* * Compute the QR decomposition of FACTORMATRIX)
-
-         (for I from 0 to (SUB1 P) do (\FLOATASET 0.0 QRAUX I))
-         (bind NRMXL for L from 0 to (SUB1 (IMIN N P)) unless (EQL L (SUB1 N))
-            do                                               (* Compute the Householder 
-                                                             transformation for column L)
-               (SETQ NRMXL (BLAS.NRM2 FACTORMATRIX (IPLUS L (ITIMES P L))
-                                  P
-                                  (IDIFFERENCE N L)))
-               (if (FGREATERP NRMXL 0.0)
-                   then (if (FLESSP (\FLOATAREF FACTORMATRIX L L)
-                                   0.0)
-                            then (SETQ NRMXL (FMINUS NRMXL)))
-                        (BLAS.SCAL (FQUOTIENT 1.0 NRMXL)
-                               FACTORMATRIX
-                               (IPLUS L (ITIMES P L))
-                               P
-                               (IDIFFERENCE N L))
-                        (\FLOATASET (FPLUS 1.0 (\FLOATAREF FACTORMATRIX L L))
-                               FACTORMATRIX L L)             (* apply the transform to the 
-                                                             remaining columns)
-                        (bind TEMP for J from (ADD1 L) to (SUB1 P)
-                           do [SETQ TEMP (FMINUS (FQUOTIENT (BLAS.DOTPROD FACTORMATRIX
-                                                                   (IPLUS L (ITIMES P L))
-                                                                   P FACTORMATRIX
-                                                                   (IPLUS J (ITIMES P L))
-                                                                   P
-                                                                   (IDIFFERENCE N L))
-                                                        (\FLOATAREF FACTORMATRIX L L]
-                              (BLAS.AXPY TEMP FACTORMATRIX (IPLUS L (ITIMES P L))
-                                     P FACTORMATRIX (IPLUS J (ITIMES P L))
-                                     P
-                                     (IDIFFERENCE N L)))
-                        (\FLOATASET (\FLOATAREF FACTORMATRIX L L)
-                               QRAUX L)
-                        (\FLOATASET (FMINUS NRMXL)
-                               FACTORMATRIX L L)))
-     FACTORMATRIX])
-
-(QROLS
-  [LAMBDA (QRMATRIX QRAUX Y QTY B RSD YHAT)                  (* jop: "27-May-86 17:21")
-          
-          (* * Lifted from LINPACK algorithm SQRSL)
-
-    (BLAS.CHECKARRAY QRMATRIX)
-    (BLAS.CHECKARRAY QRAUX)
-    (BLAS.CHECKARRAY Y)
-    (LET ((N (ARRAY-DIMENSION QRMATRIX 0))
-          (P (ARRAY-DIMENSION QRMATRIX 1)))
-          
-          (* * Arg Checks)
-
-         (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX))
-                       (EQL P (ARRAY-TOTAL-SIZE QRAUX]
-             then (HELP "QRAUX not of size P" QRAUX))
-         (if [NOT (AND (EQL 1 (ARRAY-RANK Y))
-                       (EQL N (ARRAY-TOTAL-SIZE Y]
-             then (HELP "Y not of size N" Y))
-         (if (NULL QTY)
-             then (SETQ QTY (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE)
-                                   (QUOTE FLOAT)))
-           else (BLAS.CHECKARRAY QTY)
-                (if (NOT (EQL N (ARRAY-TOTAL-SIZE QTY)))
-                    then (HELP "QTY not of size N" QTY)))
-         (if (NULL B)
-             then (SETQ B (MAKE-ARRAY P (QUOTE :ELEMENT-TYPE)
-                                 (QUOTE FLOAT)))
-           else (BLAS.CHECKARRAY B)
-                (if (NOT (EQL P (ARRAY-TOTAL-SIZE B)))
-                    then (HELP "B not of size P" B)))
-         (if RSD
-             then (BLAS.CHECKARRAY RSD)
-                  (if (NOT (EQL N (ARRAY-TOTAL-SIZE RSD)))
-                      then (HELP "RSD not of size N" RSD)))
-         (if YHAT
-             then (BLAS.CHECKARRAY YHAT)
-                  (if (NOT (EQL N (ARRAY-TOTAL-SIZE YHAT)))
-                      then (HELP "XB not of size N" YHAT)))  (* Compute TRANS (Q) * Y)
-         (QRQTY QRMATRIX QRAUX Y QTY)
-          
-          (* * Compute B)
-                                                             (* Set up computation of B)
-         (BLAS.ARRAYBLT QTY 0 1 B 0 1 P)
-         (for J from (SUB1 P) to 0 by -1
-            do (if (UFEQP (\FLOATAREF QRMATRIX J J)
-                          0.0)
-                   then (HELP "Singular Matrix" QRMATRIX))
-               (\FLOATASET (FQUOTIENT (\FLOATAREF B J)
-                                  (\FLOATAREF QRMATRIX J J))
-                      B J)
-               (if (NOT (EQL J 0))
-                   then (BLAS.AXPY (FMINUS (\FLOATAREF B J))
-                               QRMATRIX J P B 0 1 J)))
-          
-          (* * Compute RSD)
-
-         [if RSD
-             then                                            (* Set up computation of RSD)
-             (if (ILESSP P N)
-                 then (BLAS.ARRAYBLT QTY P 1 RSD P 1))
-             (BLAS.ARRAYFILL 0.0 RSD 0 1 P)
-             (bind TEMP for J from (SUB1 (IMIN P (SUB1 N))) to 0 by -1
-                do (if (NOT (UFEQP (\FLOATAREF QRAUX J)
-                                   0.0))
-                       then (SETQ TEMP (\FLOATAREF QRMATRIX J J))
-                            (\FLOATASET (\FLOATAREF QRAUX J)
-                                   QRMATRIX J J)
-                            (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX
-                                                                 (IPLUS J (ITIMES P J))
-                                                                 P RSD J 1 (IDIFFERENCE N J))
-                                                      (\FLOATAREF QRMATRIX J J)))
-                                   QRMATRIX
-                                   (IPLUS J (ITIMES P J))
-                                   P RSD J 1 (IDIFFERENCE N J))
-                            (\FLOATASET TEMP QRMATRIX J J))) 
-          
-          (* * Compute YHAT)
-
-             (if YHAT
-                 then                                        (* Set up computation of YHAT)
-                      (BLAS.ARRAYBLT QTY 0 1 YHAT 0 1 P)
-                      (BLAS.ARRAYFILL 0.0 YHAT P 1)
-                      (bind TEMP for J from (SUB1 (IMIN P (SUB1 N))) to 0 by -1
-                         do (if (NOT (UFEQP (\FLOATAREF QRAUX J)
-                                            0.0))
-                                then (SETQ TEMP (\FLOATAREF QRMATRIX J J))
-                                     (\FLOATASET (\FLOATAREF QRAUX J)
-                                            QRMATRIX J J)
-                                     (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX
-                                                                          (IPLUS J (ITIMES P J))
-                                                                          P YHAT J 1 (IDIFFERENCE
-                                                                                      N J))
-                                                               (\FLOATAREF QRMATRIX J J)))
-                                            QRMATRIX
-                                            (IPLUS J (ITIMES P J))
-                                            P YHAT J 1 (IDIFFERENCE N J))
-                                     (\FLOATASET TEMP QRMATRIX J J]
-     B])
-
-(QRQTY
-  [LAMBDA (QRMATRIX QRAUX Y PRODUCT)                         (* jop: "27-May-86 16:28")
-          
-          (* * COMPUTE (TRANS Q) * Y given a QR factorization described by QRMATRIX and 
-          QRAUX where Y is an N vector)
-          
-          (* * Lifted from LINPACK algorithm SQRSL)
-
-    (BLAS.CHECKARRAY QRMATRIX)
-    (BLAS.CHECKARRAY QRAUX)
-    (BLAS.CHECKARRAY Y)
-    (LET ((N (ARRAY-DIMENSION QRMATRIX 0))
-          (P (ARRAY-DIMENSION QRMATRIX 1)))
-          
-          (* * Arg Checks)
-
-         (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX))
-                       (EQL P (ARRAY-TOTAL-SIZE QRAUX]
-             then (HELP "QRAUX not of size P" QRAUX))
-         (if [NOT (AND (EQL 1 (ARRAY-RANK Y))
-                       (EQL N (ARRAY-TOTAL-SIZE Y]
-             then (HELP "Y not of size N" Y))
-         (if (NULL PRODUCT)
-             then (SETQ PRODUCT (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE)
-                                       (QUOTE FLOAT)))
-           else (BLAS.CHECKARRAY PRODUCT)
-                (if (NOT (EQL N (ARRAY-TOTAL-SIZE PRODUCT)))
-                    then (HELP "PRODUCT not of size N" PRODUCT)))
-         (BLAS.ARRAYBLT Y 0 1 PRODUCT 0 1 N)
-         (bind TEMP for J from 0 to (IMIN P (SUB1 N))
-            do (if (NOT (UFEQP (\FLOATAREF QRAUX J)
-                               0.0))
-                   then (SETQ TEMP (\FLOATAREF QRMATRIX J J))
-                        (\FLOATASET (\FLOATAREF QRAUX J)
-                               QRMATRIX J J)
-                        (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX (IPLUS J
-                                                                                    (ITIMES P J))
-                                                             P PRODUCT J 1 (IDIFFERENCE N J))
-                                                  (\FLOATAREF QRMATRIX J J)))
-                               QRMATRIX
-                               (IPLUS J (ITIMES P J))
-                               P PRODUCT J 1 (IDIFFERENCE N J))
-                        (\FLOATASET TEMP QRMATRIX J J)))
-     PRODUCT])
-
-(QRQY
-  [LAMBDA (QRMATRIX QRAUX Y PRODUCT)                         (* jop: "27-May-86 16:30")
-          
-          (* * COMPUTE QX given a QR factorization described by QRMATRIX and QRAUX where 
-          Y is an N vector)
-          
-          (* * Lifted from LINPACK algorithm SQRSL)
-
-    (BLAS.CHECKARRAY QRMATRIX)
-    (BLAS.CHECKARRAY QRAUX)
-    (BLAS.CHECKARRAY Y)
-    (LET ((N (ARRAY-DIMENSION QRMATRIX 0))
-          (P (ARRAY-DIMENSION QRMATRIX 1)))
-          
-          (* * Arg Checks)
-
-         (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX))
-                       (EQL P (ARRAY-TOTAL-SIZE QRAUX]
-             then (HELP "QRAUX not of size P" QRAUX))
-         (if [NOT (AND (EQL 1 (ARRAY-RANK Y))
-                       (EQL N (ARRAY-TOTAL-SIZE Y]
-             then (HELP "Y not of size N" Y))
-         (if (NULL PRODUCT)
-             then (SETQ PRODUCT (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE)
-                                       (QUOTE FLOAT)))
-           else (BLAS.CHECKARRAY PRODUCT)
-                (if (NOT (EQL N (ARRAY-TOTAL-SIZE PRODUCT)))
-                    then (HELP "PRODUCT not of size N" PRODUCT)))
-         (BLAS.ARRAYBLT Y 0 1 PRODUCT 0 1 N)
-         (bind TEMP for J from (SUB1 (IMIN P (SUB1 N))) to 0 by -1
-            do (if (NOT (UFEQP (\FLOATAREF QRAUX J)
-                               0.0))
-                   then (SETQ TEMP (\FLOATAREF QRMATRIX J J))
-                        (\FLOATASET (\FLOATAREF QRAUX J)
-                               QRMATRIX J J)
-                        (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX (IPLUS J
-                                                                                    (ITIMES P J))
-                                                             P PRODUCT J 1 (IDIFFERENCE N J))
-                                                  (\FLOATAREF QRMATRIX J J)))
-                               QRMATRIX
-                               (IPLUS J (ITIMES P J))
-                               P PRODUCT J 1 (IDIFFERENCE N J))
-                        (\FLOATASET TEMP QRMATRIX J J)))
-     PRODUCT])
-
-(QRSOLV
-  [LAMBDA (QRMATRIX QRAUX BVECTOR SOLUTION)                  (* jop: "27-May-86 20:38")
-
-          (* * Solves to system A x = b. BVECTOR should to the RHS of the system. Returns SOLUTION)
-
-
-    (RSOLV QRMATRIX (QRQTY QRMATRIX QRAUX BVECTOR SOLUTION)
-	     SOLUTION])
-
-(MREGRESS
-  [LAMBDA (Y X B RSD YHAT)                                   (* jop: " 4-Jun-86 14:12")
-
-          (* * MREGRESS calculates the least squares (multiple) regression of Y on X. An N vector Y.)
-
-
-    (LET* ((QRAUX (MAKE-ARRAY (ARRAY-DIMENSION X 1)
-				(QUOTE :ELEMENT-TYPE)
-				(QUOTE FLOAT)))
-	   (QRMATRIX (QRFACTOR X QRAUX)))
-          (QROLS QRMATRIX QRAUX Y NIL B RSD YHAT])
-
-(RSOLV
-  [LAMBDA (RMATRIX CVECTOR BVECTOR)                          (* jop: "28-May-86 20:31")
-          
-          (* * Calcluate the solution vector BVECTOR for the system of linear equations 
-          R*B=C, where RMATRIX is upper triangular M X N with non-zero diagonal elements.
-          BVECTOR and CVECTOR must be of size N. Always returns BVECTOR)
-
-    (BLAS.CHECKARRAY RMATRIX)
-    (BLAS.CHECKARRAY CVECTOR)
-    (PROG ((M (ARRAY-DIMENSION RMATRIX 0))
-           (N (ARRAY-DIMENSION RMATRIX 1)))
-          
-          (* * Arg Checks)
-
-          (if (ILESSP M N)
-              then (HELP "Order of system less than" N))
-          (if (NOT (EQL (ARRAY-TOTAL-SIZE CVECTOR)
-                        N))
-              then (HELP "CVECTOR not of size" N))
-          (if (NULL BVECTOR)
-              then (SETQ BVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE)
-                                        (QUOTE FLOAT)))
-            else (BLAS.CHECKARRAY BVECTOR)
-                 (if (NOT (EQL (ARRAY-TOTAL-SIZE BVECTOR)
-                               N))
-                     then (HELP "BVECTOR not of size" N)))   (* Check for zero diagonal elements)
-          (if (for I from 0 to (SUB1 N) thereis (UFEQP 0.0 (\FLOATAREF RMATRIX I I)))
-              then (HELP "RMATRIX has a zero diagonal element"))
-          
-          (* * Solution by backsubstitution.)
-
-          (BLAS.ARRAYBLT CVECTOR 0 1 BVECTOR 0 1 N)
-          (LET ((INDEXLIMIT (SUB1 N)))                       (* Compute the last value)
-               (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR INDEXLIMIT)
-                                  (\FLOATAREF RMATRIX INDEXLIMIT INDEXLIMIT))
-                      BVECTOR INDEXLIMIT)
-               (bind J JLESS1 for JJ from 1 to INDEXLIMIT
-                  do (SETQ J (IDIFFERENCE N JJ))
-                     (SETQ JLESS1 (SUB1 J))
-                     (BLAS.AXPY (FMINUS (\FLOATAREF BVECTOR J))
-                            RMATRIX J N BVECTOR 0 1 J)
-                     (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR JLESS1)
-                                        (\FLOATAREF RMATRIX JLESS1 JLESS1))
-                            BVECTOR JLESS1)))
-          (RETURN BVECTOR])
-
-(MSOLVE
-  [LAMBDA (MATRIX CVECTOR SOLUTION)                          (* jop: "27-May-86 20:40")
-
-          (* * Solves to system A x = b. CVECTOR should to the RHS of the system. Returns SOLUTION)
-
-
-    (LET [(PIVOTVECTOR (MAKE-ARRAY (ARRAY-DIMENSION MATRIX 0]
-         (LUSOLV (LUFACTOR MATRIX PIVOTVECTOR)
-		   PIVOTVECTOR CVECTOR SOLUTION])
-
-(SVDFACTOR
-  [LAMBDA (XMATRIX SVECTOR UMATRIX VMATRIX)                  (* jop: "29-May-86 11:29")
-          
-          (* * Singular-value decomposition by means of orthogonalization by plane 
-          rotations. Taken from Nash and Shlien: "Partial svd algorithms." On entry X 
-          contains the M by N matrix to be decomposed, SVECTOR must be a vector of length 
-          N and VMATRIX must be a square N by N matrix.
-          On return UMATRIX has been overwritten by the left singular vectors, SVECTOR 
-          contains the singular values, and VMATRIX contains the right singular vectors.)
-
-    (BLAS.CHECKARRAY XMATRIX)
-    (LET ((M (ARRAY-DIMENSION UMATRIX 0))
-          (N (ARRAY-DIMENSION UMATRIX 1)))
-          
-          (* * Args checks)
-
-         (if (NOT (EQL 2 (ARRAY-RANK XMATRIX)))
-             then (HELP "XMATRIX not a matrix" XMATRIX))
-         (if (NULL SVECTOR)
-             then (SETQ SVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE)
-                                       (QUOTE FLOAT)))
-           else (BLAS.CHECKARRAY SVECTOR)
-                (if [NOT (AND (EQL 1 (ARRAY-RANK SVECTOR))
-                              (EQL N (ARRAY-TOTAL-SIZE SVECTOR]
-                    then (HELP "Illegal SVECTOR" SVECTOR)))
-         (if (NULL UMATRIX)
-             then (SETQ UMATRIX (MAKE-ARRAY (LIST M N)
-                                       (QUOTE :ELEMENT-TYPE)
-                                       (QUOTE FLOAT)))
-           else (BLAS.CHECKARRAY UMATRIX)
-                (if (NOT (EQUAL (ARRAY-DIMENSIONS UMATRIX)
-                                (ARRAY-DIMENSIONS XMATRIX)))
-                    then (HELP "Illegal UMATRIX" UMATRIX)))
-         (if (NULL VMATRIX)
-             then (SETQ VMATRIX (MAKE-ARRAY (LIST N N)
-                                       (QUOTE :ELEMENT-TYPE)
-                                       (QUOTE FLOAT)))
-           else (BLAS.CHECKARRAY VMATRIX)
-                (if (NOT (EQUAL (ARRAY-DIMENSIONS VMATRIX)
-                                (LIST N N)))
-                    then (HELP "Illegal VMATRIX" VMATRIX)))  (* Copy XMATRIX to UMATRIX)
-         (BLAS.ARRAYBLT XMATRIX NIL NIL UMATRIX)             (* Initialize VMATRIX to identity 
-                                                             matrix.)
-         (BLAS.ARRAYFILL 0.0 VMATRIX)
-         (for I from 0 to (SUB1 N) do (\FLOATASET 1.0 VMATRIX I I))
-          
-          (* * Start the computation)
-
-         (LET ((NT N))
-          
-          (* * The main loop: repeatedly sweep over all pairs of columns in U, rotating 
-          as needed, until no rotations in a complete sweep are effective.
-          Check the opportunity for rank reduction at the conclusion of each sweep.)
-
-              [bind (EPS _ 1.0E-6)
-                    (SLIMIT _ (IMAX (IQUOTIENT N 4)
-                                    6))
-                    (SCOUNT _ 0)
-                    RCOUNT eachtime (SETQ RCOUNT (IQUOTIENT (ITIMES NT (SUB1 NT))
-                                                        2))
-                                 (SETQ SCOUNT (ADD1 SCOUNT)) repeatwhile (IGREATERP RCOUNT 0)
-                 do (if (IGREATERP SCOUNT SLIMIT)
-                        then (HELP "Number of sweeps exceeds sweep limit." SCOUNT))
-                    [for J from 0 to (IDIFFERENCE NT 2)
-                       do (bind P Q R C S V for K from (ADD1 J) to (SUB1 NT)
-                             do (SETQ P (BLAS.DOTPROD UMATRIX J N UMATRIX K N M))
-                                (SETQ Q (BLAS.DOTPROD UMATRIX J N UMATRIX J N M))
-                                (SETQ R (BLAS.DOTPROD UMATRIX K N UMATRIX K N M))
-                                (\FLOATASET Q SVECTOR J)
-                                (\FLOATASET R SVECTOR K)
-                                (if (FLESSP Q R)
-                                    then (SETQ Q (FDIFFERENCE (FQUOTIENT Q R)
-                                                        1.0))
-                                         (SETQ P (FQUOTIENT P R))
-                                         [SETQ V (SQRT (SETQ V (FPLUS (FTIMES 4.0 P P)
-                                                                      (FTIMES Q Q]
-                                         [SETQ S (SQRT (FTIMES .5 (FDIFFERENCE 1.0 (FQUOTIENT Q V]
-                                         (if (FLESSP P 0.0)
-                                             then (SETQ S (FDIFFERENCE 0.0 S)))
-                                         (SETQ C (FQUOTIENT P (FTIMES V S)))
-                                         (BLAS.ROT C S UMATRIX J N UMATRIX K N M)
-                                         (BLAS.ROT C S VMATRIX J N VMATRIX K N N)
-                                  elseif (OR (LEQ (FTIMES Q R)
-                                                  (FTIMES EPS EPS))
-                                             (LEQ (FTIMES (FQUOTIENT P Q)
-                                                         (FQUOTIENT P R))
-                                                  EPS))
-                                    then (SETQ RCOUNT (SUB1 RCOUNT))
-                                  else (SETQ R (FDIFFERENCE 1.0 (FQUOTIENT R Q)))
-                                       (SETQ P (FQUOTIENT P Q))
-                                       [SETQ V (SQRT (SETQ V (FPLUS (FTIMES 4.0 P P)
-                                                                    (FTIMES R R]
-                                       [SETQ C (SQRT (FTIMES .5 (FPLUS 1.0 (FQUOTIENT R V]
-                                       (SETQ S (FQUOTIENT P (FTIMES V C))) 
-                                                             (* box before the COLROT calls)
-                                       (BLAS.ROT C S UMATRIX J N UMATRIX K N M)
-                                       (BLAS.ROT C S VMATRIX J N VMATRIX K N N]
-                    (while (AND (IGEQ NT 3)
-                                (LEQ (FQUOTIENT (\FLOATAREF SVECTOR (SUB1 NT))
-                                            (FPLUS (\FLOATAREF SVECTOR 0)
-                                                   EPS))
-                                     EPS)) do (SETQ NT (SUB1 NT]
-          
-          (* * Finish the decomposition by returning all N singular values, and by 
-          normalizing those columns of UMATRIX judged to be non-zero.)
-
-              (bind Q for J from 0 to (SUB1 N) do (SETQ Q (SQRT (\FLOATAREF SVECTOR J)))
-                                                  (\FLOATASET Q SVECTOR J)
-                                                  (if (ILEQ J NT)
-                                                      then (BLAS.SCAL (FQUOTIENT 1.0 Q)
-                                                                  UMATRIX J N M)))
-          SVECTOR])
-
-(SVDTEST
-  [LAMBDA NIL                                                (* jop: "30-Jan-86 17:37")
-
-          (* * comment)
-
-
-    (LET ((UU (MAKE-ARRAY (QUOTE (24 19))
-			    (QUOTE :ELEMENT-TYPE)
-			    (QUOTE FLOAT)))
-	  (SS (MAKE-ARRAY 19 (QUOTE :ELEMENT-TYPE)
-			    (QUOTE FLOAT)))
-	  (VV (MAKE-ARRAY (QUOTE (19 19))
-			    (QUOTE :ELEMENT-TYPE)
-			    (QUOTE FLOAT)))
-	  (L 0))
-         [for TT from 1.0 to 3.0 do (for PP from 1.0 to 2.0
-					       do (for CC from 1.0 to 4.0
-						       do (ASET TT UU L 0)
-							    (ASET PP UU L 1)
-							    (ASET CC UU L 2)
-							    (ASET (FTIMES TT PP)
-								    UU L 3)
-							    (ASET (FTIMES TT CC)
-								    UU L 4)
-							    (ASET (FTIMES PP CC)
-								    UU L 5)
-							    (ASET (FTIMES PP PP)
-								    UU L 6)
-							    (ASET (FTIMES CC CC)
-								    UU L 7)
-							    (ASET (FTIMES TT TT)
-								    UU L 8)
-							    (ASET (FTIMES TT PP PP)
-								    UU L 9)
-							    (ASET (FTIMES TT CC CC)
-								    UU L 10)
-							    (ASET (FTIMES PP TT TT)
-								    UU L 11)
-							    (ASET (FTIMES PP CC CC)
-								    UU L 12)
-							    (ASET (FTIMES CC TT TT)
-								    UU L 13)
-							    (ASET (FTIMES CC PP PP)
-								    UU L 14)
-							    (ASET (FTIMES TT TT TT)
-								    UU L 15)
-							    (ASET (FTIMES PP PP PP)
-								    UU L 16)
-							    (ASET (FTIMES CC CC CC)
-								    UU L 17)
-							    (ASET (FTIMES TT PP CC)
-								    UU L 18)
-							    (SETQ L (ADD1 L]
-         (TIMEALL (SVDNASH UU SS VV])
-
-(\FLOATAREFMACRO
-  [LAMBDA (ARGS)                                             (* jop: "26-May-86 16:02")
-          
-          (* * macro expander for \FLOATAREF)
-
-    (if (IGREATERP (LENGTH ARGS)
-               3)
-        then (HELP "\FLOATAREF takes no more than three args" ARGS))
-    (PROG ((BARRAY (CAR ARGS))
-           (BINDICES (CDR ARGS))
-           INDEXFORM)
-          [if (EQLENGTH BINDICES 1)
-              then (SETQ INDEXFORM (CAR BINDICES))
-            else (SETQ INDEXFORM (BQUOTE (IPLUS , (CADR BINDICES)
-                                                (ITIMES , (CAR BINDICES)
-                                                       (ARRAY-DIMENSION , BARRAY 1]
-          (RETURN (BQUOTE (\GETBASEFLOATP (ARRAYBASE , BARRAY)
-                                 (LLSH , INDEXFORM 1])
-
-(\FLOATASETMACRO
-  [LAMBDA (ARGS)                                             (* jop: "26-May-86 16:03")
-          
-          (* * macro expander for \FLOATASET)
-
-    (if (IGREATERP (LENGTH ARGS)
-               4)
-        then (HELP "\FLOATASET takes no more than four args" ARGS))
-    (PROG ((BNEWVALUE (CAR ARGS))
-           (BARRAY (CADR ARGS))
-           (BINDICES (CDDR ARGS))
-           INDEXFORM)
-          [if (EQLENGTH BINDICES 1)
-              then (SETQ INDEXFORM (CAR BINDICES))
-            else (SETQ INDEXFORM (BQUOTE (IPLUS , (CADR BINDICES)
-                                                (ITIMES , (CAR BINDICES)
-                                                       (ARRAY-DIMENSION , BARRAY 1]
-          (RETURN (BQUOTE (\PUTBASEFLOATP (ARRAYBASE , BARRAY)
-                                 (LLSH , INDEXFORM 1)
-                                 , BNEWVALUE])
-)
-
-(RPAQQ STACK ((80 27 89)
-		(80 27 88)
-		(75 25 90)
-		(62 24 87)
-		(62 22 87)
-		(62 23 87)
-		(62 24 93)
-		(62 24 93)
-		(58 23 87)
-		(58 18 80)
-		(58 18 89)
-		(58 17 88)
-		(58 18 82)
-		(58 19 93)
-		(50 18 89)
-		(50 18 86)
-		(50 19 72)
-		(50 19 79)
-		(50 20 80)
-		(56 20 82)
-		(70 20 91)))
-(DECLARE: EVAL@COMPILE 
-(PUTPROPS \FLOATAREF MACRO (ARGS (* *)
-				 (\FLOATAREFMACRO ARGS)))
-(PUTPROPS \FLOATASET MACRO (ARGS (* *)
-				 (\FLOATASETMACRO ARGS)))
-)
-(FILESLOAD BLAS)
-(PUTPROPS MATRIXOPS COPYRIGHT ("Xerox Corporation" 1986))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (665 47755 (CHOLESKYFACTOR 675 . 3149) (MTRANSPOSE 3151 . 4438) (MINVERT 4440 . 4810) (
-LSOLV 4812 . 7212) (LUFACTOR 7214 . 11565) (LUINVERSE 11567 . 14760) (LUSOLV 14762 . 17799) (MTIMES 
-17801 . 20328) (QRFACTOR 20330 . 24388) (QROLS 24390 . 29552) (QRQTY 29554 . 31713) (QRQY 31715 . 
-33879) (QRSOLV 33881 . 34176) (MREGRESS 34178 . 34600) (RSOLV 34602 . 36899) (MSOLVE 36901 . 37272) (
-SVDFACTOR 37274 . 44236) (SVDTEST 44238 . 46004) (\FLOATAREFMACRO 46006 . 46838) (\FLOATASETMACRO 
-46840 . 47753)))))
-STOP
diff --git a/obsolete/lispusers/MESATOLISP b/obsolete/lispusers/MESATOLISP
deleted file mode 100644
index ae2f7d4b..00000000
--- a/obsolete/lispusers/MESATOLISP
+++ /dev/null
@@ -1,5810 +0,0 @@
-(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10)
-(FILECREATED "10-Apr-87 18:07:52" {ERIS}<LISPUSERS>LYRIC>MESATOLISP.;4 285413 
-
-      changes to%:  (VARS MESATOLISPCOMS)
-                    (FNS SCAN.START SCAN.TOKEN PARSE.CEDAR PARSE.BIN PARSE.FILE)
-
-      previous date%: " 9-Apr-87 12:25:12" {ERIS}<LISPUSERS>LYRIC>MESATOLISP.;3)
-
-
-(* "
-Copyright (c) 1985, 1987 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT MESATOLISPCOMS)
-
-(RPAQQ MESATOLISPCOMS 
-       [  
-          (* ;; "MESATOLISP -- By Kelly Roach.  Lyricized by L. Masinter")
-
-        (COMS 
-
-(* ;;; "SCAN: reading mesa/cedar files")
-
-              [INITVARS (SCAN.STRING (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT '#\A :ELEMENT-TYPE
-                                            'CL:CHARACTER :ADJUSTABLE T :FILL-POINTER 0))
-                     (SCAN.CHAR NIL)
-                     (SCAN.QDOT NIL)
-                     (SCAN.BOTH.RESERVED '(! %# %( %) * + %, - %. |..| / %: ; < <= = => > >= @ ABS 
-                                             ALL AND ANY APPLY ARRAY BASE BEGIN BROADCAST CODE 
-                                             COMPUTED CONTINUE DECREASING DEFINITIONS DEPENDENT 
-                                             DESCRIPTOR DIRECTORY DO ELSE ENABLE END ENDCASE ENDLOOP 
-                                             ENTRY ERROR EXIT EXITS EXPORTS FINISHED FIRST FOR FORK 
-                                             FRAME FREE FROM GO GOTO IF IMPORTS IN INLINE INTERNAL 
-                                             ISTYPE JOIN LAST LENGTH LOCKS LONG LOOP LOOPHOLE MACHINE 
-                                             MAX MIN MOD MONITOR MONITORED NARROW NEW NILL NOT NOTIFY 
-                                             NULL OF OPEN OR ORD ORDERED OVERLAID PACKED POINTER PORT 
-                                             PRED PRIVATE PROC PROCEDURE PROCESS PROGRAM PUBLIC 
-                                             READONLY RECORD REJECT RELATIVE REPEAT RESTART RESUME 
-                                             RETRY RETURN RETURNS SELECT SEQUENCE SHARES SIGNAL SIZE 
-                                             START STATE STOP SUCC THEN THROUGH TO TRANSFER TRASH 
-                                             TYPE UNCOUNTED UNTIL USING VAL VAR WAIT WHILE WITH ZONE 
-                                             %[ %] ^ _ { %| } ~))
-                     (SCAN.CEDAR.RESERVED '(CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED 
-                                                  UNCHECKED UNSAFE))
-                     (SCAN.MESA.RESERVED '(RESIDENT]
-              (FNS SCAN.INIT SCAN.START SCAN.TEST SCAN.TESTFILE SCAN.OPENSTREAM SCAN.TOKEN 
-                   SCAN.NUMBER SCAN.ACCEPT SCAN.APPENDDECIMAL SCAN.APPENDOCTAL SCAN.APPENDHEX 
-                   SCAN.APPENDTOSCALE SCAN.VALIDFRACTION SCAN.DECIMAL SCAN.OCTAL SCAN.OCTALCHAR 
-                   SCAN.HEX SCAN.FLOATING SCAN.ESCAPE)
-              (P (SCAN.INIT)))
-        (COMS                                                (* ; "PARSE *")
-              [INITVARS (PARSE.FILELST NIL)
-                     (PARSE.STREAM NIL)
-                     (PARSE.FILECOMS NIL)
-                     (PARSE.LANGUAGE NIL)
-                     (PARSE.DIRLST NIL)
-                     (PARSE.CLASS NIL)
-                     (PARSE.ATOM NIL)
-                     (PARSE.CLASS2 NIL)
-                     (PARSE.ATOM2 NIL)
-                     (PARSE.CASEHEAD.FIRST '(WITH SELECT))
-                     (PARSE.DEFHEAD.FIRST '(DEFINITIONS))
-                     (PARSE.DEPENDENT.FIRST '(MACHINE))
-                     (PARSE.DOTEST.FIRST '(UNTIL WHILE))
-                     (PARSE.FORCLAUSE.FIRST '(FOR THROUGH))
-                     (PARSE.HEAP.FIRST '(UNCOUNTED))
-                     (PARSE.INTERVAL.FIRST '(%( %[))
-                     (PARSE.OPTRELATION.FIRST '(%# < <= = > >= IN NOT ~))
-                     (PARSE.ORDERED.FIRST '(ORDERED))
-                     (PARSE.ORDERLIST.FOLLOW '(! ; END %] }))
-                     (PARSE.PACKED.FIRST '(PACKED))
-                     (PARSE.PREFIXOP.FIRST '(ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC))
-                     (PARSE.PROGHEAD.FIRST '(MONITOR PROGRAM RESIDENT))
-                     (PARSE.QUALIFIER.FIRST '(%. %[ ^))
-                     (PARSE.RANGE.FOLLOW '(! %) %, |..| %: ; => AND DO ELSE END ENDCASE ENDLOOP EXITS 
-                                             FINISHED FROM NULL OR REPEAT SELECT THEN TRASH UNTIL 
-                                             WHILE %] }))
-                     (PARSE.TRANSFER.FIRST '(BROADCAST ERROR JOIN NOTIFY RESTART RETURN SIGNAL START 
-                                                   TRANSFER))
-                     (PARSE.TRANSFERMODE.FIRST '(ERROR PORT PROCESS PROGRAM SIGNAL))
-                     (PARSE.TRANSFEROP.FIRST '(ERROR FORK JOIN NEW SIGNAL START))
-                     (PARSE.TYPECONS.FIRST '(%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG MACHINE 
-                                                MONITORED ORDERED PACKED POINTER PORT PROC PORCEDURE 
-                                                PROCESS PROGRAM RECORD SIGNAL UNCOUNTED VAR %[ {))
-                     (PARSE.TYPEOP.FIRST '(FIRST LAST NILL))
-                     (PARSE.VARIANTPART.FIRST '(PACKED SELECT SEQUENCE))
-                     (PARSE.CATCHLIST.FOLLOW '(END %] }))
-                     (PARSE.CONTROLID.FOLLOW '(DECREASING IN _))
-                     (PARSE.DECLIST.FOLLOW '(; END }))
-                     (PARSE.DEFAULTOPT.FOLLOW '(%, ; END %] }))
-                     (PARSE.EXITLIST.FOLLOW '(END ENDLOOP FINISHED }))
-                     (PARSE.MODULELIST.FOLLOW '(IEQP EXPORTS SHARES))
-                     (PARSE.OPTARGS.FOLLOW '(; ELSE END ENDCASE ENDLOOP EXITS FINISHED REPEAT %] }))
-                     (PARSE.OPTEXP.FOLLOW '(! %, ; END FROM %] }))
-                     (PARSE.SCOPE.FOLLOW '(END EXITS }))
-                     (PARSE.STATEMENTLIST.FOLLOW '(END ENDLOOP EXITS REPEAT }))
-                     (PARSE.TYPEEXP.FOLLOW '(! %, ; = => DECREASING END EXPORTS FROM IMPORTS IN OF 
-                                               SHARES %] _ }))
-                     (PARSE.PREDEFINED.TYPES '(ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER CONDITION 
-                                                    INT INTEGER MDSZone MONITORLOCK NAT REAL STRING 
-                                                    StringBody UNSPECIFIED WORD))
-                     (PARSE.RELOPS (LIST '= '%# '< '<= '> '>=))
-                     (PARSE.ADDOPS (LIST '+ '-))
-                     (PARSE.MULTOPS (LIST '* '/ 'MOD))
-                     (PARSE.TRANSFEROPS '(SIGNAL ERROR START JOIN NEW FORK))
-                     (PARSE.PREFIXOPS '(LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH))
-                     (PARSE.TYPEOPS '(FIRST LAST NILL))
-                     (PARSE.NOTS '(~ NOT]
-              (RECORDS PARSERSTATE MINTERVAL MRANGE MRELATIVE MPAINTED MENUMERATED MRECORD MVAR 
-                     MARRAY MDESCRIPTOR MFRAME MREF MLIST PAIRITEM DEFAULT TYPELIST TYPEITEM MPOINTER 
-                     CASEHEAD BINDITEM KEYITEM FIELDLIST PAIRLIST ORDERLIST KEYLIST EXPLIST)
-              (FNS PARSE.MESA PARSE.CEDAR PARSE.FILE PARSE.GET.STATE PARSE.SET.STATE PARSE.BIN 
-                   PARSE.VARID PARSE.SMURF PARSE.THISIS.MESA PARSE.THISIS.CEDAR PARSE.MODULE 
-                   PARSE.INCLUDEITEM PARSE.INCLUDECHECK PARSE.SEADIRT PARSE.PROGHEAD PARSE.RESIDENT 
-                   PARSE.SAFE PARSE.DEFHEAD PARSE.TILDE PARSE.DEFINITIONS PARSE.DEFBODY PARSE.LOCKS 
-                   PARSE.LAMBDA PARSE.MODULEITEM PARSE.DECLARATION PARSE.PUBLIC PARSE.ENTRY 
-                   PARSE.IDLIST PARSE.IDENTLIST PARSE.POSITION PARSE.OPTBITS PARSE.INTERVAL 
-                   PARSE.TYPEEXP.HERE PARSE.TYPEEXP PARSE.RANGE PARSE.TYPEAPPL PARSE.TYPEAPPL.CONT 
-                   PARSE.TYPEID PARSE.TYPEID.CONT PARSE.TYPECONS PARSE.TYPECONS1 PARSE.TYPECONS.CONT 
-                   PARSE.TYPECONS.RANGE PARSE.TYPECONS.RELATIVE PARSE.TYPECONS.PAINTED 
-                   PARSE.TYPECONS2 PARSE.TYPECONS.INTERVAL PARSE.TYPECONS.DEPENDENT 
-                   PARSE.TYPECONS.ENUMERATED PARSE.TYPECONS.RECORD PARSE.TYPECONS.ORDERED 
-                   PARSE.TYPECONS.VAR PARSE.TYPECONS.PACKED PARSE.TYPECONS.DESCRIPTOR 
-                   PARSE.TYPECONS.SAFE PARSE.TYPECONS.HEAP PARSE.TYPECONS.LONG PARSE.TYPECONS.FRAME 
-                   PARSE.TYPECONS.REF PARSE.TYPECONS.LIST PARSE.IDENT PARSE.ELEMENT PARSE.MONITORED 
-                   PARSE.DEPENDENT PARSE.RECLIST PARSE.VARIANTPAIR PARSE.PAIRITEM PARSE.DEFAULTOPT 
-                   PARSE.VARIANTPART PARSE.VCASEHEAD PARSE.TAGTYPE PARSE.VARIANTITEM PARSE.TYPELIST 
-                   PARSE.TYPEITEM PARSE.POINTERTYPE PARSE.TRANSFERMODE PARSE.INITIALIZATION 
-                   PARSE.INITVALUE PARSE.CHECKED PARSE.CODELIST PARSE.STATEMENT PARSE.STATEMENT1 
-                   PARSE.STATEMENT2 PARSE.STATEMENT.CASEHEAD PARSE.STATEMENT.FORCLAUSE 
-                   PARSE.STATEMENT.RETURN PARSE.STATEMENT.TRANSFER PARSE.STATEMENT.LBRACKET 
-                   PARSE.STATEMENT.IF PARSE.BLOCK PARSE.SCOPE PARSE.BINDITEM PARSE.EXITS 
-                   PARSE.CASESTMTITEM PARSE.CASEEXPITEM PARSE.EXITITEM PARSE.CASETEST PARSE.CONTROLID 
-                   PARSE.FORCLAUSE PARSE.DIRECTION PARSE.DOTEST PARSE.DOEXIT PARSE.ENABLES 
-                   PARSE.CATCHLIST PARSE.CATCHCASE PARSE.OPTARGS PARSE.TRANSFER PARSE.KEYITEM 
-                   PARSE.OPTEXP PARSE.EXP PARSE.EXP1 PARSE.EXP2 PARSE.EXP.TRANSFEROP PARSE.EXP.IF 
-                   PARSE.EXP.CASEHEAD PARSE.EXP.LHS PARSE.EXP.LBRACKET PARSE.EXP.ERROR 
-                   PARSE.EXP.DISJUNCT PARSE.DISJUNCT PARSE.CONJUNCT PARSE.NEGATION PARSE.RELATION 
-                   PARSE.SUM PARSE.PRODUCT PARSE.OPTRELATION PARSE.RELATIONTAIL PARSE.RELOP 
-                   PARSE.ADDOP PARSE.MULTOP PARSE.FACTOR PARSE.PRIMARY PARSE.ATOM PARSE.PRIMARY.NIL 
-                   PARSE.PRIMARY.LBRACKET PARSE.PRIMARY.PREFIXOP PARSE.PRIMARY.VAL PARSE.PRIMARY.ALL 
-                   PARSE.PRIMARY.NEW PARSE.PRIMARY.TYPEOP PARSE.PRIMARY.SIZE PARSE.PRIMARY.ISTYPE 
-                   PARSE.PRIMARY.AT PARSE.PRIMARY.DESCRIPTOR PARSE.PRIMARY.CONS PARSE.PRIMARY.LIST 
-                   PARSE.PRIMARY.LHS PARSE.PRIMARY.LHS.NEW PARSE.PRIMARY.LHS.CONS 
-                   PARSE.PRIMARY.LHS.LIST PARSE.QUALIFIER PARSE.LHS PARSE.QUALIFIER.HERE 
-                   PARSE.OPTCATCH PARSE.TRANSFEROP PARSE.PREFIXOP PARSE.TYPEOP PARSE.DESCLIST 
-                   PARSE.DIRECTORY PARSE.IMPORTS PARSE.POINTERPREFIX PARSE.EXPORTS PARSE.FIELDLIST 
-                   PARSE.USING PARSE.CATCHHEAD PARSE.DECLIST PARSE.PAIRLIST PARSE.VARIANTLIST 
-                   PARSE.ORDERLIST PARSE.LHSLIST PARSE.INCLUDELIST PARSE.MODULELIST PARSE.ELEMENTLIST 
-                   PARSE.BINDLIST PARSE.STATEMENTLIST PARSE.CASESTMTLIST PARSE.CASELABEL 
-                   PARSE.EXITLIST PARSE.KEYLIST PARSE.CASEEXPLIST PARSE.EXPLIST PARSE.OPEN 
-                   PARSE.CLASS PARSE.CASEHEAD PARSE.READONLY PARSE.ORDERED PARSE.BASE PARSE.PACKED 
-                   PARSE.HEAP PARSE.INLINE PARSE.ARGUMENTS PARSE.INTERFACE PARSE.SHARES PARSE.DEFAULT 
-                   PARSE.OPTSIZE PARSE.BOUNDS PARSE.LENGTH PARSE.INDEXTYPE PARSE.ELSEPART 
-                   PARSE.OTHERPART PARSE.FREE PARSE.CATCHANY PARSE.NOT PARSE.NEW PARSE.OPTTYPE 
-                   PARSE.ARGLIST PARSE.RETURNLIST))
-        (COMS 
-          
-          (* ;; "BUILD ")
-
-              [INITVARS (BUILD.NEXT.SCOPE NIL)
-                     (BUILD.CURRENT.SCOPE NIL)
-                     (BUILD.SCOPE.STACK NIL)
-                     (BUILD.PREFIX NIL)
-                     (BUILD.FILECOMS NIL)
-                     (BUILD.BOOLEAN.FNS '(AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP ZEROP 
-                                              MINUSP EVENP ODDP FGREATERP FLESSP FEQP GREATERP LESSP 
-                                              GEQ LEQ))
-                     (BUILD.CARDINAL.FNS '(ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN IMINUS IMOD 
-                                                IPLUS IQUOTIENT IREMAINDER ITIMES LOGAND LOGNOT LOGOR 
-                                                LOGXOR NTHCHARCODE SUB1))
-                     (BUILD.MIXED.FNS '(ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT REMAINDER 
-                                            TIMES))
-                     (BUILD.REAL.FNS '(ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE FLOAT 
-                                             FMAX FMIN FMINUS FMOD FPLUS FQUOTIENT FREMAINDER FTIMES 
-                                             LOG SIN SQRT TAN))
-                     (BUILD.QUALIFY.WORDS '(FREE NEW SIZE))
-                     [BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS '= 'IEQP)
-                                                         (CONS '%# 'IEQP)
-                                                         (CONS '< 'ILESSP)
-                                                         (CONS '<= 'ILEQ)
-                                                         (CONS '> 'IGREATERP)
-                                                         (CONS '>= 'IGEQ)
-                                                         (CONS '+ 'IPLUS)
-                                                         (CONS '- 'IDIFFERENCE)
-                                                         (CONS '* 'ITIMES)
-                                                         (CONS '/ 'IQUOTIENT)
-                                                         (CONS '0- 'IMINUS)
-                                                         (CONS 'MAX 'IMAX)
-                                                         (CONS 'MIN 'IMIN)
-                                                         (CONS 'MOD 'IMOD]
-                     [BUILD.MIXED.ARITHOP.ALIST (LIST (CONS '= 'EQP)
-                                                      (CONS '%# 'EQP)
-                                                      (CONS '< 'LESSP)
-                                                      (CONS '<= 'GREATERP)
-                                                      (CONS '> 'GREATERP)
-                                                      (CONS '>= 'LESSP)
-                                                      (CONS '+ 'PLUS)
-                                                      (CONS '- 'DIFFERENCE)
-                                                      (CONS '* 'TIMES)
-                                                      (CONS '/ 'QUOTIENT)
-                                                      (CONS '0- 'MINUS)
-                                                      (CONS 'MAX 'MAX)
-                                                      (CONS 'MIN 'MIN)
-                                                      (CONS 'MOD 'IMOD]
-                     [BUILD.REAL.ARITHOP.ALIST (LIST (CONS '= 'FEQP)
-                                                     (CONS '%# 'FEQP)
-                                                     (CONS '< 'FLESSP)
-                                                     (CONS '<= 'FGREATERP)
-                                                     (CONS '> 'FGREATERP)
-                                                     (CONS '>= 'FLESSP)
-                                                     (CONS '+ 'FPLUS)
-                                                     (CONS '- 'FDIFFERENCE)
-                                                     (CONS '* 'FTIMES)
-                                                     (CONS '/ 'FQUOTIENT)
-                                                     (CONS '0- 'FMINUS)
-                                                     (CONS 'MAX 'FMAX)
-                                                     (CONS 'MIN 'FMIN)
-                                                     (CONS 'MOD 'IMOD]
-                     (BUILD.CARDINAL.TYPES '(CARDINAL CHAR CHARACTER INT INTEGER NAT WORD]
-              (RECORDS SCOPE)
-              (FNS BUILD.INIT BUILD.PUSH.SCOPE BUILD.POP.SCOPE BUILD.GC.SCOPE BUILD.STORE.EXPORTS 
-                   BUILD.STORE.IDENTLIST BUILD.STORE.INTERFACES BUILD.STORE.INTERFACE 
-                   BUILD.STORE.OPEN BUILD.STORE.USING BUILD.INITIALIZATION BUILD.INITIALIZE.VARS 
-                   BUILD.INITIALIZE.VAR BUILD.INITIALIZE.FN BUILD.INITIALIZE.RECORD BUILD.RECORD 
-                   BUILD.TYPE BUILD.STORE.ARGLIST BUILD.STORE.RETURNLIST BUILD.STORE.PAIRLIST 
-                   BUILD.STORE.PAIRITEM BUILD.STORE.VARLIST BUILD.ID BUILD.FIELDID BUILD.PROCID 
-                   BUILD.RECORDID BUILD.TYPEID BUILD.VARID BUILD.LOCALVARID BUILD.GLOBALVARID 
-                   BUILD.ULTIMATE.TYPE BUILD.REFINE.TYPE BUILD.IMMEDIATE.TYPE BUILD.LOOKUP.TYPE 
-                   BUILD.LOOKUP BUILD.TYPEATOM BUILD.QUALIFY BUILD.QUALIFY.PREFIXOP 
-                   BUILD.QUALIFY.TYPEOP BUILD.QUALIFY.EXPLIST BUILD.QUALIFY.ID BUILD.ARITH.EXP1 
-                   BUILD.ARITH.EXP2 BUILD.ARITH.EXP* BUILD.ARITH.ADD1SUB1 BUILD.COERCE.ARITHOP 
-                   BUILD.STRONGEST.TYPE.AMONG BUILD.STRONGEST.TYPE BUILD.COERCE BUILD.COERCE.MARRAY 
-                   BUILD.COERCE.MLIST BUILD.COERCE.EXPLIST BUILD.ALIGN BUILD.ALIGN.VALUE 
-                   BUILD.ADD.TO.FILECOMS BUILD.ADD1 BUILD.CALL BUILD.CHARCODE BUILD.COND 
-                   BUILD.COPY.OF BUILD.FETCH BUILD.FORCLAUSE.BY BUILD.FORCLAUSE.IN 
-                   BUILD.FORCLAUSE.THROUGH BUILD.IN BUILD.ISTYPE BUILD.LAMBDA BUILD.NEW BUILD.OR 
-                   BUILD.PROG BUILD.PROGN BUILD.REPLACE BUILD.RETURN BUILD.SELECTQ BUILD.SELECTQ.FN 
-                   BUILD.SELECTQ.CCLAUSE BUILD.SELECTQ.TEST BUILD.SELECTQ.SCLAUSE BUILD.SELECTQ.KEY 
-                   BUILD.SELECTTRUEFROM BUILD.SELECTTRUEFROM.CLAUSE BUILD.SETQ BUILD.SETQ.ARRAY 
-                   BUILD.SETQ.ORDERLIST BUILD.SUB1 BUILD.TAIL)
-              (P (BUILD.INIT])
-
-
-
-(* ;; "MESATOLISP -- By Kelly Roach.  Lyricized by L. Masinter")
-
-
-
-
-(* ;;; "SCAN: reading mesa/cedar files")
-
-
-(RPAQ? SCAN.STRING (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT '#\A :ELEMENT-TYPE 'CL:CHARACTER :ADJUSTABLE T 
-                          :FILL-POINTER 0))
-
-(RPAQ? SCAN.CHAR NIL)
-
-(RPAQ? SCAN.QDOT NIL)
-
-(RPAQ? SCAN.BOTH.RESERVED 
-       '(! %# %( %) * + %, - %. |..| / %: ; < <= = => > >= @ ABS ALL AND ANY APPLY ARRAY BASE BEGIN 
-           BROADCAST CODE COMPUTED CONTINUE DECREASING DEFINITIONS DEPENDENT DESCRIPTOR DIRECTORY DO 
-           ELSE ENABLE END ENDCASE ENDLOOP ENTRY ERROR EXIT EXITS EXPORTS FINISHED FIRST FOR FORK 
-           FRAME FREE FROM GO GOTO IF IMPORTS IN INLINE INTERNAL ISTYPE JOIN LAST LENGTH LOCKS LONG 
-           LOOP LOOPHOLE MACHINE MAX MIN MOD MONITOR MONITORED NARROW NEW NILL NOT NOTIFY NULL OF 
-           OPEN OR ORD ORDERED OVERLAID PACKED POINTER PORT PRED PRIVATE PROC PROCEDURE PROCESS 
-           PROGRAM PUBLIC READONLY RECORD REJECT RELATIVE REPEAT RESTART RESUME RETRY RETURN RETURNS 
-           SELECT SEQUENCE SHARES SIGNAL SIZE START STATE STOP SUCC THEN THROUGH TO TRANSFER TRASH 
-           TYPE UNCOUNTED UNTIL USING VAL VAR WAIT WHILE WITH ZONE %[ %] ^ _ { %| } ~))
-
-(RPAQ? SCAN.CEDAR.RESERVED '(CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED UNCHECKED UNSAFE))
-
-(RPAQ? SCAN.MESA.RESERVED '(RESIDENT))
-(DEFINEQ
-
-(SCAN.INIT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:05")
-    (PROG NIL
-          (for ATOM in SCAN.BOTH.RESERVED do (PUTPROP ATOM 'SCAN.RESERVED 'BOTH))
-          (for ATOM in SCAN.CEDAR.RESERVED do (PUTPROP ATOM 'SCAN.RESERVED 'CEDAR))
-          (for ATOM in SCAN.MESA.RESERVED do (PUTPROP ATOM 'SCAN.RESERVED 'MESA])
-
-(SCAN.START
-  [LAMBDA NIL                                             (* ; "Edited 10-Apr-87 11:39 by Masinter")
-    (CL:SETF (CL:FILL-POINTER SCAN.STRING)
-           0])
-
-(SCAN.TEST
-  [LAMBDA (STRING)                                        (* ; "Edited  6-Apr-87 15:05 by Masinter")
-          
-          (* How would scanner parse a file containing this STRING? *)
-
-    (PROG (STREAM TOKEN)
-          (SETQ STREAM (OPENSTRINGSTREAM STRING))
-          (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-          (SETQ SCAN.QDOT NIL)
-          (SETQ TOKEN (SCAN.TOKEN STREAM))
-          (CLOSEF STREAM)
-          (RETURN TOKEN])
-
-(SCAN.TESTFILE
-  [LAMBDA (FILE)                                             (* kbr%: "25-Nov-85 12:05")
-          
-          (* How would scanner parse a file containing this STRING? *)
-
-    (PROG (STREAM)
-          (SETQ STREAM (SCAN.OPENSTREAM FILE))
-          [do (SETQ TOKEN (SCAN.TOKEN STREAM))
-              (PRINT TOKEN T)
-              (COND
-                 ((EQ (CAR TOKEN)
-                      'EOF)
-                  (RETURN]
-          (CLOSEF STREAM])
-
-(SCAN.OPENSTREAM
-  [LAMBDA (FILE)                                          (* ; "Edited  6-Apr-87 15:05 by Masinter")
-                                                             (* Open FILE, return STREAM.
-                                                             *)
-    (PROG (STREAM TOKEN)
-          (SETQ STREAM (OPENSTREAM FILE 'INPUT))
-          (SETFILEPTR STREAM 0)
-          (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-          (SETQ SCAN.QDOT NIL)
-          (RETURN STREAM])
-
-(SCAN.TOKEN
-  [LAMBDA (STREAM)                                        (* ; "Edited 10-Apr-87 15:59 by Masinter")
-          
-          (* ;; "Return (CLASS VALUE) ")
-
-    (PROG (SCAN CLASS VALUE VALID C ADVANCE PCHAR COMMENT DASHCRLF STATE NEST)
-          (CL:SETF (CL:FILL-POINTER SCAN.STRING)
-                 0)
-          [do (while (<= (CL:CHAR-INT SCAN.CHAR)
-                      (CL:CHAR-INT '#\Space)) do (COND
-                                                    ((EOFP STREAM)
-                                                     (GO ENDFILE)))
-                                                 (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)))
-              (CASE SCAN.CHAR
-                    ((#\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)
-                     (SCAN.START SCAN.CHAR)
-                     [do (SCAN.ACCEPT STREAM)
-                         (COND
-                            ((NOT (OR (CL:ALPHA-CHAR-P SCAN.CHAR)
-                                      (CL:DIGIT-CHAR-P SCAN.CHAR)))
-                             (RETURN]
-                     (SETQ CLASS 'ID)
-                     (SETQ VALUE (MKATOM SCAN.STRING))
-                     (SETQ VALID T)
-                     (GO GOTNEXT))
-                    ((#\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)           (* TBW stuff concerning HTIndex.
-                                                             *)
-                     (SCAN.START SCAN.CHAR)
-                     [do (SCAN.ACCEPT STREAM)
-                         (COND
-                            ((NOT (OR (CL:ALPHA-CHAR-P SCAN.CHAR)
-                                      (CL:DIGIT-CHAR-P SCAN.CHAR)))
-                             (RETURN]
-                     (SETQ CLASS 'ID)
-                     (SETQ VALUE (MKATOM SCAN.STRING))
-                     (SETQ VALID T)
-                     (GO GOTNEXT))
-                    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-                     (SCAN.START SCAN.CHAR)
-                     (SETQ SCAN (SCAN.NUMBER STREAM NIL))
-                     (SETQ CLASS (CAR SCAN))
-                     (SETQ VALUE (CADR SCAN))
-                     (SETQ VALID (CADDR SCAN))
-                     (COND
-                        ((NOT VALID)
-                         (SCAN.ERROR)))
-                     (GO GOTNEXT))
-                    ((#\_ #\¬)
-                     (SETQ CLASS '_)
-                     (SETQ VALUE CLASS)
-                     (GO GETNEXT))
-                    ((#\^ #\­)
-                     (SETQ CLASS '^)
-                     (SETQ VALUE CLASS)
-                     (GO GETNEXT))
-                    ((#\, #\; #\: #\# #\+ #\* #\/ #\@ #\! #\( #\) #\[ #\] #\{ #\})
-                     [SETQ CLASS (MKATOM (CHARACTER (CL:CHAR-INT SCAN.CHAR]
-                     (SETQ VALUE CLASS)
-                     (GO GETNEXT))
-                    [(#\')
-                     (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                     (SETQ SCAN (SCAN.ESCAPE STREAM))
-                     (SETQ VALUE (CAR SCAN))
-                     (SETQ VALID (CADR SCAN))
-                     (SETQ ADVANCE (CADDR SCAN))
-                     (COND
-                        ((NOT VALID)
-                         (SCAN.ERROR)))
-                     (SETQ CLASS 'CHAR)
-                     (COND
-                        (ADVANCE (GO GETNEXT))
-                        (T (GO GOTNEXT]
-                    [(#\")
-                     (CL:SETF (CL:FILL-POINTER SCAN.STRING)
-                            0)
-                     (SETQ ADVANCE T)
-                     [do [COND
-                            (ADVANCE (SETQ SCAN.CHAR (CL:READ-CHAR STREAM]
-                         [CASE SCAN.CHAR ((#\")
-                                          (SETQ SCAN.CHAR (\BIN STREAM))
-                                          (COND
-                                             ((NOT (IEQP SCAN.CHAR (CHARCODE %")))
-                                              (RETURN]
-                         (SETQ SCAN (SCAN.ESCAPE STREAM))
-                         (CL:VECTOR-PUSH-EXTEND (CL:INT-CHAR (CAR SCAN))
-                                SCAN.STRING)
-                         (SETQ VALID (CADR SCAN))
-                         (SETQ ADVANCE (CADDR SCAN))
-                         (COND
-                            ((NOT VALID)
-                             (SCAN.ERROR]
-                     (SETQ VALUE (CL:COPY-SEQ SCAN.STRING))
-                     (COND
-                        ((OR (EQL SCAN.CHAR '#\l)
-                             (EQL SCAN.CHAR '#\L))
-                         (SETQ CLASS 'STRING)
-                         (GO GETNEXT))
-                        (T (SETQ CLASS 'STRING)
-                           (COND
-                              ((EQL (CL:CHAR-UPCASE SCAN.CHAR)
-                                    '#\G)
-                               (GO GETNEXT))
-                              (T (GO GOTNEXT]
-                    ((#\-)
-                     (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                     (COND
-                        ((NOT (EQL SCAN.CHAR '#\-))
-                         (SETQ CLASS '-)
-                         (SETQ VALUE '-)
-                         (GO GOTNEXT)))
-                     (SETQ SCAN.CHAR '#\Null)
-                     (do (SETQ PCHAR SCAN.CHAR)
-                         (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                         (CASE SCAN.CHAR [#\- (COND
-                                                 ((EQL PCHAR '#\-)
-                                                  (SETQ COMMENT 'DASH)
-                                                  (RETURN]
-                               (#\Newline (SETQ COMMENT 'CRLF)
-                                      (RETURN))
-                               NIL))
-                     (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                     (COND
-                        ((AND (EQ COMMENT 'DASH)
-                              (EQL SCAN.CHAR '#\Newline))
-                         (SETQ DASHCRLF T)))                 (* TBW stuff about formatting *)
-                     )
-                    [(#\.)
-                     (COND
-                        (SCAN.QDOT (SETQ SCAN.QDOT NIL)
-                               (SETQ CLASS '|..|)
-                               (SETQ VALUE '|..|)
-                               (GO GETNEXT)))
-                     (COND
-                        ((EOFP STREAM)
-                         (SETQ CLASS '%.)
-                         (SETQ VALUE '%.)
-                         (GO GOTNEXT)))
-                     (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                     (CASE SCAN.CHAR (#\. (SETQ CLASS '|..|)
-                                          (SETQ VALUE '|..|)
-                                          (GO GETNEXT))
-                           ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-                            (SCAN.START '#\.)
-                            (SETQ SCAN (SCAN.NUMBER STREAM T))
-                            (SETQ CLASS (CAR SCAN))
-                            (SETQ VALUE (CADR SCAN))
-                            (SETQ VALID (CADDR SCAN))
-                            (COND
-                               ((NOT VALID)
-                                (SCAN.ERROR)))
-                            (GO GOTNEXT))
-                           (T (SETQ CLASS '%.)
-                              (SETQ VALUE '%.)
-                              (GO GOTNEXT]
-                    [(#\=)
-                     (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                     (COND
-                        ((EQL SCAN.CHAR '#\>)
-                         (SETQ CLASS '=>)
-                         (SETQ VALUE '=>)
-                         (GO GETNEXT))
-                        (T (SETQ CLASS '=)
-                           (SETQ VALUE '=)
-                           (GO GOTNEXT]
-                    [(#\<)
-                     (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                     (CASE SCAN.CHAR (#\= (SETQ CLASS '<=)
-                                          (SETQ VALUE '<=)
-                                          (GO GETNEXT))
-                           (#\< (SETQ STATE 'PLAIN)
-                            (SETQ NEST 1)
-                            [do (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                                (CASE SCAN.CHAR (#\> (SELECTQ STATE
-                                                         ((PLAIN LEFTBROCKET) 
-                                                              (SETQ STATE 'RIGHTBROCKET))
-                                                         (RIGHTBROCKET (SETQ STATE 'PLAIN)
-                                                                       (SETQ NEST (SUB1 NEST))
-                                                                       (COND
-                                                                          ((ZEROP NEST)
-                                                                           (RETURN))))
-                                                         NIL))
-                                      (#\< (SELECTQ STATE
-                                               ((PLAIN RIGHTBROCKET) 
-                                                    (SETQ STATE 'LEFTBROCKET))
-                                               (RIGHTBROCKET (SETQ STATE 'PLAIN)
-                                                             (SETQ NEST (ADD1 NEST))
-                                                             (COND
-                                                                ((ZEROP NEST)
-                                                                 (RETURN))))
-                                               NIL))
-                                      (T (SETQ STATE 'PLAIN]
-                            (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                                                             (* TBW formatting stuff *)
-                            )
-                           (T (SETQ CLASS '<)
-                              (SETQ VALUE '<)
-                              (GO GOTNEXT]
-                    [(#\>)
-                     (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                     (COND
-                        ((EQL SCAN.CHAR '#\=)
-                         (SETQ CLASS '>=)
-                         (SETQ VALUE '>=)
-                         (GO GETNEXT))
-                        (T (SETQ CLASS '>)
-                           (SETQ VALUE '>)
-                           (GO GOTNEXT]
-                    (T [SETQ CLASS (MKATOM (CHARACTER (CL:CHAR-INT SCAN.CHAR]
-                       (SETQ VALUE CLASS)
-                       (GO GETNEXT]
-      GETNEXT
-          (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-      GOTNEXT
-          [COND
-             ((EQ CLASS 'ID)
-              [COND
-                 ((EQ VALUE NIL)
-          
-          (* Hack NIL to NILL because I can't put properties on NIL.
-          *)
-
-                  (SETQ VALUE 'NILL]
-              (COND
-                 ((GETPROP VALUE 'SCAN.RESERVED)
-                  (SETQ CLASS VALUE]
-          (RETURN (LIST CLASS VALUE))
-      ENDFILE
-          (SETQ CLASS 'EOF)
-          (SETQ VALUE 'EOF)
-          (RETURN (LIST CLASS VALUE])
-
-(SCAN.NUMBER
-  [LAMBDA (STREAM FLOAT)                                  (* ; "Edited  6-Apr-87 15:58 by Masinter")
-                                                             (* Return (CLASS VALUE VALID) *)
-    (PROG (CLASS VALUE VALID HEXCOUNT HEXSIG V START SCAN)
-          (SETQ HEXCOUNT 0)
-          (SETQ HEXSIG 0)
-          (SETQ CLASS 'LNUM)
-          [do (CASE SCAN.CHAR ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
-                               (SCAN.ACCEPT STREAM))
-                    [(#\e #\E)
-                     [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE e)
-                                                               (CHARCODE a]
-                     (SETQ HEXCOUNT (ADD1 HEXCOUNT))
-                     (SCAN.ACCEPT STREAM)
-                     (COND
-                        ([AND (IEQP HEXCOUNT 1)
-                              (OR (EQL SCAN.CHAR '#\+)
-                                  (EQL SCAN.CHAR '#\-]
-                         (SETQ FLOAT T)
-                         (SCAN.ACCEPT STREAM]
-                    ((#\a #\b #\c #\d #\e #\f)
-                     [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CL:CHAR-INT SCAN.CHAR)
-                                                               (CHARCODE a]
-                     (SETQ HEXCOUNT (ADD1 HEXCOUNT))
-                     (SCAN.ACCEPT STREAM))
-                    ((#\A #\B #\C #\D #\E #\F)
-                     [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE SCAN.CHAR (CHARCODE A]
-                     (SETQ HEXCOUNT (ADD1 HEXCOUNT))
-                     (SCAN.ACCEPT STREAM))
-                    ((#\h #\H)
-                     [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE h)
-                                                               (CHARCODE a]
-                     (SETQ HEXCOUNT (ADD1 HEXCOUNT))
-                     (SCAN.ACCEPT STREAM))
-                    ((#\.)
-                     (COND
-                        ((OR (NOT (IEQP HEXCOUNT 0))
-                             FLOAT)
-                         (RETURN)))
-                     (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-                     (COND
-                        ((EQL SCAN.CHAR '#\.)
-                         (SETQ SCAN.QDOT T)
-                         (RETURN)))
-                     (SETQ FLOAT T)
-                     (CL:VECTOR-PUSH-EXTEND '#\. SCAN.STRING))
-                    (T (RETURN]
-          (CL:VECTOR-PUSH-EXTEND '#\Null SCAN.STRING)
-          [COND
-             (FLOAT (SETQ CLASS 'FLNUM)
-                    (SETQ SCAN (SCAN.FLOATING SCAN.STRING))
-                    (SETQ V (CAR SCAN))
-                    (SETQ VALID (CADR SCAN)))
-             ([NOT (ZEROP (LOGAND HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE h)
-                                                        (CHARCODE a]
-              (SETQ SCAN (SCAN.HEX SCAN.STRING))
-              (SETQ V (CAR SCAN))
-              (SETQ VALID (CADR SCAN)))
-             ((IEQP HEXCOUNT 0)
-              (SETQ SCAN (SCAN.DECIMAL SCAN.STRING))
-              (SETQ V (CAR SCAN))
-              (SETQ VALID (CADR SCAN)))
-             ((IEQP HEXCOUNT 1)
-              (SELECTC HEXSIG
-                  ((LLSH 1 (IDIFFERENCE (CHARCODE b)
-                                  (CHARCODE a))) 
-                       (SETQ SCAN (SCAN.OCTAL SCAN.STRING)))
-                  ((LLSH 1 (IDIFFERENCE (CHARCODE c)
-                                  (CHARCODE a))) 
-                       (SETQ CLASS 'CHAR)
-                       (SETQ SCAN (SCAN.OCTALCHAR SCAN.STRING)))
-                  ((LLSH 1 (IDIFFERENCE (CHARCODE d)
-                                  (CHARCODE a))) 
-                       (SETQ SCAN (SCAN.DECIMAL SCAN.STRING)))
-                  ((LLSH 1 (IDIFFERENCE (CHARCODE e)
-                                  (CHARCODE a))) 
-                       (SETQ CLASS 'FLNUM)
-                       (SETQ SCAN (SCAN.FLOATING SCAN.STRING)))
-                  (SETQ SCAN (SCAN.HEX SCAN.STRING)))
-              (SETQ V (CAR SCAN))
-              (SETQ VALID (CADR SCAN)))
-             (T (SETQ SCAN (SCAN.HEX SCAN.STRING))
-                (SETQ V (CAR SCAN))
-                (SETQ VALID (CADR SCAN]                      (* TBW stuff *)
-          (RETURN (LIST CLASS V VALID])
-
-(SCAN.ACCEPT
-  [LAMBDA (STREAM)                                        (* ; "Edited  6-Apr-87 15:25 by Masinter")
-    (CL:VECTOR-PUSH-EXTEND SCAN.CHAR SCAN.STRING)
-    (SETQ SCAN.CHAR (CL:READ-CHAR STREAM])
-
-(SCAN.APPENDDECIMAL
-  [LAMBDA (V DIGIT)                                          (* kbr%: "25-Nov-85 12:06")
-                                                             (* DIGIT is a character code.
-                                                             Return (NEWV VALID) *)
-    (PROG (MAXV MAXD D VALID NEWV)
-          (SETQ MAXV 429496729)
-          (SETQ MAXD 5)
-          (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0)))
-          [SETQ VALID (OR (ILESSP V MAXV)
-                          (AND (IEQP V MAXV)
-                               (ILEQ D MAXD]
-          (SETQ NEWV (IPLUS (ITIMES 10 V)
-                            D))
-          (RETURN (LIST NEWV VALID])
-
-(SCAN.APPENDOCTAL
-  [LAMBDA (V DIGIT)                                          (* kbr%: "25-Nov-85 12:06")
-                                                             (* DIGIT is a character code.
-                                                             Return (NEWV VALID) *)
-    (PROG (MAXV D VALID NEWV)
-          (SETQ MAXV 536870911)
-          (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0)))
-          (SETQ VALID (ILEQ V MAXV))
-          (SETQ NEWV (IPLUS (ITIMES 8 V)
-                            D))
-          (RETURN (LIST NEWV VALID])
-
-(SCAN.APPENDHEX
-  [LAMBDA (V DIGIT)                                          (* kbr%: "25-Nov-85 12:06")
-                                                             (* DIGIT is a character code.
-                                                             Return (NEWV VALID) *)
-    (PROG (MAXV D VALID NEWV)
-          (SETQ MAXV 268435455)
-          [COND
-             [(AND (IGEQ DIGIT (CHARCODE 0))
-                   (ILEQ DIGIT (CHARCODE 9)))
-              (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0]
-             (T (SETQ D (IPLUS DIGIT (IMINUS (CHARCODE A))
-                               10]
-          (SETQ VALID (ILEQ V MAXV))
-          (SETQ NEWV (IPLUS (ITIMES 16 V)
-                            D))
-          (RETURN (LIST NEWV VALID])
-
-(SCAN.APPENDTOSCALE
-  [LAMBDA (V DIGIT)                                          (* kbr%: "25-Nov-85 12:06")
-                                                             (* DIGIT is a character code.
-                                                             Return (NEWV VALID) *)
-    (PROG (MAXV MAXD D VALID NEWV)
-          (SETQ MAXV 6553)
-          (SETQ MAXD 5)
-          (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0)))
-          [SETQ VALID (OR (ILESSP V MAXV)
-                          (AND (IEQP V MAXV)
-                               (ILEQ D MAXD]
-          (SETQ NEWV (IPLUS (ITIMES 10 V)
-                            D))
-          (RETURN (LIST NEWV VALID])
-
-(SCAN.VALIDFRACTION
-  [LAMBDA (V DIGIT)                                          (* kbr%: "25-Nov-85 12:06")
-                                                             (* DIGIT is a character code.
-                                                             Return VALID. *)
-    (PROG (MAXV MAXD D VALID)
-          (SETQ MAXV 214748364)
-          (SETQ MAXD 7)
-          (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0)))
-          [SETQ VALID (OR (ILESSP V MAXV)
-                          (AND (IEQP V MAXV)
-                               (ILEQ D MAXD]
-          (RETURN VALID])
-
-(SCAN.DECIMAL
-  [LAMBDA (BUFFER)                                        (* ; "Edited  6-Apr-87 15:48 by Masinter")
-                                                             (* Return (VALUE VALID) *)
-    (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE)
-          (SETQ VALID T)
-          (SETQ BUFFERPTR 0)
-          (SETQ V 0)
-          (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)))
-                            (CHARCODE 0))
-                      (ILEQ C (CHARCODE 9))) do [COND
-                                                   (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C))
-                                                          (SETQ V (CAR SCAN))
-                                                          (SETQ VALID (CADR SCAN]
-                                                (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-          [COND
-             ((OR (IEQP C (CHARCODE d))
-                  (IEQP C (CHARCODE D)))
-              (SETQ SCALE 0)
-              (SETQ BUFFERPTR (ADD1 BUFFERPTR))
-              (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)))
-                                (CHARCODE 0))
-                          (ILEQ C (CHARCODE 9))) do [COND
-                                                       (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C)
-                                                               )
-                                                              (SETQ SCALE (CAR SCAN))
-                                                              (SETQ VALID (CADR SCAN]
-                                                    (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-              (for I from 1 to SCALE do (SETQ SCAN (SCAN.APPENDDECIMAL V (CHARCODE 0)))
-                                        (SETQ V (CAR SCAN))
-                                        (SETQ VALID (CADR SCAN]
-          (COND
-             ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR]
-              (SETQ VALID NIL)))
-          (SETQ VALUE V)
-          (RETURN (LIST VALUE VALID])
-
-(SCAN.OCTAL
-  [LAMBDA (BUFFER)                                        (* ; "Edited  6-Apr-87 15:55 by Masinter")
-                                                             (* Return (VALUE VALID) *)
-    (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE)
-          (SETQ BUFFERPTR 0)
-          (SETQ VALID T)
-          (SETQ V 0)
-          (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)))
-                            (CHARCODE 0))
-                      (ILEQ C (CHARCODE 7))) do [COND
-                                                   (VALID (SETQ SCAN (SCAN.APPENDOCTAL V C))
-                                                          (SETQ V (CAR SCAN))
-                                                          (SETQ VALID (CADR SCAN]
-                                                (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-          [COND
-             ((OR (IEQP C (CHARCODE b))
-                  (IEQP C (CHARCODE B)))
-              (SETQ SCALE 0)
-              (SETQ BUFFERPTR (ADD1 BUFFERPTR))
-              (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)))
-                                (CHARCODE 0))
-                          (ILEQ C (CHARCODE 7))) do [COND
-                                                       (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C)
-                                                               )
-                                                              (SETQ SCALE (CAR SCAN))
-                                                              (SETQ VALID (CADR SCAN]
-                                                    (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-              (for I from 1 to SCALE do (SETQ SCAN (SCAN.APPENDOCTAL V (CHARCODE 0)))
-                                        (SETQ V (CAR SCAN))
-                                        (SETQ VALID (CADR SCAN]
-          (COND
-             ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR]
-              (SETQ VALID NIL)))
-          (SETQ VALUE V)
-          (RETURN (LIST VALUE VALID])
-
-(SCAN.OCTALCHAR
-  [LAMBDA (BUFFER)                                        (* ; "Edited  6-Apr-87 15:57 by Masinter")
-                                                             (* Return (VALUE VALID) *)
-    (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE)
-          (SETQ BUFFERPTR 0)
-          (SETQ VALID T)
-          (SETQ V 0)
-          (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)))
-                            (CHARCODE 0))
-                      (ILEQ C (CHARCODE 7))) do [COND
-                                                   (VALID (SETQ SCAN (SCAN.APPENDOCTAL V C))
-                                                          (SETQ V (CAR SCAN))
-                                                          (SETQ VALID (CADR SCAN]
-                                                (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-          [COND
-             ((OR (IEQP C (CHARCODE c))
-                  (IEQP C (CHARCODE C)))
-              (SETQ BUFFERPTR (ADD1 BUFFERPTR]
-          (COND
-             ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR]
-              (SETQ VALID NIL)))
-          (COND
-             ((NOT (OR (IGEQ V 0)
-                       (ILEQ V 255)))
-              (SETQ VALID NIL)))
-          (SETQ VALUE V)
-          (RETURN (LIST VALUE VALID])
-
-(SCAN.HEX
-  [LAMBDA (BUFFER)                                        (* ; "Edited  6-Apr-87 15:45 by Masinter")
-                                                             (* Return (VALUE VALID) *)
-    (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE)
-          (SETQ BUFFERPTR 0)
-          (SETQ VALID T)
-          (SETQ V 0)
-          (while [NOT (ZEROP (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR]
-             do (COND
-                   [[OR (AND (IGEQ C (CHARCODE 0))
-                             (ILEQ C (CHARCODE 9)))
-                        (AND (IGEQ C (CHARCODE A))
-                             (ILEQ C (CHARCODE F]
-                    (COND
-                       (VALID (SETQ SCAN (SCAN.APPENDHEX V C))
-                              (SETQ V (CAR SCAN))
-                              (SETQ VALID (CADR SCAN]
-                   [(AND (IGEQ C (CHARCODE a))
-                         (ILEQ C (CHARCODE f)))
-                    (COND
-                       (VALID [SETQ SCAN (SCAN.APPENDHEX V (IDIFFERENCE C (IDIFFERENCE (CHARCODE
-                                                                                        a)
-                                                                                 (CHARCODE A]
-                              (SETQ V (CAR SCAN))
-                              (SETQ VALID (CADR SCAN]
-                   (T (RETURN)))
-                (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-          [COND
-             ((OR (IEQP C (CHARCODE h))
-                  (IEQP C (CHARCODE H)))
-              (SETQ SCALE 0)
-              (SETQ BUFFERPTR (ADD1 BUFFERPTR))
-              (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)))
-                                (CHARCODE 0))
-                          (ILEQ C (CHARCODE 9))) do [COND
-                                                       (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C)
-                                                               )
-                                                              (SETQ SCALE (CAR SCAN))
-                                                              (SETQ VALID (CADR SCAN]
-                                                    (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-              (for I from 1 to SCALE do (SETQ SCAN (SCAN.APPENDHEX V (CHARCODE 0)))
-                                        (SETQ V (CAR SCAN))
-                                        (SETQ VALID (CADR SCAN]
-          (COND
-             ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR]
-              (SETQ VALID NIL)))
-          (SETQ VALUE V)
-          (RETURN (LIST VALUE VALID])
-
-(SCAN.FLOATING
-  [LAMBDA (BUFFER)                                        (* ; "Edited  6-Apr-87 15:46 by Masinter")
-                                                             (* Return (VALUE VALID) *)
-    (PROG (VALUE VALID BUFFERPTR C V EXP SCAN SCALE OP)
-          (SETQ BUFFERPTR 0)
-          (SETQ VALID T)
-          (SETQ V 0)
-          (SETQ EXP 0)
-          (while (AND [<= (CHARCODE 0)
-                       (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR]
-                      (< C (CHARCODE 9))) do (SETQ VALID (AND VALID (SCAN.VALIDFRACTION V C)))
-                                             [COND
-                                                (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C))
-                                                       (SETQ V (CAR SCAN)))
-                                                (T (SETQ EXP (ADD1 EXP]
-                                             (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-          [COND
-             ((= C (CHARCODE %.))
-              (SETQ BUFFERPTR (ADD1 BUFFERPTR))
-              (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)))
-              (COND
-                 ([NOT (AND (IGEQ C (CHARCODE 0))
-                            (ILEQ C (CHARCODE 9]
-                  (SETQ VALID NIL)))
-              (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)))
-                                (CHARCODE 0))
-                          (ILEQ C (CHARCODE 9))) do (SETQ VALID (AND VALID (SCAN.VALIDFRACTION V C)))
-                                                    [COND
-                                                       (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C))
-                                                              (SETQ V (CAR SCAN))
-                                                              (SETQ VALID (CADR SCAN))
-                                                              (SETQ EXP (SUB1 EXP]
-                                                    (SETQ BUFFERPTR (ADD1 BUFFERPTR]
-          (SETQ VALID T)
-          [COND
-             ((OR (IEQP C (CHARCODE e))
-                  (IEQP C (CHARCODE E)))
-              (SETQ SCALE 0)
-              (SETQ OP 'PLUS)
-              (SETQ BUFFERPTR (ADD1 BUFFERPTR))
-              (SELCHARQ (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))
-                   ("+" (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-                   ("-" (SETQ OP 'MINUS)
-                        (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-                   NIL)
-              (COND
-                 ([NOT (AND (IGEQ (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))
-                                  (CHARCODE 0))
-                            (ILEQ (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))
-                                  (CHARCODE 9]
-                  (SETQ VALID NIL)))
-              (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)))
-                                (CHARCODE 0))
-                          (ILEQ C (CHARCODE 9))) do [COND
-                                                       (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C)
-                                                               )
-                                                              (SETQ SCALE (CAR SCAN))
-                                                              (SETQ VALID (CADR SCAN]
-                                                    (SETQ BUFFERPTR (ADD1 BUFFERPTR)))
-              (SETQ EXP (COND
-                           ((EQ OP 'PLUS)
-                            (IPLUS EXP SCALE))
-                           (T (IDIFFERENCE EXP SCALE]
-          (COND
-             ((NOT (ZEROP (CL:ELT BUFFER BUFFERPTR)))
-              (SETQ VALID NIL)))
-          
-          (* TBW NOTE%: Look at MKNUMATOM & \FLOATINGSCALE to find right way to do this.
-          *)
-
-          (SETQ VALUE (FTIMES V (EXPT 10.0 EXP)))
-          (RETURN (LIST VALUE VALID])
-
-(SCAN.ESCAPE
-  [LAMBDA (STREAM)                                        (* ; "Edited  6-Apr-87 15:28 by Masinter")
-    (PROG (C VALID ADVANCE V NC)
-          (SETQ VALID T)
-          (SETQ ADVANCE T)
-          (SETQ C SCAN.CHAR)
-          [COND
-             ((EQL C '#\\)
-              (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))
-              (SETQ C (CASE SCAN.CHAR ((#\n #\N #\r #\R)
-                                       (CHARCODE CR))
-                            ((#\l #\L)
-                             (CHARCODE LF))
-                            ((#\t #\T)
-                             (CHARCODE TAB))
-                            ((#\b #\B)
-                             (CHARCODE BS))
-                            ((#\f #\F)
-                             (CHARCODE FF))
-                            ((#\' #\" #\\)
-                             (CL:CHAR-INT SCAN.CHAR))
-                            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
-                             (SETQ V 0)
-                             (SETQ NC 0)
-                             (do (COND
-                                    ([NOT (AND (IGEQ (CL:CHAR-INT SCAN.CHAR)
-                                                     (CHARCODE 0))
-                                               (ILEQ (CL:CHAR-INT SCAN.CHAR)
-                                                     (CHARCODE 7]
-                                     (SETQ VALID NIL)
-                                     (SETQ ADVANCE NIL)
-                                     (RETURN)))
-                                 [SETQ V (IPLUS (ITIMES 8 V)
-                                                (IDIFFERENCE (CL:CHAR-INT SCAN.CHAR)
-                                                       (CHARCODE 0]
-                                 (COND
-                                    ((IEQP (SETQ NC (ADD1 NC))
-                                           3)
-                                     (RETURN)))
-                                 (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)))
-                             (COND
-                                ((IGREATERP V 255)
-                                 (SETQ VALID NIL)
-                                 (SETQ V 0)))
-                             (SETQ C V))
-                            (T (SETQ VALID NIL)
-                               (SETQ ADVANCE NIL]
-          (RETURN (LIST C VALID ADVANCE])
-)
-(SCAN.INIT)
-
-
-
-(* ; "PARSE *")
-
-
-(RPAQ? PARSE.FILELST NIL)
-
-(RPAQ? PARSE.STREAM NIL)
-
-(RPAQ? PARSE.FILECOMS NIL)
-
-(RPAQ? PARSE.LANGUAGE NIL)
-
-(RPAQ? PARSE.DIRLST NIL)
-
-(RPAQ? PARSE.CLASS NIL)
-
-(RPAQ? PARSE.ATOM NIL)
-
-(RPAQ? PARSE.CLASS2 NIL)
-
-(RPAQ? PARSE.ATOM2 NIL)
-
-(RPAQ? PARSE.CASEHEAD.FIRST '(WITH SELECT))
-
-(RPAQ? PARSE.DEFHEAD.FIRST '(DEFINITIONS))
-
-(RPAQ? PARSE.DEPENDENT.FIRST '(MACHINE))
-
-(RPAQ? PARSE.DOTEST.FIRST '(UNTIL WHILE))
-
-(RPAQ? PARSE.FORCLAUSE.FIRST '(FOR THROUGH))
-
-(RPAQ? PARSE.HEAP.FIRST '(UNCOUNTED))
-
-(RPAQ? PARSE.INTERVAL.FIRST '(%( %[))
-
-(RPAQ? PARSE.OPTRELATION.FIRST '(%# < <= = > >= IN NOT ~))
-
-(RPAQ? PARSE.ORDERED.FIRST '(ORDERED))
-
-(RPAQ? PARSE.ORDERLIST.FOLLOW '(! ; END %] }))
-
-(RPAQ? PARSE.PACKED.FIRST '(PACKED))
-
-(RPAQ? PARSE.PREFIXOP.FIRST '(ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC))
-
-(RPAQ? PARSE.PROGHEAD.FIRST '(MONITOR PROGRAM RESIDENT))
-
-(RPAQ? PARSE.QUALIFIER.FIRST '(%. %[ ^))
-
-(RPAQ? PARSE.RANGE.FOLLOW 
-       '(! %) %, |..| %: ; => AND DO ELSE END ENDCASE ENDLOOP EXITS FINISHED FROM NULL OR REPEAT 
-           SELECT THEN TRASH UNTIL WHILE %] }))
-
-(RPAQ? PARSE.TRANSFER.FIRST '(BROADCAST ERROR JOIN NOTIFY RESTART RETURN SIGNAL START TRANSFER))
-
-(RPAQ? PARSE.TRANSFERMODE.FIRST '(ERROR PORT PROCESS PROGRAM SIGNAL))
-
-(RPAQ? PARSE.TRANSFEROP.FIRST '(ERROR FORK JOIN NEW SIGNAL START))
-
-(RPAQ? PARSE.TYPECONS.FIRST 
-       '(%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG MACHINE MONITORED ORDERED PACKED POINTER PORT PROC 
-            PORCEDURE PROCESS PROGRAM RECORD SIGNAL UNCOUNTED VAR %[ {))
-
-(RPAQ? PARSE.TYPEOP.FIRST '(FIRST LAST NILL))
-
-(RPAQ? PARSE.VARIANTPART.FIRST '(PACKED SELECT SEQUENCE))
-
-(RPAQ? PARSE.CATCHLIST.FOLLOW '(END %] }))
-
-(RPAQ? PARSE.CONTROLID.FOLLOW '(DECREASING IN _))
-
-(RPAQ? PARSE.DECLIST.FOLLOW '(; END }))
-
-(RPAQ? PARSE.DEFAULTOPT.FOLLOW '(%, ; END %] }))
-
-(RPAQ? PARSE.EXITLIST.FOLLOW '(END ENDLOOP FINISHED }))
-
-(RPAQ? PARSE.MODULELIST.FOLLOW '(IEQP EXPORTS SHARES))
-
-(RPAQ? PARSE.OPTARGS.FOLLOW '(; ELSE END ENDCASE ENDLOOP EXITS FINISHED REPEAT %] }))
-
-(RPAQ? PARSE.OPTEXP.FOLLOW '(! %, ; END FROM %] }))
-
-(RPAQ? PARSE.SCOPE.FOLLOW '(END EXITS }))
-
-(RPAQ? PARSE.STATEMENTLIST.FOLLOW '(END ENDLOOP EXITS REPEAT }))
-
-(RPAQ? PARSE.TYPEEXP.FOLLOW 
-       '(! %, ; = => DECREASING END EXPORTS FROM IMPORTS IN OF SHARES %] _ }))
-
-(RPAQ? PARSE.PREDEFINED.TYPES 
-       '(ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER CONDITION INT INTEGER MDSZone MONITORLOCK NAT REAL 
-              STRING StringBody UNSPECIFIED WORD))
-
-(RPAQ? PARSE.RELOPS (LIST '= '%# '< '<= '> '>=))
-
-(RPAQ? PARSE.ADDOPS (LIST '+ '-))
-
-(RPAQ? PARSE.MULTOPS (LIST '* '/ 'MOD))
-
-(RPAQ? PARSE.TRANSFEROPS '(SIGNAL ERROR START JOIN NEW FORK))
-
-(RPAQ? PARSE.PREFIXOPS '(LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH))
-
-(RPAQ? PARSE.TYPEOPS '(FIRST LAST NILL))
-
-(RPAQ? PARSE.NOTS '(~ NOT))
-(DECLARE%: EVAL@COMPILE
-
-(TYPERECORD PARSERSTATE (STREAM FILEPTR CHAR QDOT CLASS ATOM CLASS2 ATOM2 PREFIX NEXTSCOPE 
-                               CURRENTSCOPE SCOPESTACK FILECOMS))
-
-(TYPERECORD MINTERVAL (KIND . BOUNDS)
-                      [ACCESSFNS ((LBOUND (CAR (fetch (MINTERVAL BOUNDS) of DATUM)))
-                                  (UBOUND (CADR (fetch (MINTERVAL BOUNDS) of DATUM])
-
-(TYPERECORD MRANGE (TYPE INTERVAL))
-
-(TYPERECORD MRELATIVE (TYPEID TYPE))
-
-(TYPERECORD MPAINTED (TYPEID TYPE))
-
-(TYPERECORD MENUMERATED ITEMS)
-
-(TYPERECORD MRECORD (RECORDID . FIELDLIST))
-
-(TYPERECORD MVAR TYPE)
-
-(TYPERECORD MARRAY (INDEXTYPE TYPE))
-
-(TYPERECORD MDESCRIPTOR TYPE)
-
-(TYPERECORD MFRAME ID)
-
-(TYPERECORD MREF TYPE)
-
-(TYPERECORD MLIST TYPE)
-
-(RECORD PAIRITEM (ID TYPEEXP DEFAULT))
-
-(RECORD DEFAULT (EXP TRASH))
-
-(TYPERECORD TYPELIST ITEMS)
-
-(RECORD TYPEITEM (TYPEEXP DEFAULT))
-
-(TYPERECORD MPOINTER TYPE)
-
-(TYPERECORD CASEHEAD (ID EXP OPTEXP))
-
-(TYPERECORD BINDITEM (ID EXP))
-
-(RECORD KEYITEM (ID OPTEXP))
-
-(RECORD FIELDLIST (TYPE . ITEMS)
-                  [TYPE? (AND (LISTP DATUM)
-                              (FMEMB (CAR DATUM)
-                                     '(PAIRLIST TYPELIST])
-
-(TYPERECORD PAIRLIST ITEMS)
-
-(TYPERECORD ORDERLIST ITEMS)
-
-(TYPERECORD KEYLIST ITEMS)
-
-(RECORD EXPLIST (TYPE . ITEMS)
-                [TYPE? (AND (LISTP DATUM)
-                            (FMEMB (CAR DATUM)
-                                   '(KEYLIST ORDERLIST])
-)
-(DEFINEQ
-
-(PARSE.MESA
-  [LAMBDA (FILE DIRLST)                                      (* kbr%: "25-Nov-85 12:46")
-    (PARSE.FILE FILE 'MESA DIRLST])
-
-(PARSE.CEDAR
-  (CL:LAMBDA (&OPTIONAL FILE DIRLST)                      (* ; "Edited 10-Apr-87 16:00 by Masinter")
-         (PARSE.FILE FILE 'CEDAR DIRLST)))
-
-(PARSE.FILE
-  (CL:LAMBDA (&OPTIONAL FILE LANGUAGE DIRLST)             (* ; "Edited 10-Apr-87 16:01 by Masinter")
-         (PROG NIL
-               (SETQ PARSE.DIRLST DIRLST)
-               (SETQ PARSE.LANGUAGE LANGUAGE)
-               (SETQ PARSE.STREAM (SCAN.OPENSTREAM FILE))
-               (SETQ PARSE.ATOM NIL)
-               (SETQ PARSE.ATOM2 NIL)
-               (PARSE.BIN)
-               (PARSE.BIN)
-               (PARSE.MODULE)
-               (SETQ PARSE.FILECOMS (DREVERSE PARSE.FILECOMS))
-               (CLOSEF PARSE.STREAM))))
-
-(PARSE.GET.STATE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:46")
-                                                             (* Get parser state to save before 
-                                                             interruption. *)
-    (create PARSERSTATE
-           STREAM _ PARSE.STREAM
-           FILEPTR _ (GETFILEPTR PARSE.STREAM)
-           CHAR _ SCAN.CHAR
-           QDOT _ SCAN.QDOT
-           CLASS _ PARSE.CLASS
-           ATOM _ PARSE.ATOM
-           CLASS2 _ PARSE.CLASS2
-           ATOM2 _ PARSE.ATOM2
-           PREFIX _ BUILD.PREFIX
-           NEXTSCOPE _ BUILD.NEXT.SCOPE
-           CURRENTSCOPE _ BUILD.CURRENT.SCOPE
-           SCOPESTACK _ BUILD.SCOPE.STACK
-           FILECOMS _ BUILD.FILECOMS])
-
-(PARSE.SET.STATE
-  [LAMBDA (STATE)                                            (* kbr%: "25-Nov-85 12:46")
-                                                             (* Restore state after interruption.
-                                                             *)
-    (PROG NIL
-          (SETQ PARSE.STREAM (fetch (PARSERSTATE STREAM) of STATE))
-          (SETFILEPTR PARSE.STREAM (fetch (PARSERSTATE FILEPTR) of STATE))
-          (SETQ SCAN.CHAR (fetch (PARSERSTATE CHAR) of STATE))
-          (SETQ SCAN.QDOT (fetch (PARSERSTATE QDOT) of STATE))
-          (SETQ PARSE.CLASS (fetch (PARSERSTATE CLASS) of STATE))
-          (SETQ PARSE.ATOM (fetch (PARSERSTATE ATOM) of STATE))
-          (SETQ PARSE.CLASS2 (fetch (PARSERSTATE CLASS2) of STATE))
-          (SETQ PARSE.ATOM2 (fetch (PARSERSTATE ATOM2) of STATE))
-          (SETQ BUILD.PREFIX (fetch (PARSERSTATE PREFIX) of STATE))
-          (SETQ BUILD.NEXT.SCOPE (fetch (PARSERSTATE NEXTSCOPE) of STATE))
-          (SETQ BUILD.CURRENT.SCOPE (fetch (PARSERSTATE CURRENTSCOPE) of STATE))
-          (SETQ BUILD.SCOPE.STACK (fetch (PARSERSTATE SCOPESTACK) of STATE))
-          (SETQ BUILD.FILECOMS (fetch (PARSERSTATE FILECOMS) of STATE])
-
-(PARSE.BIN
-  (CL:LAMBDA (EXPECTCLASS)                                (* ; "Edited 10-Apr-87 16:00 by Masinter")
-         (PROG (OLDATOM TOKEN)
-               (COND
-                  ([AND EXPECTCLASS (OR (AND (LITATOM EXPECTCLASS)
-                                             (NOT (EQ EXPECTCLASS PARSE.CLASS)))
-                                        (AND (LISTP EXPECTCLASS)
-                                             (NOT (FMEMB PARSE.CLASS EXPECTCLASS]
-                   (SHOULDNT "PARSE.BIN")))
-               (SETQ OLDATOM PARSE.ATOM)
-               (SETQ TOKEN (SCAN.TOKEN PARSE.STREAM))
-               (SETQ PARSE.CLASS PARSE.CLASS2)
-               (SETQ PARSE.ATOM PARSE.ATOM2)
-               (SETQ PARSE.CLASS2 (CAR TOKEN))
-               (SETQ PARSE.ATOM2 (CADR TOKEN))
-               (RETURN OLDATOM))))
-
-(PARSE.VARID
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:46")
-    (BUILD.VARID NIL (PARSE.BIN 'ID])
-
-(PARSE.SMURF
-  [LAMBDA (N)                                                (* kbr%: "25-Nov-85 12:46")
-                                                             (* Indicate where error occurred while 
-                                                             reading file *)
-    (COND
-       ((NULL N)
-        (SETQ N 100)))
-    (RESETLST (PROG (POSITION START FINISH)                  (* Broken file = previous input file *)
-                    (SETQ POSITION (GETFILEPTR PARSE.STREAM))
-                    (RESETSAVE NIL (LIST 'SETFILEPTR PARSE.STREAM POSITION))
-                    (SETQ START (IMAX 0 (IDIFFERENCE (SUB1 POSITION)
-                                               N)))
-                    (SETQ FINISH (IMIN (GETEOFPTR PARSE.STREAM)
-                                       (IPLUS (SUB1 POSITION)
-                                              N)))
-                    (COPYBYTES PARSE.STREAM T START (SUB1 POSITION))
-                    (PRIN1 "[PARSE]" T)
-                    (COPYBYTES PARSE.STREAM T (SUB1 POSITION)
-                           FINISH)
-                    (TERPRI T])
-
-(PARSE.THISIS.MESA
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:46")
-                                                             (* Assert this is MESA *)
-    (COND
-       ((NOT (EQ PARSE.LANGUAGE 'MESA))
-        (SHOULDNT])
-
-(PARSE.THISIS.CEDAR
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:46")
-                                                             (* Assert this is CEDAR *)
-    (COND
-       ((NOT (EQ PARSE.LANGUAGE 'CEDAR))
-        (SHOULDNT])
-
-(PARSE.MODULE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:46")
-    (PROG (IDENTLIST)                                        (* (module directory identlist cedar 
-                                                             proghead trusted checked block)
-                                                             (module directory identlist cedar 
-                                                             defhead defbody) *)
-          (PARSE.DIRECTORY)
-          (SETQ IDENTLIST (PARSE.IDENTLIST))
-          (BUILD.INIT (CAR IDENTLIST))
-          (BUILD.STORE.INTERFACES IDENTLIST)
-          (PARSE.SEADIRT)
-          (COND
-             ((NOT (EQ PARSE.ATOM 'DEFINITIONS))
-              (PARSE.PROGHEAD)
-              (PARSE.CHECKED)
-              (PARSE.BLOCK))
-             (T (PARSE.DEFHEAD)
-                (PARSE.DEFBODY)))
-          (PUTPROP BUILD.PREFIX 'MESA.PARSED T)
-          (pushnew PARSE.FILELST BUILD.PREFIX])
-
-(PARSE.INCLUDEITEM
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:46")
-    (PROG (ID USING)                                         (* (includeitem id %: FROM string 
-                                                             using) (includeitem id %: TYPE using)
-                                                             (includeitem id using)
-                                                             (includeitem id %: TYPE id using) *)
-          (SETQ ID (PARSE.BIN 'ID))
-          (BUILD.STORE.INTERFACE ID)
-          (PARSE.INCLUDECHECK ID)
-          [COND
-             [(EQ PARSE.ATOM '%:)
-              (PARSE.BIN)
-              (COND
-                 ((EQ PARSE.ATOM 'FROM)
-                  (PARSE.BIN)
-                  (PARSE.BIN 'STRING)
-                  (SETQ USING (PARSE.USING)))
-                 (T (PARSE.BIN 'TYPE)
-                    (COND
-                       ((EQ PARSE.ATOM 'ID)
-                        (PARSE.BIN 'ID)
-                        (SETQ USING (PARSE.USING)))
-                       ((EQ PARSE.ATOM 'USING)
-                        (SETQ USING (PARSE.USING]
-             (T (SETQ USING (PARSE.USING]
-          (BUILD.STORE.USING ID USING])
-
-(PARSE.INCLUDECHECK
-  [LAMBDA (ID)                                               (* kbr%: "25-Nov-85 12:46")
-    (PROG (STATE FILE)
-          (COND
-             ((GETPROP ID 'MESA.PARSED)                      (* Interface already loaded.
-                                                             *)
-              (RETURN)))
-          (SELECTQ (ASKUSER NIL NIL (CONCAT "Should I parse " ID ".MESA?"))
-              (Y [SETQ FILE (OR (FINDFILE (PACK* ID '.MESA)
-                                       NIL PARSE.DIRLST)
-                                (MKATOM (PROMPTFORWORD (CONCAT "Enter full filename for " ID ".MESA:"
-                                                              ]
-                 (COND
-                    (FILE (SETQ STATE (PARSE.GET.STATE))
-                          (PARSE.FILE FILE PARSE.LANGUAGE PARSE.DIRLST)
-                          (PARSE.SET.STATE STATE))))
-              (N NIL)
-              (SHOULDNT])
-
-(PARSE.SEADIRT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:46")
-                                                             (* BOTH (cedar) *)
-                                                             (* CEDAR (cedar CEDAR) *)
-    (COND
-       ((EQ PARSE.ATOM 'CEDAR)
-        (PARSE.THISIS.CEDAR)
-        (PARSE.BIN])
-
-(PARSE.PROGHEAD
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:46")
-    (PROG NIL                                                (* (proghead resident safe class 
-                                                             arguments locks interface tilde public) 
-                                                             *)
-          
-          (* In MESA, tilde must be =. This is handled by PARSE.TILDE.
-          *)
-
-          (PARSE.RESIDENT)
-          (PARSE.SAFE)
-          (PARSE.CLASS)
-          (PARSE.ARGUMENTS)
-          (PARSE.LOCKS)
-          (PARSE.INTERFACE)
-          (PARSE.TILDE)
-          (PARSE.PUBLIC])
-
-(PARSE.RESIDENT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* BOTH (resident) *)
-                                                             (* MESA (resident RESIDENT) *)
-    (COND
-       ((EQ PARSE.ATOM 'RESIDENT)
-        (PARSE.THISIS.MESA)
-        (PARSE.BIN])
-
-(PARSE.SAFE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* BOTH (safe) *)
-                                                             (* CEDAR (safe UNSAFE)
-                                                             (safe SAFE) *)
-    (COND
-       ((FMEMB PARSE.ATOM '(SAFE UNSAFE))
-        (PARSE.THISIS.CEDAR)
-        (PARSE.BIN])
-
-(PARSE.DEFHEAD
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG NIL                                                (* (defhead definitions locks imports 
-                                                             shares tilde public) *)
-          (PARSE.DEFINITIONS)
-          (PARSE.LOCKS)
-          (PARSE.IMPORTS)
-          (PARSE.SHARES)
-          (PARSE.TILDE)
-          (PARSE.PUBLIC])
-
-(PARSE.TILDE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* BOTH (tilde =) *)
-                                                             (* CEDAR (tilde ~) *)
-    (COND
-       ((EQ PARSE.ATOM '=)
-        (PARSE.BIN))
-       ((EQ PARSE.ATOM '~)
-        (PARSE.THISIS.CEDAR)
-        (PARSE.BIN))
-       (T (SHOULDNT])
-
-(PARSE.DEFINITIONS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (definitions DEFINITIONS) *)
-    (PARSE.BIN])
-
-(PARSE.DEFBODY
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG NIL                                                (* (defbody BEGIN open declist END)
-                                                             (defbody BEGIN open declist ;
-                                                             END) (defbody { open declist })
-                                                             (defbody { open declist ;
-                                                             }) *)
-          (PARSE.BIN '(BEGIN {))
-          (BUILD.PUSH.SCOPE)
-          (BUILD.STORE.OPEN (PARSE.OPEN))
-          (PARSE.DECLIST)
-          (BUILD.POP.SCOPE)
-          (BUILD.GC.SCOPE)
-          (COND
-             ((EQ PARSE.ATOM ';)
-              (PARSE.BIN)))
-          (PARSE.BIN '(END }])
-
-(PARSE.LOCKS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG NIL                                                (* (locks LOCKS primary lambda)
-                                                             (locks) *)
-          (COND
-             ((EQ PARSE.ATOM 'LOCKS)
-              (PARSE.BIN)
-              (PARSE.PRIMARY)
-              (PARSE.LAMBDA])
-
-(PARSE.LAMBDA
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (IDENT TYPEEXP)                                    (* (lambda USING ident typeexp)
-                                                             (lambda) *)
-          (COND
-             ((EQ PARSE.ATOM 'USING)
-              (PARSE.BIN)
-              (SETQ IDENT (PARSE.IDENT))
-              (SETQ TYPEEXP (PARSE.TYPEEXP))
-              (BUILD.INITIALIZE.VAR IDENT TYPEEXP NIL BUILD.CURRENT.SCOPE])
-
-(PARSE.MODULEITEM
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ID1 ID2)                                          (* (moduleitem id) (moduleitem id %: 
-                                                             id) *)
-          (SETQ ID1 (PARSE.BIN 'ID))
-          [COND
-             ((EQ PARSE.ATOM '%:)
-              (PARSE.BIN)
-              (SETQ ID2 (PARSE.BIN 'ID))
-              (PUTPROP ID1 'MESA.ABBREVIATES 'ID2]
-          (RETURN ID1])
-
-(PARSE.DECLARATION
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (IDENTLIST TYPEEXP INITIALIZATION DEFAULT OPTSIZE ANSWER)
-                                                             (* (declaration identlist public entry 
-                                                             readonly typeexp initialization)
-                                                             (declaration identlist public TYPE 
-                                                             tilde public typeexp default)
-                                                             (declaration identlist public TYPE 
-                                                             optsize) *)
-          
-          (* In MESA, tilde must be =. This is handled by PARSE.TILDE.
-          *)
-
-          (SETQ IDENTLIST (PARSE.IDENTLIST))
-          (BUILD.STORE.IDENTLIST IDENTLIST)
-          (PARSE.PUBLIC)
-          [COND
-             ((NOT (EQ PARSE.ATOM 'TYPE))
-              (PARSE.ENTRY)
-              (PARSE.READONLY)
-              (SETQ TYPEEXP (PARSE.TYPEEXP))
-              (SETQ INITIALIZATION (PARSE.INITIALIZATION))
-              (SETQ ANSWER (BUILD.INITIALIZATION IDENTLIST TYPEEXP INITIALIZATION)))
-             (T (PARSE.BIN 'TYPE)
-                (COND
-                   ([OR (EQ PARSE.ATOM '=)
-                        (AND (EQ PARSE.LANGUAGE 'CEDAR)
-                             (EQ PARSE.ATOM '~]
-                    (PARSE.TILDE)
-                    (PARSE.PUBLIC)
-                    (SETQ TYPEEXP (PARSE.TYPEEXP))
-                    (SETQ DEFAULT (PARSE.DEFAULT))
-                    (BUILD.TYPE IDENTLIST TYPEEXP DEFAULT))
-                   (T (SETQ OPTSIZE (PARSE.OPTSIZE))
-          
-          (* I think this means MESA/CEDAR is to treat declared id as a type, but no 
-          declaration of id is given in this file.
-          *)
-
-                      ]
-          (BUILD.STORE.IDENTLIST NIL)
-          (RETURN ANSWER])
-
-(PARSE.PUBLIC
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (public PUBLIC) (public PRIVATE)
-                                                             (public) *)
-    (COND
-       ((MEMB PARSE.ATOM '(PUBLIC PRIVATE))
-        (PARSE.BIN])
-
-(PARSE.ENTRY
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (entry ENTRY) (entry INTERNAL)
-                                                             (entry) *)
-    (COND
-       ((MEMB PARSE.ATOM '(ENTRY INTERNAL))
-        (PARSE.BIN])
-
-(PARSE.IDLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (idlist' id) (idlist' id %, idlist') 
-                                                             *)
-    (PROG (IDS ANSWER)
-          (push IDS (PARSE.BIN 'ID))
-          [while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (push IDS (PARSE.BIN 'ID]
-          (SETQ ANSWER (DREVERSE IDS))
-          (RETURN ANSWER])
-
-(PARSE.IDENTLIST
-  [LAMBDA (KIND)                                             (* kbr%: "25-Nov-85 12:47")
-                                                             (* (identlist' id %:)
-                                                             (identlist' id position %:)
-                                                             (identlist' id %, identlist')
-                                                             (identlist' id position %, identlist') 
-                                                             *)
-    (PROG (IDS TYPEITEMS ANSWER)
-      LOOP
-          (COND
-             ((AND (EQ KIND 'FIELDLIST)
-                   (PARSE.TYPEEXP.HERE))
-          
-          (* Thought we we're parsing a pairlist, but now we learn we are in a typelist.
-          *)
-
-              (SETQ TYPEITEMS (fetch (TYPELIST ITEMS) of (PARSE.TYPELIST)))
-              (GO TYPELIST)))
-          (push IDS (PARSE.BIN 'ID))
-          (COND
-             ((EQ PARSE.ATOM '%()
-              (PARSE.POSITION)))
-          (COND
-             ((EQ PARSE.ATOM '%,)
-              (PARSE.BIN)
-              (GO LOOP))
-             (T (GO EXIT)))
-          (GO LOOP)
-      EXIT
-          (COND
-             ((NOT (EQ PARSE.ATOM '%:))
-              (GO TYPELIST)))
-          (PARSE.BIN '%:)
-          (SETQ ANSWER (DREVERSE IDS))
-          (RETURN ANSWER)
-      TYPELIST
-          (SETQ ANSWER (create TYPELIST
-                              ITEMS _ (NCONC (DREVERSE IDS)
-                                             TYPEITEMS)))
-          (RETURN ANSWER])
-
-(PARSE.POSITION
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (EXP OPTBITS ANSWER)                               (* (position %( exp optbits %)) *)
-          (PARSE.BIN '%()
-          (SETQ EXP (PARSE.EXP))
-          (SETQ OPTBITS (PARSE.OPTBITS))
-          (PARSE.BIN '%))
-          (SETQ ANSWER (LIST 'position EXP OPTBITS))
-          (RETURN ANSWER])
-
-(PARSE.OPTBITS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (optbits %: bounds)
-                                                             (optbits) *)
-    (COND
-       ((EQ PARSE.ATOM '%:)
-        (PARSE.BIN '%:)
-        (PARSE.BOUNDS])
-
-(PARSE.INTERVAL
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (KIND BOUNDS ANSWER)                               (* (interval %[ bounds %])
-                                                             (interval %[ bounds %))
-                                                             (interval %( bounds %])
-                                                             (interval %( bounds %)) *)
-          (SELECTQ PARSE.ATOM
-              (%[ (PARSE.BIN)
-                  (SETQ BOUNDS (PARSE.BOUNDS))
-                  (SELECTQ PARSE.ATOM
-                      (%] (SETQ KIND 'CC))
-                      (%) (SETQ KIND 'CO))
-                      (SHOULDNT))
-                  (PARSE.BIN))
-              (%( (PARSE.BIN)
-                  (SETQ BOUNDS (PARSE.BOUNDS))
-                  (SELECTQ PARSE.ATOM
-                      (%] (SETQ KIND 'OC))
-                      (%) (SETQ KIND 'OO))
-                      (SHOULDNT))
-                  (PARSE.BIN))
-              (SHOULDNT))
-          (SETQ ANSWER (create MINTERVAL
-                              KIND _ KIND
-                              BOUNDS _ BOUNDS))
-          (RETURN ANSWER])
-
-(PARSE.TYPEEXP.HERE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    NIL])
-
-(PARSE.TYPEEXP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ANSWER)                                           (* (typeexp id) (typeexp typeid)
-                                                             (typeexp typecons))
-          [COND
-             [(EQ PARSE.CLASS 'ID)
-              (SETQ ANSWER (PARSE.BIN))
-              [COND
-                 ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW))
-                  (SETQ ANSWER (PARSE.TYPEID.CONT ANSWER)))
-                 (T (SETQ ANSWER (BUILD.TYPEID NIL ANSWER]
-              (COND
-                 ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW))
-                  (SETQ ANSWER (PARSE.TYPECONS.CONT ANSWER]
-             (T (SETQ ANSWER (PARSE.TYPECONS]
-          (RETURN ANSWER])
-
-(PARSE.RANGE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TYPE INTERVAL ANSWER)                             (* (range id) (range id interval)
-                                                             (range typeid interval)
-                                                             (range interval) (range typeid) *)
-          [COND
-             ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST)
-              (SETQ TYPE 'CARDINAL)
-              (SETQ INTERVAL (PARSE.INTERVAL)))
-             ((FMEMB PARSE.ATOM2 PARSE.RANGE.FOLLOW)
-          
-          (* This case occurs if TYPE itself is a range type.
-          *)
-
-              [SETQ TYPE (BUILD.TYPEID NIL (PARSE.BIN 'ID]
-              (RETURN TYPE))
-             ((FMEMB PARSE.ATOM2 PARSE.INTERVAL.FIRST)
-              [SETQ TYPE (BUILD.TYPEID NIL (PARSE.BIN 'ID]
-              (SETQ INTERVAL (PARSE.INTERVAL)))
-             (T (SETQ TYPE (PARSE.TYPEID))
-                (COND
-                   ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST)
-                    (SETQ INTERVAL (PARSE.INTERVAL]
-          (SETQ ANSWER (create MRANGE
-                              TYPE _ TYPE
-                              INTERVAL _ INTERVAL))
-          (RETURN ANSWER])
-
-(PARSE.TYPEAPPL
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG NIL                                                (* (typeappl typeappl %.
-                                                             id) (typeappl id length)
-                                                             (typeappl typeid length)
-                                                             (typeappl typeappl length) *)
-          (BREAK1 NIL T])
-
-(PARSE.TYPEAPPL.CONT
-  [LAMBDA (TYPEAPPL)                                         (* kbr%: "25-Nov-85 12:47")
-    (PROG (ID LENGTH ANSWER)
-          (SETQ ANSWER TYPEAPPL)
-          [while (FMEMB PARSE.ATOM '(%. %[)) do (COND
-                                                   ((EQ PARSE.ATOM '%.)
-                                                    (PARSE.BIN)
-                                                    (SETQ ID (PARSE.BIN 'ID))
-                                                    (SETQ ANSWER (LIST ANSWER ID)))
-                                                   (T (SETQ LENGTH (PARSE.LENGTH))
-                                                      (SETQ ANSWER (LIST ANSWER LENGTH]
-          (RETURN ANSWER])
-
-(PARSE.TYPEID
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PARSE.TYPEID.CONT (PARSE.BIN 'ID])
-
-(PARSE.TYPEID.CONT
-  [LAMBDA (ID)                                               (* kbr%: "25-Nov-85 12:47")
-    (PROG (INTERFACE ANSWER)                                 (* (typeid' id %. id)
-                                                             (typeid' typeid' %. id)
-                                                             (typeid id id) (typeid id typeid)
-                                                             (typeid typeid') *)
-                                                             (* Should be ID+{.ID}* *)
-          (while (EQ PARSE.CLASS 'ID) do (BREAK1 NIL T)
-                                         (SETQ ID (PARSE.BIN)))
-          [COND
-             ((EQ PARSE.ATOM '%.)
-              (SETQ INTERFACE ID)
-              (PARSE.BIN)
-              (SETQ ID (PARSE.BIN 'ID]
-          (SETQ ANSWER (BUILD.TYPEID INTERFACE ID))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (COND
-       ((EQ PARSE.CLASS 'ID)
-        (PARSE.TYPECONS1))
-       (T (PARSE.TYPECONS2])
-
-(PARSE.TYPECONS1
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* TYPECONS begining with ID token.
-                                                             *)
-    (PROG (TYPEID ANSWER)                                    (* BOTH (typecons id interval)
-                                                             (typecons typeid interval)
-                                                             (typecons id RELATIVE typeexp)
-                                                             (typecons typeid RELATIVE typeexp)
-                                                             (typecons typeappl) *)
-                                                             (* CEDAR (typecons id PAINTED typeexp)
-                                                             (typecons typeid PAINTED typeexp) *)
-                                                             (* Get id or typeid.
-                                                             *)
-          (SETQ TYPEID (PARSE.BIN 'ID))
-          [COND
-             ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW))
-              (SETQ TYPEID (PARSE.TYPEID.CONT TYPEID)))
-             (T (SETQ TYPEID (BUILD.TYPEID NIL TYPEID]       (* Finish typecons. *)
-          (SETQ ANSWER (PARSE.TYPECONS.CONT TYPEID))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.CONT
-  [LAMBDA (TYPEID)                                           (* kbr%: "25-Nov-85 12:47")
-                                                             (* ; 
-                                                       "TYPEID is an id or typeid.  Finish typecons.")
-    (PROG (INTERVAL TYPEEXP EXP1 EXP2 KIND ANSWER)
-          
-          (* ;; "BOTH (typecons id interval) (typecons typeid interval) (typecons id RELATIVE typeexp) (typecons typeid RELATIVE typeexp) (typecons typeappl) ")
-          
-          (* ;; "CEDAR (typecons id PAINTED typeexp) (typecons typeid PAINTED typeexp) *")
-
-          (COND
-             ((EQ PARSE.ATOM 'RELATIVE)
-              (SETQ ANSWER (PARSE.TYPECONS.RELATIVE)))
-             ((EQ PARSE.ATOM 'PAINTED)
-              (SETQ ANSWER (PARSE.TYPECONS.PAINTED)))
-             ((EQ PARSE.ATOM '%()
-              (PARSE.TYPECONS.RANGE TYPEID))
-             [(EQ PARSE.ATOM '%[)                            (* ; 
-         "This can be the start of a length or of an interval.  Can't tell with bounded look ahead. ")
-              (PARSE.BIN '%[)
-              (SETQ EXP1 (PARSE.EXP))
-              (COND
-                 ((EQ PARSE.ATOM '|..|)                      (* ; "Interval. ")
-                  (PARSE.BIN '|..|)
-                  (SETQ EXP2 (PARSE.EXP))
-                  [COND
-                     ((EQ PARSE.ATOM '%))
-                      (PARSE.BIN '%))
-                      (SETQ KIND 'CO))
-                     (T (PARSE.BIN '%])
-                        (SETQ KIND 'CC]
-                  (SETQ INTERVAL (create MINTERVAL
-                                        KIND _ KIND
-                                        BOUNDS _ (LIST EXP1 EXP2)))
-                  (SETQ ANSWER (create MRANGE
-                                      TYPE _ TYPEID
-                                      INTERVAL _ INTERVAL)))
-                 (T                                          (* ; "Length.  *")
-                    (PARSE.BIN '%])
-                    (SETQ ANSWER (LIST TYPEID EXP1))
-                    (SETQ ANSWER (PARSE.TYPEAPPL.CONT ANSWER]
-             (T (SHOULDNT)))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.RANGE
-  [LAMBDA (TYPEID)                                           (* kbr%: "25-Nov-85 12:47")
-    (PROG (INTERVAL ANSWER)
-          (SETQ INTERVAL (PARSE.INTERVAL))
-          (SETQ ANSWER (create MRANGE
-                              TYPE _ TYPEID
-                              INTERVAL _ INTERVAL))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.RELATIVE
-  [LAMBDA (TYPEID)                                           (* kbr%: "25-Nov-85 12:47")
-    (PROG (TYPE ANSWER)
-          (PARSE.BIN 'RELATIVE)
-          (SETQ TYPE (PARSE.TYPEEXP))
-          (SETQ ANSWER (create MRELATIVE
-                              TYPEID _ TYPEID
-                              TYPE _ TYPE))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.PAINTED
-  [LAMBDA (TYPEID)                                           (* kbr%: "25-Nov-85 12:47")
-    (PROG (TYPE ANSWER)
-          (PARSE.THISIS.CEDAR)
-          (PARSE.BIN 'RELATIVE)
-          (SETQ TYPE (PARSE.TYPEEXP))
-          (SETQ ANSWER (create MPAINTED
-                              TYPEID _ TYPEID
-                              TYPE _ TYPE))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS2
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* TYPECONS begining with reserved 
-                                                             word. *)
-    (PROG (ANSWER)
-          
-          (* BOTH (typecons interval) (typecons dependent { elementlist })
-          (typecons dependent monitored RECORD reclist)
-          (typecons ordered base pointertype) (typecons VAR typeexp)
-          (typecons packed ARRAY indextype OF typeexp)
-          (typecons DESCRIPTOR FOR readonly typeexp)
-          (typecons safe transfermode arguments) (typecons heap ZONE)
-          (typecons LONG typeexp) (typecons FRAME %[ id %]) *)
-                                                             (* CEDAR (typecons REF readonly 
-                                                             typeexp) (typecons REF readonly ANY)
-                                                             (typecons REF) (typecons LIST OF 
-                                                             readonly typeexp) *)
-          [SETQ ANSWER (COND
-                          ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST)
-                           (PARSE.TYPECONS.INTERVAL))
-                          (T (SELECTQ PARSE.ATOM
-                                 ((MACHINE MONITORED RECORD {) 
-                                      (PARSE.TYPECONS.DEPENDENT))
-                                 ((ORDERED BASE POINTER) 
-                                      (PARSE.TYPECONS.ORDERED))
-                                 (VAR (PARSE.TYPECONS.VAR))
-                                 ((PACKED ARRAY) 
-                                      (PARSE.TYPECONS.PACKED))
-                                 (DESCRIPTOR (PARSE.TYPECONS.DESCRIPTOR))
-                                 ((SAFE ERROR PORT PROC PROCEDURE PROCESS PROGRAM SIGNAL) 
-                                      (PARSE.TYPECONS.SAFE))
-                                 (UNCOUNTED (PARSE.TYPECONS.HEAP))
-                                 (LONG (PARSE.TYPECONS.LONG))
-                                 (FRAME (PARSE.TYPECONS.FRAME))
-                                 (REF (PARSE.TYPECONS.REF))
-                                 (LIST (PARSE.TYPECONS.LIST))
-                                 (SHOULDNT]
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.INTERVAL
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ANSWER)                                           (* (typecons interval) *)
-          (SETQ ANSWER (create MRANGE
-                              TYPE _ 'CARDINAL
-                              INTERVAL _ (PARSE.INTERVAL)))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.DEPENDENT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ELEMENTLIST RECLIST ANSWER)                       (* (typecons dependent { elementlist })
-                                                             (typecons dependent monitored RECORD 
-                                                             reclist) *)
-          (PARSE.DEPENDENT)
-          [SETQ ANSWER (COND
-                          ((EQ PARSE.ATOM '{)
-                           (PARSE.TYPECONS.ENUMERATED))
-                          (T (PARSE.TYPECONS.RECORD]
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.ENUMERATED
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ITEMS ANSWER)
-          (PARSE.BIN)
-          (SETQ ITEMS (PARSE.ELEMENTLIST))
-          (PARSE.BIN '})
-          (SETQ ANSWER (create MENUMERATED
-                              ITEMS _ ITEMS))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.RECORD
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (FIELDLIST ANSWER)
-          (PARSE.MONITORED)
-          (PARSE.BIN 'RECORD)
-          (SETQ FIELDLIST (PARSE.RECLIST))
-          (SETQ ANSWER (create MRECORD
-                              FIELDLIST _ FIELDLIST))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.ORDERED
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ANSWER)                                           (* (typecons ordered base pointertype) 
-                                                             *)
-          (PARSE.ORDERED)
-          (PARSE.BASE)
-          (SETQ ANSWER (PARSE.POINTERTYPE))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.VAR
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TYPE ANSWER)                                      (* (typecons VAR typeexp) *)
-          (PARSE.BIN 'VAR)
-          (SETQ TYPE (PARSE.TYPEEXP))
-          (SETQ ANSWER (create MVAR
-                              TYPE _ TYPE))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.PACKED
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (PACKED INDEXTYPE TYPE ANSWER)                     (* (typecons packed ARRAY indextype OF 
-                                                             typeexp) *)
-          (SETQ PACKED (PARSE.PACKED))
-          (PARSE.BIN 'ARRAY)
-          (SETQ INDEXTYPE (PARSE.INDEXTYPE))
-          (PARSE.BIN 'OF)
-          (SETQ TYPE (PARSE.TYPEEXP))
-          (SETQ ANSWER (create MARRAY
-                              INDEXTYPE _ INDEXTYPE
-                              TYPE _ TYPE))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.DESCRIPTOR
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TYPE ANSWER)                                      (* (typecons DESCRIPTOR FOR readonly 
-                                                             typeexp) *)
-          (PARSE.BIN 'DESCRIPTOR)
-          (PARSE.BIN 'FOR)
-          (PARSE.READONLY)
-          (SETQ TYPE (PARSE.TYPEEXP))
-          (SETQ ANSWER (create MDESCRIPTOR
-                              TYPE _ TYPE))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.SAFE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TRANSFERMODE)                                     (* (typecons safe transfermode 
-                                                             arguments) *)
-          (PARSE.SAFE)
-          (SETQ TRANSFERMODE (PARSE.TRANSFERMODE))
-          (PARSE.ARGUMENTS)
-          (RETURN TRANSFERMODE])
-
-(PARSE.TYPECONS.HEAP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG NIL                                                (* (typecons heap ZONE) *)
-          (PARSE.HEAP)
-          (PARSE.BIN 'ZONE)
-          (RETURN 'ZONE])
-
-(PARSE.TYPECONS.LONG
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ANSWER)                                           (* (typecons LONG typeexp) *)
-          (PARSE.BIN 'LONG)
-          (SETQ ANSWER (PARSE.TYPEEXP))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.FRAME
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ID ANSWER)                                        (* (typecons FRAME %[ id %]) *)
-          (PARSE.BIN 'FRAME)
-          (PARSE.BIN '%[)
-          [SETQ ID (BUILD.ID NIL (PARSE.BIN 'ID]
-          (PARSE.BIN '%])
-          (SETQ ANSWER (create MFRAME
-                              ID _ ID))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.REF
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TYPE ANSWER)                                      (* CEDAR (typecons REF readonly 
-                                                             typeexp) (typecons REF readonly ANY)
-                                                             (typecons REF) *)
-          (PARSE.THISIS.CEDAR)
-          (PARSE.BIN 'REF)
-          [COND
-             ((FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW)
-              (SETQ TYPE 'ANY))
-             (T (PARSE.READONLY)
-                (COND
-                   ((EQ PARSE.ATOM 'ANY)
-                    (PARSE.BIN)
-                    (SETQ TYPE 'ANY))
-                   (T (SETQ TYPE (PARSE.TYPEEXP]
-          (SETQ ANSWER (create MREF
-                              TYPE _ TYPE))
-          (RETURN ANSWER])
-
-(PARSE.TYPECONS.LIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TYPE ANSWER)                                      (* CEDAR (typecons LIST OF readonly 
-                                                             typeexp) *)
-          (PARSE.THISIS.CEDAR)
-          (PARSE.BIN 'LIST)
-          (PARSE.BIN 'OF)
-          (PARSE.READONLY)
-          (SETQ TYPE (PARSE.TYPEEXP))
-          (SETQ ANSWER (create MLIST
-                              TYPE _ TYPE))
-          (RETURN ANSWER])
-
-(PARSE.IDENT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ID)                                               (* (ident id position %:)
-                                                             (ident id %:) *)
-          (SETQ ID (PARSE.BIN 'ID))
-          [COND
-             ((EQ PARSE.ATOM '%:)
-              (PARSE.BIN))
-             (T (PARSE.POSITION)
-                (PARSE.BIN '%:]
-          (RETURN ID])
-
-(PARSE.ELEMENT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ID EXP ANSWER)                                    (* (element id %( exp %))
-                                                             (element %( exp %)) (element id) *)
-          [COND
-             ((NOT (EQ PARSE.ATOM '%())
-              (SETQ ID (PARSE.BIN 'ID]
-          (COND
-             ((EQ PARSE.ATOM '%()
-              (PARSE.BIN)
-              (SETQ EXP (PARSE.EXP))
-              (SETQ ANSWER ID)
-              (PARSE.BIN '%)))
-             (T (SETQ ANSWER ID)))
-          (RETURN ANSWER])
-
-(PARSE.MONITORED
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (monitored MONITORED)
-                                                             (monitored) *)
-    (COND
-       ((EQ PARSE.ATOM 'MONITORED)
-        (PARSE.BIN])
-
-(PARSE.DEPENDENT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (dependent MACHINE DEPENDENT)
-                                                             (dependent) *)
-    (COND
-       ((EQ PARSE.ATOM 'MACHINE)
-        (PARSE.BIN)
-        (PARSE.BIN 'DEPENDENT)
-        'MACHINE.DEPENDENT])
-
-(PARSE.RECLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (PAIRLIST TYPELIST VARIANTPAIR VARIANTPART DEFAULT ANSWER)
-                                                             (* (reclist %[ %]) (reclist NULL)
-                                                             (reclist %[ pairlist %])
-                                                             (reclist %[ typelist %])
-                                                             (reclist %[ pairlist %, variantpair %])
-                                                             (reclist %[ variantpart default %])
-                                                             (reclist %[ variantpair %]) *)
-          (COND
-             ((EQ PARSE.ATOM 'NULL)
-              (PARSE.BIN)
-              (RETURN NIL)))
-          (PARSE.BIN '%[)
-          (COND
-             ((EQ PARSE.ATOM '%])
-              (PARSE.BIN)
-              (RETURN NIL)))
-          (COND
-             [(FMEMB PARSE.ATOM PARSE.VARIANTPART.FIRST)
-              (SETQ VARIANTPART (PARSE.VARIANTPART))
-              (SETQ DEFAULT (PARSE.DEFAULT))
-              (SETQ ANSWER (LIST (create PAIRITEM
-                                        TYPEEXP _ VARIANTPART
-                                        DEFAULT _ DEFAULT]
-             ([AND (EQ PARSE.CLASS 'ID)
-                   (NOT (FMEMB PARSE.ATOM PARSE.PREDEFINED.TYPES))
-                   (FMEMB PARSE.ATOM2 '(%( %, %:]
-              (SETQ PAIRLIST (PARSE.PAIRLIST 'RECLIST))
-              [for PAIRITEM in (fetch (PAIRLIST ITEMS) of PAIRLIST)
-                 do (replace (PAIRITEM ID) of PAIRITEM with (BUILD.FIELDID NIL (fetch (PAIRITEM
-                                                                                       ID)
-                                                                                  of PAIRITEM]
-              (SETQ ANSWER PAIRLIST))
-             (T (SETQ TYPELIST (PARSE.TYPELIST))
-                (SETQ ANSWER TYPELIST)))
-          (PARSE.BIN '%])
-          (RETURN ANSWER])
-
-(PARSE.VARIANTPAIR
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (IDENTLIST PUBLIC VARIANTPART DEFAULT ANSWER)      (* (variantpair identlist public 
-                                                             variantpart default) *)
-          (SETQ IDENTLIST (PARSE.IDENTLIST))
-          (PARSE.PUBLIC)
-          (SETQ VARIANTPART (PARSE.VARIANTPART))
-          (SETQ DEFAULT (PARSE.DEFAULT))
-          (SETQ ANSWER (for ID in IDENTLIST
-                          collect (create PAIRITEM
-                                         ID _ ID
-                                         TYPEEXP _ VARIANTPART
-                                         DEFAULT _ DEFAULT)))
-          (RETURN ANSWER])
-
-(PARSE.PAIRITEM
-  [LAMBDA (KIND)                                             (* kbr%: "25-Nov-85 12:47")
-    (PROG (IDENTLIST VARIANTPART TYPEEXP DEFAULT ANSWER)     (* (pairitem identlist public typeexp 
-                                                             default) (variantpair identlist public 
-                                                             variantpart default) *)
-          (SETQ IDENTLIST (PARSE.IDENTLIST KIND))
-          (COND
-             ((type? TYPELIST IDENTLIST)
-          
-          (* Thought we we're parsing a pairlist but found a typelist.
-          *)
-
-              (RETURN IDENTLIST)))
-          (PARSE.PUBLIC)
-          [COND
-             ([AND (FMEMB PARSE.ATOM PARSE.VARIANTPART.FIRST)
-                   (OR (NOT (EQ PARSE.ATOM 'PACKED))
-                       (NOT (EQ PARSE.ATOM2 'ARRAY]          (* Variantpair. *)
-              (COND
-                 ((NOT (EQ KIND 'RECLIST))
-                  (SHOULDNT)))
-              (SETQ TYPEEXP (PARSE.VARIANTPART)))
-             (T                                              (* Typeexp. *)
-                (SETQ TYPEEXP (PARSE.TYPEEXP]
-          (SETQ DEFAULT (PARSE.DEFAULT))
-          (SETQ ANSWER (for ID in IDENTLIST
-                          collect (create PAIRITEM
-                                         ID _ ID
-                                         TYPEEXP _ TYPEEXP
-                                         DEFAULT _ DEFAULT)))
-          (RETURN ANSWER])
-
-(PARSE.DEFAULTOPT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (EXP TRASH ANSWER)                                 (* (defaultopt TRASH)
-                                                             (defaultopt NULL) (defaultopt exp %| 
-                                                             TRASH) (defaultopt exp %| NULL)
-                                                             (defaultopt) (defaultopt exp) *)
-          [COND
-             ((FMEMB PARSE.ATOM '(TRASH NULL))
-              (PARSE.BIN)
-              (SETQ TRASH T))
-             ((NOT (FMEMB PARSE.ATOM PARSE.DEFAULTOPT.FOLLOW))
-              (SETQ EXP (PARSE.EXP))
-              (COND
-                 ((EQ PARSE.ATOM '%|)
-                  (PARSE.BIN '%|)
-                  (COND
-                     ((FMEMB PARSE.ATOM '(TRASH NULL))
-                      (PARSE.BIN)
-                      (SETQ TRASH T]
-          (SETQ ANSWER (create DEFAULT
-                              EXP _ EXP
-                              TRASH _ TRASH))
-          (RETURN ANSWER])
-
-(PARSE.VARIANTPART
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (VCASEHEAD VARIANTLIST TYPEEXP ANSWER)             (* (variantpart SELECT vcasehead FROM 
-                                                             variantlist ENDCASE)
-                                                             (variantpart SELECT vcasehead FROM 
-                                                             variantlist %, ENDCASE)
-                                                             (variantpart packed SEQUENCE vcasehead 
-                                                             OF typeexp) *)
-          [COND
-             ((EQ PARSE.ATOM 'SELECT)
-              (PARSE.BIN)
-              (SETQ VCASEHEAD (PARSE.VCASEHEAD))
-              (PARSE.BIN 'FROM)
-              (SETQ VARIANTLIST (PARSE.VARIANTLIST))
-              (COND
-                 ((EQ PARSE.ATOM '%,)
-                  (PARSE.BIN)))
-              (PARSE.BIN 'ENDCASE)
-              (SETQ ANSWER (LIST 'SELECT VCASEHEAD VARIANTLIST)))
-             (T (SETQ PACKED (PARSE.PACKED))
-                (PARSE.BIN 'SEQUENCE)
-                (SETQ VCASEHEAD (PARSE.VCASEHEAD))
-                (PARSE.BIN 'OF)
-                (SETQ TYPEEXP (PARSE.TYPEEXP))
-                (SETQ ANSWER (LIST 'SEQUENCE VCASEHEAD TYPEEXP]
-          (RETURN ANSWER])
-
-(PARSE.VCASEHEAD
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (IDENT PUBLIC TAGTYPE ANSWER)                      (* (vcasehead ident public tagtype)
-                                                             (vcasehead COMPUTED tagtype)
-                                                             (vcasehead OVERLAID tagtype) *)
-          [COND
-             ([NOT (FMEMB PARSE.ATOM '(COMPUTED OVERLAID]
-              (SETQ IDENT (PARSE.IDENT))
-              (SETQ PUBLIC (PARSE.PUBLIC))
-              (SETQ TAGTYPE (PARSE.TAGTYPE))
-              (SETQ ANSWER (LIST 'vcasehead IDENT PUBLIC TAGTYPE)))
-             (T (SETQ ANSWER (LIST 'vcasehead (PARSE.BIN)
-                                   (PARSE.TAGTYPE]
-          (RETURN ANSWER])
-
-(PARSE.TAGTYPE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (tagtype *) (tagtype typeexp) *)
-    (COND
-       ((EQ PARSE.ATOM '*)
-        (PARSE.BIN))
-       (T (PARSE.TYPEEXP])
-
-(PARSE.VARIANTITEM
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (IDLIST RECLIST ANSWER)                            (* (variantitem idlist => reclist) *)
-          (SETQ IDLIST (PARSE.IDLIST))
-          (PARSE.BIN '=>)
-          (SETQ RECLIST (PARSE.RECLIST))
-          (SETQ ANSWER (LIST 'variantitem IDLIST RECLIST))
-          (RETURN ANSWER])
-
-(PARSE.TYPELIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TYPEITEMS ANSWER)                                 (* (typelist typecons default)
-                                                             (typelist typeid default)
-                                                             (typelist id) (typelist id _ 
-                                                             defaultopt) (typelist typecons default 
-                                                             %, typelist) (typelist typeid default 
-                                                             %, typelist) (typelist id %, typelist)
-                                                             (typelist id _ defaultopt %, typelist) 
-                                                             *)
-          (push TYPEITEMS (PARSE.TYPEITEM))
-          (while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (push TYPEITEMS (PARSE.TYPEITEM)))
-          (SETQ ANSWER (create TYPELIST
-                              ITEMS _ (DREVERSE TYPEITEMS)))
-          (RETURN ANSWER])
-
-(PARSE.TYPEITEM
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TYPEEXP DEFAULT ANSWER)
-          (SETQ TYPEEXP (PARSE.TYPEEXP))
-          [COND
-             ((NOT (LITATOM TYPEEXP))
-              (SETQ DEFAULT (PARSE.DEFAULT)))
-             ((EQ PARSE.ATOM '_)
-              (SETQ DEFAULT (PARSE.DEFAULTOPT]
-          (SETQ ANSWER (create TYPEITEM
-                              TYPEEXP _ TYPEEXP
-                              DEFAULT _ DEFAULT))
-          (RETURN ANSWER])
-
-(PARSE.POINTERTYPE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TYPE ANSWER)                                      (* (pointertype pointerprefix)
-                                                             (pointertype pointerprefix TO readonly 
-                                                             typeexp) *)
-          (PARSE.POINTERPREFIX)
-          [COND
-             ((EQ PARSE.ATOM 'TO)
-              (PARSE.BIN)
-              (PARSE.READONLY)
-              (SETQ TYPE (PARSE.TYPEEXP)))
-             (T (SETQ TYPE 'UNSPECIFIED]
-          (SETQ ANSWER (create MPOINTER
-                              TYPE _ TYPE))
-          (RETURN ANSWER])
-
-(PARSE.TRANSFERMODE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (transfermode PROCEDURE)
-                                                             (transfermode PROC) (transfermode PORT)
-                                                             (transfermode SIGNAL)
-                                                             (transfermode ERROR)
-                                                             (transfermode PROCESS)
-                                                             (transfermode PROGRAM) *)
-    (PROG NIL
-          (PARSE.BIN)
-          (RETURN 'PROC])
-
-(PARSE.INITIALIZATION
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ANSWER)                                           (* (initialization) (initialization _ 
-                                                             initvalue) (initialization tilde 
-                                                             initvalue) *)
-                                                             (* In MESA tilde must be =.
-                                                             *)
-          [COND
-             ([OR (FMEMB PARSE.ATOM '(_ =))
-                  (AND (EQ PARSE.LANGUAGE 'CEDAR)
-                       (EQ PARSE.ATOM '~]
-              (PARSE.BIN)
-              (SETQ ANSWER (PARSE.INITVALUE]
-          (RETURN ANSWER])
-
-(PARSE.INITVALUE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (INLINE BLOCK CODELIST EXP ANSWER)                 (* (initvalue procaccess trusted 
-                                                             checked inline block)
-                                                             (initvalue CODE) (initvalue procaccess 
-                                                             trusted checked MACHINE CODE BEGIN 
-                                                             codelist END) (initvalue procaccess 
-                                                             trusted checked MACHINE CODE { 
-                                                             codelist }) (initvalue TRASH)
-                                                             (initvalue NULL) (initvalue exp) *)
-          [COND
-             ((FMEMB PARSE.ATOM '(CODE TRASH NULL))
-              (PARSE.BIN)
-              (SETQ ANSWER 'TRASH))
-             (T (PARSE.CHECKED)
-                (COND
-                   ((FMEMB PARSE.ATOM '(INLINE BEGIN {))
-                    (SETQ INLINE (PARSE.INLINE))
-                    (SETQ BLOCK (PARSE.BLOCK))
-                    (SETQ ANSWER BLOCK))
-                   ((EQ PARSE.ATOM 'MACHINE)
-                    (PARSE.BIN)
-                    (PARSE.BIN 'CODE)
-                    (PARSE.BIN '(BEGIN {))
-                    (SETQ CODELIST (PARSE.CODELIST))
-                    (PARSE.BIN '(END }))
-                    (SETQ ANSWER CODELIST))
-                   (T (SETQ EXP (PARSE.EXP))
-                      (SETQ ANSWER EXP]
-          (RETURN ANSWER])
-
-(PARSE.CHECKED
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* BOTH (checked) *)
-                                                             (* CEDAR (checked CHECKED)
-                                                             (checked TRUSTED) (checked UNCHECKED) 
-                                                             *)
-    (COND
-       ((FMEMB PARSE.ATOM '(CHECKED TRUSTED UNCHECKED))
-        (PARSE.THISIS.CEDAR)
-        (PARSE.BIN])
-
-(PARSE.CODELIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG NIL                                                (* (codelist orderlist)
-                                                             (codelist codelist ;
-                                                             orderlist) *)
-          (BREAK1 NIL T])
-
-(PARSE.STATEMENT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (COND
-       ((FMEMB PARSE.CLASS '(ID %())
-        (PARSE.STATEMENT1))
-       (T (PARSE.STATEMENT2])
-
-(PARSE.STATEMENT1
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (LHS EXP OPTCATCH ANSWER)                          (* (statement lhs) (statement lhs _ 
-                                                             exp) (statement free %[ exp optcatch 
-                                                             %]) (statement lhs _ STATE) *)
-          (SETQ LHS (PARSE.LHS))
-          (COND
-             ((AND (EQ PARSE.ATOM '%.)
-                   (EQ PARSE.ATOM2 'FREE))
-              (PARSE.BIN)
-              (PARSE.BIN)
-              (PARSE.BIN '%[)
-              (SETQ EXP (PARSE.EXP))
-              (SETQ OPTCATCH (PARSE.OPTCATCH))
-              (PARSE.BIN '%])
-              (SETQ ANSWER (LIST LHS EXP OPTCATCH)))
-             ((AND (EQ PARSE.ATOM '_)
-                   (EQ PARSE.ATOM2 'STATE))
-              (PARSE.BIN)
-              (PARSE.BIN)
-              (SETQ ANSWER LHS))
-             ((EQ PARSE.ATOM '_)
-              (PARSE.BIN)
-              (SETQ EXP (PARSE.EXP))
-              (SETQ ANSWER (BUILD.SETQ LHS EXP)))
-             (T (SETQ ANSWER LHS)))
-          (RETURN ANSWER])
-
-(PARSE.STATEMENT2
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ANSWER)
-          
-          (* (statement %[ explist %] _ exp) (statement trusted checked block)
-          (statement IF exp THEN statement elsepart)
-          (statement casehead casestmtlist ENDCASE otherpart)
-          (statement forclause dotest DO scope doexit ENDLOOP)
-          (statement EXIT) (statement LOOP) (statement GOTO id)
-          (statement GO TO id) (statement RETURN optargs)
-          (statement transfer lhs) (statement WAIT lhs)
-          (statement ERROR) (statement STOP) (statement NULL)
-          (statement RESUME optargs) (statement REJECT)
-          (statement CONTINUE) (statement RETRY) *)
-
-          [SETQ ANSWER (COND
-                          ((FMEMB PARSE.ATOM PARSE.CASEHEAD.FIRST)
-                           (PARSE.STATEMENT.CASEHEAD))
-                          ((OR (FMEMB PARSE.ATOM PARSE.FORCLAUSE.FIRST)
-                               (FMEMB PARSE.ATOM PARSE.DOTEST.FIRST)
-                               (EQ PARSE.ATOM 'DO))
-                           (PARSE.STATEMENT.FORCLAUSE))
-                          ([AND (EQ PARSE.ATOM 'RETURN)
-                                (NOT (EQ PARSE.ATOM2 'WITH]
-          
-          (* Don't confuse statement RETURN with the transfer RETURN WITH.
-          *)
-
-                           (PARSE.STATEMENT.RETURN))
-                          ((FMEMB PARSE.ATOM PARSE.TRANSFER.FIRST)
-                           (PARSE.STATEMENT.TRANSFER))
-                          (T (SELECTQ PARSE.ATOM
-                                 (%[ (PARSE.STATEMENT.LBRACKET))
-                                 (({ BEGIN CHECKED TRUSTED UNCHECKED) 
-                                      (PARSE.CHECKED)
-                                      (PARSE.BLOCK))
-                                 (IF (PARSE.STATEMENT.IF))
-                                 (EXIT (PARSE.BIN)
-                                       '(RETURN))
-                                 (LOOP (PARSE.BIN)
-                                       '(GO LOOP))
-                                 (GOTO (PARSE.BIN)
-                                       (LIST 'GO (PARSE.BIN 'ID)))
-                                 (GO (PARSE.BIN)
-                                     (PARSE.BIN 'TO)
-                                     (LIST 'GO (PARSE.BIN 'ID)))
-                                 (WAIT (PARSE.BIN)
-                                       (PARSE.LHS))
-                                 (ERROR (PARSE.BIN)
-                                        '(SHOULDNT))
-                                 (STOP (PARSE.BIN)
-                                       '(GO STOP))
-                                 (NULL (PARSE.BIN)
-                                       NIL)
-                                 (RESUME (PARSE.BIN)
-                                         (PARSE.OPTARGS))
-                                 (REJECT (PARSE.BIN)
-                                         '(SHOULDNT))
-                                 (CONTINUE (PARSE.BIN)
-                                           '(GO CONTINUE))
-                                 (RETRY (PARSE.BIN)
-                                        '(GO RETRY))
-                                 (SHOULDNT]
-          (RETURN ANSWER])
-
-(PARSE.STATEMENT.CASEHEAD
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (CASEHEAD CASESTMTLIST OTHERPART ANSWER)           (* (statement casehead casestmtlist 
-                                                             ENDCASE otherpart) *)
-          (BUILD.PUSH.SCOPE)
-          (SETQ CASEHEAD (PARSE.CASEHEAD))
-          (SETQ CASESTMTLIST (PARSE.CASESTMTLIST CASEHEAD))
-          (PARSE.BIN 'ENDCASE)
-          (SETQ OTHERPART (PARSE.OTHERPART))
-          (SETQ ANSWER (BUILD.SELECTQ CASEHEAD CASESTMTLIST OTHERPART))
-          (COND
-             ((fetch (CASEHEAD ID) of CASEHEAD)
-              (BUILD.INITIALIZE.VAR (fetch (CASEHEAD ID) of CASEHEAD)
-                     NIL
-                     (fetch (CASEHEAD EXP) of CASEHEAD)
-                     BUILD.CURRENT.SCOPE)))
-          (SETQ ANSWER (BUILD.PROG (LIST ANSWER)))
-          (BUILD.POP.SCOPE)
-          (RETURN ANSWER])
-
-(PARSE.STATEMENT.FORCLAUSE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (FORCLAUSE DOTEST SCOPE DOEXIT EXITLIST STATEMENT ANSWER)
-                                                             (* (statement forclause dotest DO 
-                                                             scope doexit ENDLOOP) *)
-          (BUILD.STORE.IDENTLIST '(DO))
-          (BUILD.PUSH.SCOPE)
-          (SETQ FORCLAUSE (PARSE.FORCLAUSE))
-          (SETQ DOTEST (PARSE.DOTEST))
-          (PARSE.BIN 'DO)
-          (SETQ SCOPE (PARSE.SCOPE))
-          (SETQ DOEXIT (PARSE.DOEXIT))
-          (SETQ EXITLIST (CAR DOEXIT))
-          (SETQ STATEMENT (CADR DOEXIT))
-          (PARSE.BIN 'ENDLOOP)
-          (BUILD.POP.SCOPE)
-          [SETQ ANSWER `(,@FORCLAUSE ,@DOTEST do ,@(BUILD.TAIL SCOPE]
-          [COND
-             (STATEMENT (SETQ ANSWER `(,@ANSWER finally ,@(BUILD.TAIL STATEMENT]
-          [COND
-             (EXITLIST (SETQ ANSWER (BUILD.PROGN (CONS ANSWER EXITLIST]
-          (RETURN ANSWER])
-
-(PARSE.STATEMENT.RETURN
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (OPTARGS ANSWER)                                   (* (statement RETURN optargs) *)
-          (PARSE.BIN 'RETURN)
-          (SETQ OPTARGS (PARSE.OPTARGS))
-          (SETQ ANSWER (BUILD.RETURN OPTARGS))
-          (RETURN ANSWER])
-
-(PARSE.STATEMENT.TRANSFER
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TRANSFER LHS ANSWER)                              (* (statement transfer lhs) *)
-          (SETQ TRANSFER (PARSE.TRANSFER))
-          (SETQ LHS (PARSE.LHS))
-          [SETQ ANSWER `(SHOULDNT ',LHS]
-          (RETURN ANSWER])
-
-(PARSE.STATEMENT.LBRACKET
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (EXPLIST EXP ANSWER)                               (* (statement %[ explist %] _ exp) *)
-          (PARSE.BIN '%[)
-          (SETQ EXPLIST (PARSE.EXPLIST))
-          (PARSE.BIN '%])
-          (PARSE.BIN '_)
-          (SETQ EXP (PARSE.EXP))
-          (SETQ ANSWER (BUILD.SETQ EXPLIST EXP))
-          (RETURN ANSWER])
-
-(PARSE.STATEMENT.IF
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (EXP STATEMENT ELSEPART HEAD TAIL ANSWER)          (* (statement IF exp THEN statement 
-                                                             elsepart) *)
-          (PARSE.BIN 'IF)
-          (SETQ EXP (PARSE.EXP))
-          (PARSE.BIN 'THEN)
-          (SETQ STATEMENT (PARSE.STATEMENT))
-          (SETQ ELSEPART (PARSE.ELSEPART))
-          (SETQ ANSWER (BUILD.COND EXP STATEMENT ELSEPART))
-          (RETURN ANSWER])
-
-(PARSE.BLOCK
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (SCOPE EXITS ANSWER)                               (* (block BEGIN scope exits END)
-                                                             (block { scope exits }) *)
-          (BUILD.PUSH.SCOPE)
-          (PARSE.BIN '(BEGIN {))
-          (SETQ SCOPE (PARSE.SCOPE))
-          (SETQ EXITS (PARSE.EXITS))
-          (PARSE.BIN '(END }))
-          (BUILD.POP.SCOPE)
-          (SETQ ANSWER (APPEND SCOPE EXITS))
-          (RETURN ANSWER])
-
-(PARSE.SCOPE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (STATEMENTLIST ANSWER)                             (* (scope open enables statementlist)
-                                                             (scope open enables declist ;
-                                                             statementlist) *)
-          (BUILD.STORE.OPEN (PARSE.OPEN))
-          (PARSE.ENABLES)
-          (COND
-             ([AND (EQ PARSE.CLASS 'ID)
-                   (FMEMB PARSE.ATOM2 '(%, %:]
-              (PARSE.DECLIST)))
-          (SETQ STATEMENTLIST (PARSE.STATEMENTLIST))
-          (SETQ ANSWER (BUILD.PROG STATEMENTLIST))
-          (RETURN ANSWER])
-
-(PARSE.BINDITEM
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ID EXP ANSWER)                                    (* BOTH (binditem exp)
-                                                             (binditem id %: exp) *)
-                                                             (* CEDAR (binditem id ~ ~ exp) *)
-          [COND
-             ((AND (EQ PARSE.CLASS 'ID)
-                   (EQ PARSE.ATOM2 '%:))
-              (SETQ ID (PARSE.BIN))
-              (PARSE.BIN))
-             ((AND (EQ PARSE.LANGUAGE 'CEDAR)
-                   (EQ PARSE.CLASS 'ID)
-                   (EQ PARSE.ATOM2 '~))
-              (SETQ ID (PARSE.BIN))
-              (PARSE.BIN)
-              (PARSE.BIN '~]
-          (SETQ EXP (PARSE.EXP))
-          (SETQ ANSWER (create BINDITEM
-                              ID _ ID
-                              EXP _ EXP))
-          (RETURN ANSWER])
-
-(PARSE.EXITS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (exits EXITS exitlist)
-                                                             (exits) *)
-    (COND
-       ((EQ PARSE.ATOM 'EXITS)
-        (PARSE.BIN)
-        (PARSE.EXITLIST])
-
-(PARSE.CASESTMTITEM
-  [LAMBDA (CASEHEAD)                                         (* kbr%: "25-Nov-85 12:47")
-    (PROG (CASELABEL STATEMENT ANSWER)                       (* (casestmtitem caselabel => 
-                                                             statement) *)
-          (SETQ CASELABEL (PARSE.CASELABEL))
-          (PARSE.BIN '=>)
-          (SETQ STATEMENT (PARSE.STATEMENT))
-          (SETQ ANSWER (CONS CASELABEL (BUILD.TAIL STATEMENT)))
-          (RETURN ANSWER])
-
-(PARSE.CASEEXPITEM
-  [LAMBDA (CASEHEAD)                                         (* kbr%: "25-Nov-85 12:47")
-    (PROG (CASELABEL EXP ANSWER)                             (* (caseexpitem caselabel => exp) *)
-          (SETQ CASELABEL (PARSE.CASELABEL))
-          (PARSE.BIN '=>)
-          (SETQ EXP (PARSE.EXP))
-          (SETQ ANSWER (CONS CASELABEL (BUILD.TAIL EXP)))
-          (RETURN ANSWER])
-
-(PARSE.EXITITEM
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (IDLIST STATEMENT ANSWER)                          (* (exititem idlist => statement) *)
-          (SETQ IDLIST (PARSE.IDLIST))
-          (PARSE.BIN '=>)
-          (SETQ STATEMENT (PARSE.STATEMENT))
-          [SETQ ANSWER (BUILD.PROGN (NCONC IDLIST (BUILD.TAIL STATEMENT]
-          (RETURN ANSWER])
-
-(PARSE.CASETEST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (OPTRELATION EXP ANSWER)                           (* (casetest optrelation)
-                                                             (casetest exp) *)
-          (COND
-             ((FMEMB PARSE.ATOM PARSE.OPTRELATION.FIRST)
-              (SETQ OPTRELATION (PARSE.OPTRELATION))
-              (SETQ ANSWER OPTRELATION))
-             (T (SETQ EXP (PARSE.EXP))
-                (SETQ ANSWER EXP)))
-          (RETURN ANSWER])
-
-(PARSE.CONTROLID
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ID TYPEEXP)                                       (* (controlid ident typeexp)
-                                                             (controlid id) *)
-          [COND
-             ((FMEMB PARSE.ATOM2 PARSE.CONTROLID.FOLLOW)
-              (SETQ ID (PARSE.BIN 'ID))
-              (SETQ TYPEEXP 'INTEGER))
-             (T (SETQ ID (PARSE.IDENT))
-                (SETQ TYPEEXP (PARSE.TYPEEXP]
-          (BUILD.INITIALIZE.VAR ID TYPEEXP NIL BUILD.CURRENT.SCOPE)
-          (RETURN ID])
-
-(PARSE.FORCLAUSE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (CONTROLID EXP1 EXP2 DIRECTION RANGE ANSWER)       (* (forclause FOR controlid _ exp %, 
-                                                             exp) (forclause FOR controlid 
-                                                             direction IN range) (forclause THROUGH 
-                                                             range) (forclause) *)
-          [COND
-             [(EQ PARSE.ATOM 'FOR)
-              (PARSE.BIN)
-              (SETQ CONTROLID (PARSE.CONTROLID))
-              (COND
-                 ((EQ PARSE.ATOM '_)
-                  (PARSE.BIN)
-                  (SETQ EXP1 (PARSE.EXP))
-                  (PARSE.BIN '%,)
-                  (SETQ EXP2 (PARSE.EXP))
-                  (SETQ ANSWER (BUILD.FORCLAUSE.BY CONTROLID EXP1 EXP2)))
-                 (T (SETQ DIRECTION (PARSE.DIRECTION))
-                    (PARSE.BIN 'IN)
-                    (SETQ RANGE (PARSE.RANGE))
-                    (SETQ ANSWER (BUILD.FORCLAUSE.IN CONTROLID DIRECTION RANGE]
-             ((EQ PARSE.ATOM 'THROUGH)
-              (PARSE.BIN)
-              (SETQ RANGE (PARSE.RANGE))
-              (SETQ ANSWER (BUILD.FORCLAUSE.THROUGH RANGE]
-          (RETURN ANSWER])
-
-(PARSE.DIRECTION
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (direction DECREASING)
-                                                             (direction) *)
-    (COND
-       ((EQ PARSE.ATOM 'DECREASING)
-        (PARSE.BIN])
-
-(PARSE.DOTEST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (dotest UNTIL exp)
-                                                             (dotest WHILE exp) (dotest) *)
-    (COND
-       ((EQ PARSE.ATOM 'UNTIL)
-        (PARSE.BIN)
-        (LIST 'until (PARSE.EXP)))
-       ((EQ PARSE.ATOM 'WHILE)
-        (PARSE.BIN)
-        (LIST 'while (PARSE.EXP])
-
-(PARSE.DOEXIT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (EXITLIST STATEMENT ANSWER)                        (* (doexit) (doexit REPEAT exitlist)
-                                                             (doexit REPEAT exitlist FINISHED => 
-                                                             statement) (doexit REPEAT exitlist 
-                                                             FINISHED => statement ;) *)
-          [COND
-             ((EQ PARSE.ATOM 'REPEAT)
-              (PARSE.BIN)
-              (SETQ EXITLIST (PARSE.EXITLIST))
-              (COND
-                 ((EQ PARSE.ATOM 'FINISHED)
-                  (PARSE.BIN)
-                  (PARSE.BIN '=>)
-                  (SETQ STATEMENT (PARSE.STATEMENT))
-                  (COND
-                     ((EQ PARSE.ATOM ';)
-                      (PARSE.BIN]
-          (SETQ ANSWER (LIST EXITLIST STATEMENT))
-          (RETURN ANSWER])
-
-(PARSE.ENABLES
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (CATCHCASE CATCHANY CATCHLIST ANSWER)              (* (enables ENABLE catchcase ;)
-                                                             (enables ENABLE catchany ;)
-                                                             (enables ENABLE BEGIN catchlist END ;)
-                                                             (enables ENABLE { catchlist } ;)
-                                                             (enables) *)
-          [COND
-             ((EQ PARSE.ATOM 'ENABLE)
-              (PARSE.BIN)
-              [COND
-                 ((EQ PARSE.ATOM 'ANY)
-                  (SETQ CATCHANY (PARSE.CATCHANY))
-                  (SETQ ANSWER (LIST CATCHANY)))
-                 ((FMEMB PARSE.ATOM '(BEGIN {))
-                  (PARSE.BIN)
-                  (SETQ CATCHLIST (PARSE.CATCHLIST))
-                  (PARSE.BIN '(END }))
-                  (SETQ ANSWER CATCHLIST))
-                 (T (SETQ CATCHCASE (PARSE.CATCHCASE))
-                    (SETQ ANSWER (LIST CATCHCASE]
-              (PARSE.BIN ';]
-          (RETURN ANSWER])
-
-(PARSE.CATCHLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (CATCHHEAD CATCHANY CATCHCASE ANSWER)              (* (catchlist catchhead)
-                                                             (catchlist catchhead catchcase)
-                                                             (catchlist catchhead catchany)
-                                                             (catchlist catchhead catchany ;) *)
-          (SETQ CATCHHEAD (PARSE.CATCHHEAD))
-          [COND
-             ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW)
-              (SETQ ANSWER CATCHHEAD))
-             [(EQ PARSE.ATOM 'ANY)
-              (SETQ CATCHANY (PARSE.CATCHANY))
-              (SETQ ANSWER (NCONC1 CATCHHEAD CATCHANY))
-              (COND
-                 ((EQ PARSE.ATOM ';)
-                  (PARSE.BIN]
-             (T (SETQ CATCHCASE (PARSE.CATCHCASE))
-                (SETQ ANSWER (NCONC1 CATCHHEAD CATCHCASE]
-          (RETURN ANSWER])
-
-(PARSE.CATCHCASE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (LHSLIST STATEMENT ANSWER)                         (* (catchcase lhslist => statement) *)
-          (SETQ LHSLIST (PARSE.LHSLIST))
-          (PARSE.BIN '=>)
-          (SETQ STATEMENT (PARSE.STATEMENT))
-          (SETQ ANSWER (LIST 'catchcase LHSLIST STATEMENT))
-          (RETURN ANSWER])
-
-(PARSE.OPTARGS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ANSWER)                                           (* (optargs %[ explist %])
-                                                             (optargs) (optargs lhs) *)
-          [COND
-             ((EQ PARSE.ATOM '%[)
-              (PARSE.BIN '%[)
-              (SETQ ANSWER (PARSE.EXPLIST))
-              (PARSE.BIN '%]))
-             ((NOT (FMEMB PARSE.ATOM PARSE.OPTARGS.FOLLOW))
-              (SETQ ANSWER (LIST (PARSE.LHS]
-          (RETURN ANSWER])
-
-(PARSE.TRANSFER
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-          
-          (* (transfer SIGNAL) (transfer ERROR) (transfer RETURN WITH ERROR)
-          (transfer START) (transfer RESTART) (transfer JOIN)
-          (transfer NOTIFY) (transfer BROADCAST) (transfer TRANSFER WITH)
-          (transfer RETURN WITH) *)
-
-    (COND
-       [(EQ PARSE.ATOM 'RETURN)
-        (PARSE.BIN)
-        (PARSE.BIN 'WITH)
-        (COND
-           ((EQ PARSE.ATOM 'ERROR)
-            'SHOULDNT)
-           (T 'RETURN]
-       ((EQ PARSE.ATOM 'TRANSFER)
-        (PARSE.BIN)
-        (PARSE.BIN 'WITH)
-        'RETURN)
-       (T (PARSE.BIN])
-
-(PARSE.KEYITEM
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ID OPTEXP ANSWER)                                 (* BOTH (keyitem id %: optexp) *)
-                                                             (* CEDAR (keyitem id ~ optexp) *)
-          (SETQ ID (PARSE.BIN 'ID))
-          (COND
-             ((EQ PARSE.ATOM '%:)
-              (PARSE.BIN))
-             ((AND (EQ PARSE.LANGUAGE 'CEDAR)
-                   (EQ PARSE.ATOM '~))
-              (PARSE.BIN))
-             (T (SHOULDNT)))
-          (SETQ OPTEXP (PARSE.OPTEXP))
-          (SETQ ANSWER (create KEYITEM
-                              ID _ ID
-                              OPTEXP _ OPTEXP))
-          (RETURN ANSWER])
-
-(PARSE.OPTEXP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (ANSWER)                                           (* (optexp TRASH) (optexp NULL)
-                                                             (optexp exp) (optexp) *)
-          [SETQ ANSWER (COND
-                          ((FMEMB PARSE.ATOM '(NULL TRASH))
-                           (PARSE.BIN)
-                           'TRASH)
-                          ((FMEMB PARSE.ATOM PARSE.OPTEXP.FOLLOW)
-                           'TRASH)
-                          (T (PARSE.EXP]
-          (RETURN ANSWER])
-
-(PARSE.EXP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (COND
-       ((EQ PARSE.CLASS 'ID)
-        (PARSE.EXP1))
-       (T (PARSE.EXP2])
-
-(PARSE.EXP1
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* First token of EXP is ID.
-                                                             *)
-    (PROG (DISJUNCT EXP ANSWER)                              (* (exp lhs _ exp) (exp disjunct) *)
-          (SETQ DISJUNCT (PARSE.DISJUNCT))
-          (COND
-             ((EQ PARSE.ATOM '_)
-              (PARSE.BIN)
-              (SETQ EXP (PARSE.EXP))
-              (SETQ ANSWER (BUILD.SETQ DISJUNCT EXP)))
-             (T (SETQ ANSWER DISJUNCT)))
-          (RETURN ANSWER])
-
-(PARSE.EXP2
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* First token of EXP is not ID.
-                                                             *)
-    (PROG (DISJUNCT ANSWER)                                  (* (exp transferop lhs)
-                                                             (exp IF exp THEN exp ELSE exp)
-                                                             (exp casehead caseexplist ENDCASE => 
-                                                             exp) (exp lhs _ exp)
-                                                             (exp %[ explist %] _ exp)
-                                                             (exp ERROR) (exp disjunct) *)
-          [SETQ ANSWER
-           (COND
-              ([AND (FMEMB PARSE.ATOM PARSE.TRANSFEROP.FIRST)
-                    (OR (NOT (EQ PARSE.ATOM 'NEW))
-                        (NOT (EQ PARSE.ATOM2 '%[]            (* Don't confuse with
-                                                             (primary new %[ typeexp initialization 
-                                                             optcatch %]) *)
-               (PARSE.EXP.TRANSFEROP))
-              ((EQ PARSE.ATOM 'IF)
-               (PARSE.EXP.IF))
-              ((FMEMB PARSE.ATOM PARSE.CASEHEAD.FIRST)
-               (PARSE.EXP.CASEHEAD))
-              ((EQ PARSE.ATOM)
-               (PARSE.EXP.LBRACKET '%[))
-              ((EQ PARSE.ATOM 'ERROR)
-               (PARSE.EXP.ERROR))
-              ((NUMBERP PARSE.ATOM)
-               (PARSE.EXP.DISJUNCT))
-              ((STRINGP PARSE.ATOM)
-               (PARSE.EXP.DISJUNCT))
-              ((FMEMB PARSE.ATOM
-                      '(ABS ALL BASE DESCRIPTOR FIRST ISTYPE LAST LENGTH LONG MAX MIN NILL NOT ORD 
-                            PRED SIZE SUCC VAL + - @ %[))
-               (PARSE.EXP.DISJUNCT))
-              (T (PROGN (SETQ DISJUNCT (PARSE.EXP.DISJUNCT))
-                        (COND
-                           ((EQ PARSE.ATOM '_)
-                            (PARSE.BIN)
-                            (BUILD.SETQ DISJUNCT (PARSE.EXP)))
-                           (T DISJUNCT]
-          (RETURN ANSWER])
-
-(PARSE.EXP.TRANSFEROP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (TRANSFEROP LHS ANSWER)                            (* (exp transferop lhs) *)
-          (SETQ TRANSFEROP (PARSE.TRANSFEROP))
-          (SETQ LHS (PARSE.LHS))
-          [SETQ ANSWER `(SHOULDNT ',LHS]
-          (RETURN ANSWER])
-
-(PARSE.EXP.IF
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (EXP1 EXP2 EXP3 ANSWER)                            (* (exp IF exp THEN exp ELSE exp) *)
-          (PARSE.BIN 'IF)
-          (SETQ EXP1 (PARSE.EXP))
-          (PARSE.BIN 'THEN)
-          (SETQ EXP2 (PARSE.EXP))
-          (PARSE.BIN 'ELSE)
-          (SETQ EXP3 (PARSE.EXP))
-          (SETQ ANSWER (BUILD.COND EXP1 EXP2 EXP3))
-          (RETURN ANSWER])
-
-(PARSE.EXP.CASEHEAD
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (CASEHEAD CASEEXPLIST EXP ANSWER)                  (* (exp casehead caseexplist ENDCASE 
-                                                             => exp) *)
-          (SETQ CASEHEAD (PARSE.CASEHEAD))
-          (SETQ CASEEXPLIST (PARSE.CASEEXPLIST))
-          (PARSE.BIN 'ENDCASE)
-          (PARSE.BIN '=>)
-          (SETQ EXP (PARSE.EXP))
-          (SETQ ANSWER (BUILD.SELECTQ CASEHEAD CASEEXPLIST EXP))
-          (RETURN ANSWER])
-
-(PARSE.EXP.LHS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (LHS EXP ANSWER)                                   (* (exp lhs _ exp) *)
-          (SETQ LHS (PARSE.LHS))
-          (PARSE.BIN '_)
-          (SETQ EXP (PARSE.EXP))
-          [SETQ ANSWER `(SETQ ,LHS ,EXP]
-          (RETURN ANSWER])
-
-(PARSE.EXP.LBRACKET
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (EXPLIST EXP ANSWER)                               (* (exp %[ explist %] _ exp) *)
-          (PARSE.BIN '%[)
-          (SETQ EXPLIST (PARSE.EXPLIST))
-          (PARSE.BIN '%])
-          (PARSE.BIN '_)
-          (SETQ EXP (PARSE.EXP))
-          [SETQ ANSWER `(SETQ ,EXPLIST ,EXP]
-          (RETURN ANSWER])
-
-(PARSE.EXP.ERROR
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (exp ERROR) *)
-    (PARSE.BIN 'ERROR)
-    '(SHOULDNT])
-
-(PARSE.EXP.DISJUNCT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (exp disjunct) *)
-    (PARSE.DISJUNCT])
-
-(PARSE.DISJUNCT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (CONJUNCTS ANSWER)                                 (* (disjunct disjunct OR conjunct)
-                                                             (disjunct conjunct) *)
-          (push CONJUNCTS (PARSE.CONJUNCT))
-          (while (EQ PARSE.ATOM 'OR) do (PARSE.BIN)
-                                        (push CONJUNCTS (PARSE.CONJUNCT)))
-          [SETQ ANSWER (COND
-                          ((CDR CONJUNCTS)
-                           (CONS 'OR (DREVERSE CONJUNCTS)))
-                          (T (CAR CONJUNCTS]
-          (RETURN ANSWER])
-
-(PARSE.CONJUNCT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (NEGATIONS ANSWER)                                 (* (conjunct conjunct AND negation)
-                                                             (conjunct negation) *)
-          (push NEGATIONS (PARSE.NEGATION))
-          (while (EQ PARSE.ATOM 'AND) do (PARSE.BIN)
-                                         (push NEGATIONS (PARSE.NEGATION)))
-          [SETQ ANSWER (COND
-                          ((CDR NEGATIONS)
-                           (CONS 'AND (DREVERSE NEGATIONS)))
-                          (T (CAR NEGATIONS]
-          (RETURN ANSWER])
-
-(PARSE.NEGATION
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (NOT ANSWER)                                       (* (negation not relation)
-                                                             (negation relation) *)
-          [COND
-             ((FMEMB PARSE.ATOM PARSE.NOTS)
-              (SETQ NOT (PARSE.NOT]
-          (SETQ ANSWER (PARSE.RELATION))
-          [COND
-             (NOT (SETQ ANSWER `(NOT ,ANSWER]
-          (RETURN ANSWER])
-
-(PARSE.RELATION
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (SUM OPTRELATION NOT ANSWER)                       (* (relation sum optrelation)
-                                                             (relation sum) *)
-          (SETQ SUM (PARSE.SUM))
-          (COND
-             ((NOT (FMEMB PARSE.ATOM PARSE.OPTRELATION.FIRST))
-              (RETURN SUM)))
-          (SETQ OPTRELATION (PARSE.OPTRELATION))
-          [COND
-             ((EQ (CAR OPTRELATION)
-                  'NOT)
-              (SETQ NOT T)
-              (SETQ OPTRELATION (CADR OPTRELATION]
-          [SETQ ANSWER (COND
-                          ((EQ (CAR OPTRELATION)
-                               'IN)
-                           (BUILD.IN SUM (CADR OPTRELATION)))
-                          (T (BUILD.ARITH.EXP2 (CAR OPTRELATION)
-                                    SUM
-                                    (CADR OPTRELATION]
-          [COND
-             (NOT (SETQ ANSWER (LIST 'NOT ANSWER]
-          (RETURN ANSWER])
-
-(PARSE.SUM
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (PRODUCTS PRODUCT ANSWER)                          (* (sum sum addop product)
-                                                             (sum product) *)
-          (SETQ PRODUCT (PARSE.PRODUCT))
-          [while (FMEMB PARSE.ATOM PARSE.ADDOPS) do (COND
-                                                       ((EQ PARSE.ATOM '+)
-                                                        (PARSE.BIN)
-                                                        (push PRODUCTS PRODUCT)
-                                                        (SETQ PRODUCT (PARSE.PRODUCT)))
-                                                       [(EQ PARSE.ATOM '-)
-                                                        (PARSE.BIN)
-                                                        (SETQ PRODUCT (BUILD.ARITH.EXP2 '- PRODUCT
-                                                                             (PARSE.PRODUCT]
-                                                       (T (SHOULDNT]
-          (push PRODUCTS PRODUCT)
-          [SETQ ANSWER (COND
-                          ((CDR PRODUCTS)
-                           (BUILD.ARITH.EXP* '+ (DREVERSE PRODUCTS)))
-                          (T (CAR PRODUCTS]
-          (RETURN ANSWER])
-
-(PARSE.PRODUCT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (FACTORS FACTOR ANSWER)                            (* (product product multop factor)
-                                                             (product factor) *)
-          (SETQ FACTOR (PARSE.FACTOR))
-          [while (FMEMB PARSE.ATOM PARSE.MULTOPS) do (COND
-                                                        ((EQ PARSE.ATOM '*)
-                                                         (PARSE.BIN)
-                                                         (push FACTORS FACTOR)
-                                                         (SETQ FACTOR (PARSE.FACTOR)))
-                                                        [(EQ PARSE.ATOM '/)
-                                                         (PARSE.BIN)
-                                                         (SETQ FACTOR (BUILD.ARITH.EXP2 '/ FACTOR
-                                                                             (PARSE.FACTOR]
-                                                        [(EQ PARSE.ATOM 'MOD)
-                                                         (PARSE.BIN)
-                                                         (SETQ FACTOR (BUILD.ARITH.EXP2 'MOD FACTOR
-                                                                             (PARSE.FACTOR]
-                                                        (T (SHOULDNT]
-          (push FACTORS FACTOR)
-          [SETQ ANSWER (COND
-                          ((CDR FACTORS)
-                           (BUILD.ARITH.EXP* '* (DREVERSE FACTORS)))
-                          (T (CAR FACTORS]
-          (RETURN ANSWER])
-
-(PARSE.OPTRELATION
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (NOT ANSWER)                                       (* (optrelation not relationtail)
-                                                             (optrelation relationtail) *)
-                                                             (* In CEDAR, not must be NOT.
-                                                             *)
-          [COND
-             ([OR (EQ PARSE.ATOM 'NOT)
-                  (AND (EQ PARSE.LANGUAGE 'MESA)
-                       (EQ PARSE.ATOM '~]
-              (SETQ NOT (PARSE.NOT]
-          (SETQ ANSWER (PARSE.RELATIONTAIL))
-          [COND
-             (NOT (SETQ ANSWER (LIST 'NOT ANSWER]
-          (RETURN ANSWER])
-
-(PARSE.RELATIONTAIL
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-    (PROG (RANGE RELOP SUM ANSWER)                           (* (relationtail IN range)
-                                                             (relationtail relop sum) *)
-          [COND
-             ((EQ PARSE.ATOM 'IN)
-              (PARSE.BIN)
-              (SETQ RANGE (PARSE.RANGE))
-              (SETQ ANSWER (LIST 'IN RANGE)))
-             (T (SETQ RELOP (PARSE.RELOP))
-                (SETQ SUM (PARSE.SUM))
-                (SETQ ANSWER (LIST RELOP SUM]
-          (RETURN ANSWER])
-
-(PARSE.RELOP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (relop =) (relop %#)
-                                                             (relop <) (relop <=)
-                                                             (relop >) (relop >=) *)
-    (PARSE.BIN])
-
-(PARSE.ADDOP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:47")
-                                                             (* (addop +) (addop -) *)
-    (PARSE.BIN])
-
-(PARSE.MULTOP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (multop *) (multop /)
-                                                             (multop MOD) *)
-    (PARSE.BIN])
-
-(PARSE.FACTOR
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (ADDOP PRIMARY ANSWER)                             (* (factor addop primary)
-                                                             (factor primary) *)
-          [COND
-             ((FMEMB PARSE.ATOM PARSE.ADDOPS)
-              (SETQ ADDOP (PARSE.BIN]
-          (SETQ ANSWER (PARSE.PRIMARY))
-          [COND
-             ((EQ ADDOP '-)
-              (SETQ ANSWER (BUILD.ARITH.EXP1 '- ANSWER]
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (ANSWER LHS)
-          
-          (* BOTH (primary num) (primary lnum) (primary flnum)
-          (primary string) (primary lstring) (primary atom)
-          (primary NIL) (primary %[ explist %]) (primary prefixop %[ orderlist %])
-          (primary VAL %[ orderlist %]) (primary ALL %[ orderlist %])
-          (primary new %[ typeexp initialization optcatch %])
-          (primary typeop %[ typeexp %]) (primary SIZE %[ typeexp %])
-          (primary SIZE %[ typeexp %, exp %]) (primary ISTYPE %[ exp %, typeexp %])
-          (primary @ lhs) (primary DESCRIPTOR %[ desclist %])
-          (primary lhs) *)
-                                                             (* CEDAR (primary cons %[ explist 
-                                                             optcatch %]) (primary listcons %[ 
-                                                             explist %]) *)
-                                                             (* In CEDAR, new can be NEW.
-                                                             *)
-          [SETQ ANSWER (COND
-                          ((EQ PARSE.CLASS 'CHAR)
-                           (BUILD.CHARCODE (PARSE.BIN)))
-                          ((NUMBERP PARSE.ATOM)
-                           (PARSE.BIN))
-                          ((STRINGP PARSE.ATOM)
-                           (PARSE.BIN))
-                          ((FMEMB PARSE.ATOM PARSE.PREFIXOP.FIRST)
-                           (PARSE.PRIMARY.PREFIXOP))
-                          ((AND [OR (FMEMB PARSE.ATOM PARSE.TYPEOP.FIRST)
-                                    (AND (EQ PARSE.LANGUAGE 'CEDAR)
-                                         (EQ PARSE.ATOM 'CODE]
-                                (EQ PARSE.ATOM2 '%[))
-                           (PARSE.PRIMARY.TYPEOP))
-                          (T (SELECTQ PARSE.ATOM
-                                 ($ (PARSE.ATOM))
-                                 (NILL (PARSE.PRIMARY.NIL))
-                                 (%[ (PARSE.PRIMARY.LBRACKET))
-                                 (VAL (PARSE.PRIMARY.VAL))
-                                 (ALL (PARSE.PRIMARY.ALL))
-                                 (SIZE (PARSE.PRIMARY.SIZE))
-                                 (ISTYPE (PARSE.PRIMARY.ISTYPE))
-                                 (@ (PARSE.PRIMARY.AT))
-                                 (DESCRIPTOR (PARSE.PRIMARY.DESCRIPTOR))
-                                 (NEW (PARSE.PRIMARY.NEW))
-                                 (CONS (PARSE.PRIMARY.CONS))
-                                 (LIST (PARSE.PRIMARY.LIST))
-                                 (PARSE.PRIMARY.LHS]
-          (RETURN ANSWER])
-
-(PARSE.ATOM
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (atom $ id) *)
-    (PARSE.BIN '$)
-    `',(PARSE.BIN 'ID])
-
-(PARSE.PRIMARY.NIL
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (primary NIL) *)
-    (PARSE.BIN 'NILL)
-    NIL])
-
-(PARSE.PRIMARY.LBRACKET
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (ANSWER)                                           (* (primary %[ explist %]) *)
-          (PARSE.BIN '%[)
-          (SETQ ANSWER (PARSE.EXPLIST))
-          (PARSE.BIN '%])
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.PREFIXOP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (PREFIXOP ORDERLIST ANSWER)                        (* (primary prefixop %[ orderlist %]) 
-                                                             *)
-          (SETQ PREFIXOP (PARSE.PREFIXOP))
-          (PARSE.BIN '%[)
-          (SETQ ORDERLIST (PARSE.ORDERLIST))
-          (PARSE.BIN '%])
-          (SETQ ANSWER (CONS PREFIXOP (fetch (ORDERLIST ITEMS) of ORDERLIST)))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.VAL
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (ORDERLIST ANSWER)                                 (* (primary VAL %[ orderlist %]) *)
-          (PARSE.BIN 'VAL)
-          (PARSE.BIN '%[)
-          (SETQ ORDERLIST (PARSE.ORDERLIST))
-          (PARSE.BIN '%])
-          (SETQ ANSWER (CONS 'VAL (fetch (ORDERLIST ITEMS) of ORDERLIST)))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.ALL
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (ORDERLIST ANSWER)                                 (* (primary ALL %[ orderlist %]) *)
-          (PARSE.BIN 'ALL)
-          (PARSE.BIN '%[)
-          (SETQ ORDERLIST (PARSE.ORDERLIST))
-          (PARSE.BIN '%])
-          (SETQ ANSWER (CONS 'ALL (fetch (ORDERLIST ITEMS) of ORDERLIST)))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.NEW
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (TYPEEXP INITIALIZATION ANSWER)                    (* (primary new %[ typeexp 
-                                                             initialization optcatch %]) *)
-          (PARSE.NEW)
-          (PARSE.BIN '%[)
-          (SETQ TYPEEXP (PARSE.TYPEEXP))
-          (SETQ INITIALIZATION (PARSE.INITIALIZATION))
-          (PARSE.OPTCATCH)
-          (PARSE.BIN '%])
-          (SETQ ANSWER (BUILD.NEW TYPEEXP INITIALIZATION))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.TYPEOP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (TYPEOP TYPEEXP ANSWER)                            (* (primary typeop %[ typeexp %]) *)
-          (SETQ TYPEOP (PARSE.TYPEOP))
-          (PARSE.BIN '%[)
-          (SETQ TYPEEXP (PARSE.TYPEEXP))
-          (PARSE.BIN '%])
-          (SETQ ANSWER (LIST TYPEOP TYPEEXP))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.SIZE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (TYPEEXP EXP ANSWER)                               (* (primary SIZE %[ typeexp %])
-                                                             (primary SIZE %[ typeexp %, exp %]) *)
-          (PARSE.BIN 'SIZE)
-          (PARSE.BIN '%[)
-          (SETQ TYPEEXP (PARSE.TYPEEXP))
-          [COND
-             ((NOT (EQ PARSE.ATOM '%,))
-              (PARSE.BIN '%])
-              (SETQ ANSWER (LIST 'SIZE TYPEEXP)))
-             (T (PARSE.BIN)
-                (SETQ EXP (PARSE.EXP))
-                (PARSE.BIN '%])
-                (SETQ ANSWER (LIST 'SIZE TYPEEXP EXP]
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.ISTYPE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (primary ISTYPE %[ exp %, typeexp 
-                                                             %]) *)
-    (PROG (EXP TYPEEXP ANSWER)
-          (PARSE.BIN 'ISTYPE)
-          (PARSE.BIN '%[)
-          (SETQ EXP (PARSE.EXP))
-          (PARSE.BIN '%,)
-          (SETQ TYPEEXP (PARSE.TYPEEXP))
-          (PARSE.BIN '%])
-          (SETQ ANSWER (BUILD.ISTYPE EXP TYPEEXP))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.AT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (LHS ANSWER)                                       (* (primary @ lhs) *)
-          (PARSE.BIN '@)
-          (SETQ LHS (PARSE.LHS))
-          (SETQ ANSWER LHS)
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.DESCRIPTOR
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (DESCLIST ANSWER)                                  (* (primary DESCRIPTOR %[ desclist %]) 
-                                                             *)
-          (PARSE.BIN 'DESCRIPTOR)
-          (PARSE.BIN '%[)
-          (SETQ DESCLIST (PARSE.DESCLIST))
-          (PARSE.BIN '%])
-          (SETQ ANSWER (CONS 'DESCRIPTOR DESCLIST))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.CONS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (EXPLIST ANSWER)                                   (* CEDAR (primary CONS %[ explist 
-                                                             optcatch %]) *)
-          (PARSE.THISIS.CEDAR)
-          (PARSE.BIN 'CONS)
-          (PARSE.BIN '%[)
-          (SETQ EXPLIST (PARSE.EXPLIST))
-          (PARSE.OPTCATCH)
-          (PARSE.BIN '%])
-          (SETQ ANSWER (CONS 'CONS (fetch (EXPLIST ITEMS) of EXPLIST)))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.LIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (EXPLIST ANSWER)                                   (* CEDAR (primary LIST %[ explist %]) 
-                                                             *)
-          (PARSE.THISIS.CEDAR)
-          (PARSE.BIN 'LIST)
-          (PARSE.BIN '%[)
-          (SETQ EXPLIST (PARSE.EXPLIST))
-          (PARSE.BIN '%])
-          (SETQ ANSWER (CONS 'LIST (fetch (EXPLIST ITEMS) of EXPLIST)))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.LHS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (LHS QUALIFIER ANSWER)                             (* BOTH (primary lhs)
-                                                             (primary new %[ typeexp initialization 
-                                                             optcatch %]) *)
-                                                             (* CEDAR (primary cons %[ explist 
-                                                             optcatch %]) (primary listcons %[ 
-                                                             explist %]) *)
-          (SETQ LHS (PARSE.LHS))
-          (COND
-             ([NOT (AND (EQ PARSE.ATOM '%.)
-                        (OR (EQ PARSE.ATOM2 'NEW)
-                            (AND (EQ PARSE.LANGUAGE 'CEDAR)
-                                 (FMEMB PARSE.ATOM2 '(CONS LIST]
-              (RETURN LHS)))
-          (PARSE.BIN '%.)
-          (SETQ ANSWER (SELECTQ PARSE.ATOM
-                           (NEW (PARSE.PRIMARY.LHS.NEW LHS))
-                           (CONS (PARSE.PRIMARY.LHS.CONS LHS))
-                           (LIST (PARSE.PRIMARY.LHS.LIST LHS))
-                           (SHOULDNT)))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.LHS.NEW
-  [LAMBDA (LHS)                                              (* kbr%: "25-Nov-85 12:48")
-    (PROG (TYPEEXP INITIALIZATION ANSWER)                    (* (primary new %[ typeexp 
-                                                             initialization optcatch %]) *)
-          (PARSE.BIN 'NEW)
-          (PARSE.BIN '%[)
-          (SETQ TYPEEXP (PARSE.TYPEEXP))
-          (SETQ INITIALIZATION (PARSE.INITIALIZATION))
-          (PARSE.OPTCATCH)
-          (PARSE.BIN '%])
-          (SETQ ANSWER (LIST 'create LHS TYPEEXP INITIALIZATION))
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.LHS.CONS
-  [LAMBDA (LHS)                                              (* kbr%: "25-Nov-85 12:48")
-    (PROG (EXPLIST OPTCATCH ANSWER)                          (* CEDAR (primary cons %[ explist 
-                                                             optcatch %]) *)
-          (PARSE.BIN 'CONS)
-          (PARSE.BIN '%[)
-          (SETQ EXPLIST (PARSE.EXPLIST))
-          (PARSE.OPTCATCH)
-          (PARSE.BIN '%])
-          [SETQ ANSWER `(CONS ,LHS ,@EXPLIST]
-          (RETURN ANSWER])
-
-(PARSE.PRIMARY.LHS.LIST
-  [LAMBDA (LHS)                                              (* kbr%: "25-Nov-85 12:48")
-    (PROG (EXPLIST OPTCATCH ANSWER)                          (* CEDAR (primary listcons %[ explist 
-                                                             %]) *)
-          (PARSE.BIN 'LIST)
-          (PARSE.BIN '%[)
-          (SETQ EXPLIST (PARSE.EXPLIST))
-          (PARSE.BIN '%])
-          [SETQ ANSWER `(LIST ,LHS ,@EXPLIST]
-          (RETURN ANSWER])
-
-(PARSE.QUALIFIER
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (ANSWER)                                           (* (qualifier %. prefixop)
-                                                             (qualifier %. typeop)
-                                                             (qualifier %. SIZE) (qualifier %[ 
-                                                             explist optcatch %])
-                                                             (qualifier %. id) (qualifier ^) *)
-          [COND
-             [(EQ PARSE.ATOM '%.)
-              (PARSE.BIN)
-              (COND
-                 ((FMEMB PARSE.ATOM PARSE.PREFIXOPS)
-                  (SETQ ANSWER (PARSE.PREFIXOP)))
-                 ([OR (FMEMB PARSE.ATOM PARSE.TYPEOPS)
-                      (AND (EQ PARSE.LANGUAGE 'CEDAR)
-                           (EQ PARSE.ATOM 'CODE]
-                  (SETQ ANSWER (PARSE.TYPEOP)))
-                 ((EQ PARSE.ATOM 'SIZE)
-                  (SETQ ANSWER (PARSE.BIN)))
-                 ((EQ PARSE.ATOM 'FREE)                      (* (free lhs %. FREE) *)
-                  (SETQ ANSWER (PARSE.BIN)))
-                 ((EQ PARSE.ATOM 'NEW)                       (* (new lhs %. NEW) *)
-                  (SETQ ANSWER (PARSE.BIN)))
-                 ([AND (EQ PARSE.LANGUAGE 'CEDAR)
-                       (FMEMB PARSE.ATOM '(LIST CONS]
-                  (SETQ ANSWER (PARSE.BIN)))
-                 (T (SETQ ANSWER (PARSE.BIN 'ID]
-             ((EQ PARSE.ATOM '%[)
-              (PARSE.BIN)
-              (SETQ ANSWER (PARSE.EXPLIST))
-              (PARSE.OPTCATCH)
-              (PARSE.BIN '%]))
-             (T (SETQ ANSWER (PARSE.BIN '^]
-          (RETURN ANSWER])
-
-(PARSE.LHS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (EXP1 EXP2 OPTTYPE ANSWER)                         (* (lhs id) (lhs char)
-                                                             (lhs NARROW %[ exp opttype optcatch %])
-                                                             (lhs LOOPHOLE %[ exp opttype %])
-                                                             (lhs APPLY %[ exp %, exp optcatch %])
-                                                             (lhs %( exp %)) (lhs lhs qualifier) *)
-          [COND
-             ((EQ PARSE.ATOM 'TRUE)
-              (PARSE.BIN)
-              (SETQ ANSWER T))
-             ((EQ PARSE.ATOM 'FALSE)
-              (PARSE.BIN))
-             ((EQ PARSE.ATOM 'NARROW)
-              (PARSE.BIN)
-              (PARSE.BIN '%[)
-              (SETQ EXP1 (PARSE.EXP))
-              (SETQ OPTTYPE (PARSE.OPTTYPE))
-              (PARSE.OPTCATCH)
-              (PARSE.BIN '%])
-              (SETQ ANSWER (BUILD.COERCE EXP1 OPTTYPE)))
-             ((EQ PARSE.ATOM 'LOOPHOLE)
-              (PARSE.BIN)
-              (PARSE.BIN '%[)
-              (SETQ EXP1 (PARSE.EXP))
-              (SETQ OPTTYPE (PARSE.OPTTYPE))
-              (PARSE.BIN '%])
-              (SETQ ANSWER (BUILD.COERCE EXP1 OPTTYPE)))
-             ((EQ PARSE.ATOM 'APPLY)
-              (PARSE.BIN)
-              (PARSE.BIN '%[)
-              (SETQ EXP1 (PARSE.EXP))
-              (PARSE.BIN '%,)
-              (SETQ EXP2 (PARSE.EXP))
-              (PARSE.OPTCATCH)
-              (PARSE.BIN '%])
-              (SETQ ANSWER (LIST 'APPLY EXP1 EXP2)))
-             ((EQ PARSE.ATOM '%()
-              (PARSE.BIN)
-              (SETQ EXP1 (PARSE.EXP))
-              (PARSE.BIN '%))
-              (SETQ ANSWER EXP1))
-             ((EQ PARSE.CLASS 'ID)
-              (SETQ ANSWER (PARSE.BIN)))
-             ((EQ PARSE.CLASS 'CHAR)
-              (SETQ ANSWER (BUILD.CHARCODE (PARSE.BIN]
-          [while (PARSE.QUALIFIER.HERE) do (SETQ ANSWER (BUILD.QUALIFY ANSWER (PARSE.QUALIFIER]
-          (RETURN ANSWER])
-
-(PARSE.QUALIFIER.HERE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (AND (FMEMB PARSE.ATOM PARSE.QUALIFIER.FIRST)
-         (NOT (AND (EQ PARSE.ATOM '%.)
-                   (OR (FMEMB PARSE.ATOM2 '(FREE NEW))
-                       (AND (EQ PARSE.LANGUAGE 'CEDAR)
-                            (FMEMB PARSE.ATOM2 '(CONS LIST])
-
-(PARSE.OPTCATCH
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (CATCHLIST ANSWER)                                 (* (optcatch ! catchlist)
-                                                             (optcatch) *)
-          [COND
-             ((EQ PARSE.ATOM '!)
-              (PARSE.BIN)
-              (SETQ ANSWER (PARSE.CATCHLIST]
-          (RETURN ANSWER])
-
-(PARSE.TRANSFEROP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (transferop SIGNAL)
-                                                             (transferop ERROR) (transferop START)
-                                                             (transferop JOIN) (transferop NEW)
-                                                             (transferop FORK) *)
-    (PARSE.BIN])
-
-(PARSE.PREFIXOP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-          
-          (* (prefixop LONG) (prefixop ABS) (prefixop PRED)
-          (prefixop SUCC) (prefixop ORD) (prefixop MIN)
-          (prefixop MAX) (prefixop BASE) (prefixop LENGTH) *)
-
-    (PARSE.BIN])
-
-(PARSE.TYPEOP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* BOTH (typeop FIRST)
-                                                             (typeop LAST) (typeop NIL) *)
-                                                             (* CEDAR (typeop CODE) *)
-    (COND
-       ((EQ PARSE.ATOM 'CODE)
-        (PARSE.THISIS.CEDAR)))
-    (PARSE.BIN])
-
-(PARSE.DESCLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (EXP1 EXP2 OPTTYPE ANSWER)                         (* (desclist exp %, exp opttype)
-                                                             (desclist exp) *)
-          (SETQ EXP1 (PARSE.EXP))
-          [COND
-             ((EQ PARSE.ATOM '%,)
-              (PARSE.BIN)
-              (SETQ EXP2 (PARSE.EXP))
-              (SETQ OPTTYPE (PARSE.OPTTYPE))
-              (SETQ ANSWER (LIST 'desclist EXP1 EXP2 OPTTYPE))
-              (RETURN ANSWER))
-             (T (SETQ ANSWER (LIST 'desclist EXP1]
-          (RETURN ANSWER])
-
-(PARSE.DIRECTORY
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG NIL                                                (* (directory DIRECTORY ;)
-                                                             (directory DIRECTORY includelist ;)
-                                                             (directory) *)
-          (COND
-             ((EQ PARSE.ATOM 'DIRECTORY)
-              (PARSE.BIN)
-              (COND
-                 ((EQ PARSE.ATOM ';))
-                 (T (PARSE.INCLUDELIST)
-                    (PARSE.BIN ';])
-
-(PARSE.IMPORTS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG NIL                                                (* (imports IMPORTS)
-                                                             (imports IMPORTS modulelist)
-                                                             (imports) *)
-          (COND
-             ((EQ PARSE.ATOM 'IMPORTS)
-              (PARSE.BIN)
-              (PARSE.MODULELIST])
-
-(PARSE.POINTERPREFIX
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (ANSWER)                                           (* (pointerprefix POINTER)
-                                                             (pointerprefix POINTER interval) *)
-          (PARSE.BIN 'POINTER)
-          [COND
-             ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST)
-              (SETQ ANSWER (LIST 'POINTER (PARSE.INTERVAL]
-          (RETURN ANSWER])
-
-(PARSE.EXPORTS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (MODULELIST ANSWER)                                (* (exports EXPORTS)
-                                                             (exports EXPORTS modulelist)
-                                                             (exports) *)
-          (COND
-             ((EQ PARSE.ATOM 'EXPORTS)
-              (PARSE.BIN)
-              (BUILD.STORE.EXPORTS (PARSE.MODULELIST])
-
-(PARSE.FIELDLIST
-  [LAMBDA (KIND)                                             (* kbr%: "25-Nov-85 12:48")
-    (PROG (ANSWER)                                           (* (fieldlist %[ %])
-                                                             (fieldlist %[ pairlist %])
-                                                             (fieldlist %[ typelist %]) *)
-          (PARSE.BIN '%[)
-          [COND
-             ((NOT (EQ PARSE.ATOM '%]))
-              (COND
-                 [[AND (EQ PARSE.CLASS 'ID)
-                       (NOT (FMEMB PARSE.ATOM PARSE.PREDEFINED.TYPES))
-                       (FMEMB PARSE.ATOM2 '(%( %, %:]
-                  (SETQ ANSWER (PARSE.PAIRLIST 'FIELDLIST]
-                 (T (SETQ ANSWER (PARSE.TYPELIST]
-          (PARSE.BIN '%])
-          (RETURN ANSWER])
-
-(PARSE.USING
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (IDLIST)                                           (* (using USING %[ %])
-                                                             (using USING %[ idlist %])
-                                                             (using) *)
-          [COND
-             ((EQ PARSE.ATOM 'USING)
-              (PARSE.BIN)
-              (PARSE.BIN '%[)
-              (COND
-                 ((EQ PARSE.ATOM '%])
-                  (PARSE.BIN))
-                 (T (SETQ IDLIST (PARSE.IDLIST))
-                    (PARSE.BIN '%]]
-          (RETURN IDLIST])
-
-(PARSE.CATCHHEAD
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (CATCHCASES ANSWER)                                (* (catchhead) (catchhead catchhead 
-                                                             catchcase ;) *)
-          (COND
-             ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW)
-              (RETURN)))
-          (push CATCHCASES (PARSE.CATCHCASE))
-          (while (EQ PARSE.ATOM ';) do (PARSE.BIN)
-                                       (COND
-                                          ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW)
-                                           (RETURN)))
-                                       (push CATCHCASES (PARSE.CATCHCASE)))
-          (SETQ ANSWER (DREVERSE CATCHCASES))
-          (RETURN ANSWER])
-
-(PARSE.DECLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (VARLIST)                                          (* (declist declaration)
-                                                             (declist declist ; declaration) *)
-          (SETQ VARLIST (PARSE.DECLARATION))
-          [do (COND
-                 ((EQ PARSE.ATOM ';)
-                  (PARSE.BIN))
-                 ((FMEMB PARSE.ATOM PARSE.DECLIST.FOLLOW)
-                  (RETURN))
-                 (T (SHOULDNT "PARSE.DECLIST")))
-              (COND
-                 ([NOT (AND (EQ PARSE.CLASS 'ID)
-                            (FMEMB PARSE.ATOM2 '(%, %:]
-                  (RETURN)))
-              (SETQ VARLIST (NCONC VARLIST (PARSE.DECLARATION]
-          (BUILD.STORE.VARLIST VARLIST])
-
-(PARSE.PAIRLIST
-  [LAMBDA (KIND)                                             (* kbr%: "25-Nov-85 12:48")
-    (PROG (PAIRITEMS ANSWER)                                 (* (pairlist pairitem)
-                                                             (pairlist pairlist %, pairitem) *)
-                                                             (* PARSE.PAIRITEM returns a list of 
-                                                             PAIRITEM records. *)
-          (SETQ PAIRITEMS (PARSE.PAIRITEM KIND))
-          (COND
-             ((type? TYPELIST PAIRITEMS)
-          
-          (* Thought we we're parsing a pairlist, but found a typelist.
-          *)
-
-              (RETURN PAIRITEMS)))
-          [while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (SETQ PAIRITEMS (NCONC PAIRITEMS (PARSE.PAIRITEM KIND]
-          (SETQ ANSWER (create PAIRLIST
-                              ITEMS _ PAIRITEMS))
-          (RETURN ANSWER])
-
-(PARSE.VARIANTLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (VARIANTITEMS ANSWER)                              (* (variantlist variantitem)
-                                                             (variantlist variantlist %, 
-                                                             variantitem) *)
-          (push VARIANTITEMS (PARSE.VARIANTITEM))
-          (while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (push VARIANTITEMS (PARSE.VARIANTITEM)))
-          (SETQ ANSWER (CONS 'variantlist (DREVERSE VARIANTITEMS)))
-          (RETURN ANSWER])
-
-(PARSE.ORDERLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (OPTEXPS ANSWER)                                   (* (orderlist optexp)
-                                                             (orderlist orderlist %, optexp) *)
-          (COND
-             ((FMEMB PARSE.ATOM PARSE.ORDERLIST.FOLLOW)
-              (RETURN)))
-          (push OPTEXPS (PARSE.OPTEXP))
-          (while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (push OPTEXPS (PARSE.OPTEXP)))
-          (SETQ ANSWER (create ORDERLIST
-                              ITEMS _ (DREVERSE OPTEXPS)))
-          (RETURN ANSWER])
-
-(PARSE.LHSLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (LHSS ANSWER)                                      (* (lhslist lhs) (lhslist lhslist %, 
-                                                             lhs) *)
-          (push LHSS (PARSE.LHS))
-          (while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (push LHSS (PARSE.LHS)))
-          (SETQ ANSWER (DREVERSE LHSS))
-          (RETURN ANSWER])
-
-(PARSE.INCLUDELIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG NIL                                                (* (includelist includeitem)
-                                                             (includelist includelist %, 
-                                                             includeitem) *)
-          (PARSE.INCLUDEITEM)
-          (while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (PARSE.INCLUDEITEM])
-
-(PARSE.MODULELIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (MODULEITEMS ANSWER)                               (* (modulelist moduleitem)
-                                                             (modulelist modulelist %, moduleitem) 
-                                                             *)
-          (COND
-             ((FMEMB PARSE.ATOM PARSE.MODULELIST.FOLLOW)
-              (RETURN NIL)))
-          (push MODULEITEMS (PARSE.MODULEITEM))
-          (while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (push MODULEITEMS (PARSE.MODULEITEM)))
-          (SETQ ANSWER (DREVERSE MODULEITEMS))
-          (RETURN ANSWER])
-
-(PARSE.ELEMENTLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (ELEMENTS ANSWER)                                  (* (elementlist element)
-                                                             (elementlist elementlist %, element) *)
-          (push ELEMENTS (PARSE.ELEMENT))
-          (while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (push ELEMENTS (PARSE.ELEMENT)))
-          (SETQ ANSWER (DREVERSE ELEMENTS))
-          (RETURN ANSWER])
-
-(PARSE.BINDLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (BINDITEMS ANSWER)                                 (* (bindlist binditem)
-                                                             (bindlist bindlist %, binditem) *)
-          (push BINDITEMS (PARSE.BINDITEM))
-          (while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (push BINDITEMS (PARSE.BINDITEM)))
-          (SETQ ANSWER (DREVERSE BINDITEMS))
-          (RETURN ANSWER])
-
-(PARSE.STATEMENTLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (STATEMENTS ANSWER)                                (* (statementlist statement)
-                                                             (statementlist statementlist ;
-                                                             statement) *)
-          (COND
-             ((FMEMB PARSE.ATOM PARSE.STATEMENTLIST.FOLLOW)
-              (RETURN)))
-          (push STATEMENTS (PARSE.STATEMENT))
-          (do (COND
-                 ((EQ PARSE.ATOM ';)
-                  (PARSE.BIN)))
-              (COND
-                 ((FMEMB PARSE.ATOM PARSE.STATEMENTLIST.FOLLOW)
-                  (RETURN)))
-              (push STATEMENTS (PARSE.STATEMENT)))
-          (SETQ ANSWER (DREVERSE STATEMENTS))
-          (RETURN ANSWER])
-
-(PARSE.CASESTMTLIST
-  [LAMBDA (CASEHEAD)                                         (* kbr%: "25-Nov-85 12:48")
-    (PROG (CASESTMTITEMS ANSWER)                             (* (casestmtlist casestmtitem)
-                                                             (casestmtlist casestmtlist ;
-                                                             casestmtitem) *)
-          (push CASESTMTITEMS (PARSE.CASESTMTITEM CASEHEAD))
-          (do (COND
-                 ((EQ PARSE.ATOM ';)
-                  (PARSE.BIN)))
-              (COND
-                 ((EQ PARSE.ATOM 'ENDCASE)
-                  (RETURN)))
-              (push CASESTMTITEMS (PARSE.CASESTMTITEM CASEHEAD)))
-          (SETQ ANSWER (DREVERSE CASESTMTITEMS))
-          (RETURN ANSWER])
-
-(PARSE.CASELABEL
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (CASETESTS IDENT TYPEEXP ANSWER)                   (* (caselabel ident typeexp)
-                                                             (caselabel caselabel')
-                                                             (caselabel' casetest)
-                                                             (caselabel' caselabel' %, casetest) *)
-          (COND
-             ([AND (EQ PARSE.CLASS 'ID)
-                   (FMEMB PARSE.ATOM2 '(%: %(]
-              (SETQ IDENT (PARSE.IDENT))
-              (SETQ TYPEEXP (PARSE.TYPEEXP))
-              (SETQ ANSWER (LIST (BUILD.ISTYPE IDENT TYPEEXP)))
-              (BUILD.INITIALIZE.VAR IDENT TYPEEXP NIL BUILD.CURRENT.SCOPE)
-              (RETURN ANSWER)))
-          (push CASETESTS (PARSE.CASETEST))
-          (while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (push CASETESTS (PARSE.CASETEST)))
-          (SETQ ANSWER (DREVERSE CASETESTS))
-          (RETURN ANSWER])
-
-(PARSE.EXITLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (EXITITEMS ANSWER)                                 (* (exitlist exititem)
-                                                             (exitlist exitlist ;
-                                                             exititem) *)
-          (COND
-             ((FMEMB PARSE.ATOM PARSE.EXITLIST.FOLLOW)
-              (RETURN)))
-          (push EXITITEMS (PARSE.EXITITEM))
-          (do (COND
-                 ((EQ PARSE.ATOM ';)
-                  (PARSE.BIN)))
-              (COND
-                 ((FMEMB PARSE.ATOM PARSE.EXITLIST.FOLLOW)
-                  (RETURN)))
-              (push EXITITEMS (PARSE.EXITITEM)))
-          (SETQ ANSWER (DREVERSE EXITITEMS))
-          (RETURN ANSWER])
-
-(PARSE.KEYLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (KEYITEMS ANSWER)                                  (* (keylist keyitem)
-                                                             (keylist keylist %, keyitem) *)
-          (push KEYITEMS (PARSE.KEYITEM))
-          (while (EQ PARSE.ATOM '%,) do (PARSE.BIN)
-                                        (push KEYITEMS (PARSE.KEYITEM)))
-          (SETQ ANSWER (create KEYLIST
-                              ITEMS _ (DREVERSE KEYITEMS)))
-          (RETURN ANSWER])
-
-(PARSE.CASEEXPLIST
-  [LAMBDA (CASEHEAD)                                         (* kbr%: "25-Nov-85 12:48")
-    (PROG (CASEEXPITEMS ANSWER)                              (* (caseexplist caseexpitem)
-                                                             (caseexplist caseexplist %, 
-                                                             caseexpitem) *)
-          (push CASEEXPITEMS (PARSE.CASEEXPITEM CASEHEAD))
-          (do (COND
-                 ((EQ PARSE.ATOM '%,)
-                  (PARSE.BIN)))
-              (COND
-                 ((EQ PARSE.ATOM 'ENDCASE)
-                  (RETURN)))
-              (push CASEEXPITEMS (PARSE.CASEEXPITEM CASEHEAD)))
-          (SETQ ANSWER (DREVERSE CASEEXPITEMS))
-          (RETURN ANSWER])
-
-(PARSE.EXPLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (explist orderlist)
-                                                             (explist keylist) *)
-    (PROG (ORDERLIST KEYLIST ANSWER)
-          [COND
-             ((AND (EQ PARSE.CLASS 'ID)
-                   (EQ PARSE.ATOM2 '%:))
-              (SETQ ANSWER (PARSE.KEYLIST)))
-             (T (SETQ ANSWER (PARSE.ORDERLIST]
-          (RETURN ANSWER])
-
-(PARSE.OPEN
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (BINDLIST)                                         (* (open OPEN bindlist ;)
-                                                             (open) *)
-          [COND
-             ((EQ PARSE.ATOM 'OPEN)
-              (PARSE.BIN)
-              (SETQ BINDLIST (PARSE.BINDLIST))
-              (PARSE.BIN ';]
-          (RETURN BINDLIST])
-
-(PARSE.CLASS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (class PROGRAM) (class MONITOR) *)
-    (PARSE.BIN '(MONITOR PROGRAM])
-
-(PARSE.CASEHEAD
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (ID EXP OPTEXP BINDITEM OPTEXP ANSWER)             (* (casehead SELECT exp FROM)
-                                                             (casehead WITH binditem SELECT optexp 
-                                                             FROM) *)
-          [COND
-             ((EQ PARSE.ATOM 'SELECT)
-              (PARSE.BIN)
-              (SETQ EXP (PARSE.EXP))
-              (PARSE.BIN 'FROM))
-             (T (PARSE.BIN 'WITH)
-                (SETQ BINDITEM (PARSE.BINDITEM))
-                (SETQ ID (fetch (BINDITEM ID) of BINDITEM))
-                (SETQ EXP (fetch (BINDITEM EXP) of BINDITEM))
-                (PARSE.BIN 'SELECT)
-                (SETQ OPTEXP (PARSE.OPTEXP))
-                (PARSE.BIN 'FROM]
-          (SETQ ANSWER (create CASEHEAD
-                              ID _ ID
-                              EXP _ EXP
-                              OPTEXP _ OPTEXP))
-          (RETURN ANSWER])
-
-(PARSE.READONLY
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (readonly READONLY)
-                                                             (readonly) *)
-    (COND
-       ((EQ PARSE.ATOM 'READONLY)
-        (PARSE.BIN])
-
-(PARSE.ORDERED
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (ordered ORDERED)
-                                                             (ordered) *)
-    (COND
-       ((EQ PARSE.ATOM 'ORDERED)
-        (PARSE.BIN])
-
-(PARSE.BASE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (base BASE) (base) *)
-    (COND
-       ((EQ PARSE.ATOM 'BASE)
-        (PARSE.BIN])
-
-(PARSE.PACKED
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (packed PACKED) (packed) *)
-    (COND
-       ((EQ PARSE.ATOM 'PACKED)
-        (PARSE.BIN])
-
-(PARSE.HEAP
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* BOTH (heap UNCOUNTED) *)
-                                                             (* CEDAR (heap) *)
-    (COND
-       ((EQ PARSE.ATOM 'UNCOUNTED)
-        (PARSE.BIN))
-       (T (PARSE.THISIS.CEDAR])
-
-(PARSE.INLINE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (inline INLINE) (inline) *)
-    (COND
-       ((EQ PARSE.ATOM 'INLINE)
-        (PARSE.BIN])
-
-(PARSE.ARGUMENTS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG NIL                                                (* (arguments arglist returnlist) *)
-          (PARSE.ARGLIST)
-          (PARSE.RETURNLIST])
-
-(PARSE.INTERFACE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG NIL                                                (* (interface imports exports shares) 
-                                                             *)
-          (PARSE.IMPORTS)
-          (PARSE.EXPORTS)
-          (PARSE.SHARES])
-
-(PARSE.SHARES
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (shares SHARES idlist)
-                                                             (shares) *)
-    (COND
-       ((EQ PARSE.ATOM 'SHARES)
-        (CONS (PARSE.BIN)
-              (PARSE.IDLIST])
-
-(PARSE.DEFAULT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (default _ defaultopt)
-                                                             (default) *)
-    (COND
-       ((EQ PARSE.ATOM '_)
-        (PARSE.BIN)
-        (PARSE.DEFAULTOPT])
-
-(PARSE.OPTSIZE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (EXP ANSWER)                                       (* (optsize %[ exp %])
-                                                             (optsize) *)
-          (COND
-             ((EQ PARSE.ATOM '%[)
-              (PARSE.BIN)
-              (SETQ EXP (PARSE.EXP))
-              (PARSE.BIN '%])
-              (SETQ ANSWER EXP)))
-          (RETURN ANSWER])
-
-(PARSE.BOUNDS
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (EXP1 EXP2 ANSWER)                                 (* (bounds exp |..| exp) *)
-          (SETQ EXP1 (PARSE.EXP))
-          (PARSE.BIN '|..|)
-          (SETQ EXP2 (PARSE.EXP))
-          (SETQ ANSWER (LIST EXP1 EXP2))
-          (RETURN ANSWER])
-
-(PARSE.LENGTH
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (EXP ANSWER)                                       (* (length %[ exp %]) *)
-          (PARSE.BIN '%[)
-          (SETQ EXP (PARSE.EXP))
-          (PARSE.BIN '%])
-          (SETQ ANSWER EXP)
-          (RETURN ANSWER])
-
-(PARSE.INDEXTYPE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (indextype typeexp)
-                                                             (indextype) *)
-    (COND
-       ((NOT (EQ PARSE.ATOM 'OF))
-        (PARSE.TYPEEXP])
-
-(PARSE.ELSEPART
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (elsepart ELSE statement)
-                                                             (elsepart) *)
-    (COND
-       ((EQ PARSE.ATOM 'ELSE)
-        (PARSE.BIN)
-        (PARSE.STATEMENT])
-
-(PARSE.OTHERPART
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (otherpart => statement)
-                                                             (otherpart) *)
-    (COND
-       ((EQ PARSE.ATOM '=>)
-        (PARSE.BIN)
-        (PARSE.STATEMENT])
-
-(PARSE.FREE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (LHS ANSWER)                                       (* (free lhs %. FREE) *)
-          (SETQ LHS (PARSE.LHS))
-          (PARSE.BIN '%.)
-          (PARSE.BIN 'FREE)
-          (SETQ ANSWER (LIST 'FREE LHS))
-          (RETURN ANSWER])
-
-(PARSE.CATCHANY
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG (STATEMENT ANSWER)                                 (* (catchany ANY => statement) *)
-          (PARSE.BIN 'ANY)
-          (PARSE.BIN '=>)
-          (SETQ STATEMENT (PARSE.STATEMENT))
-          (SETQ ANSWER (LIST 'ANY STATEMENT))
-          (RETURN ANSWER])
-
-(PARSE.NOT
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (not ~) (not NOT) *)
-    (PARSE.BIN])
-
-(PARSE.NEW
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-    (PROG NIL                                                (* BOTH (new lhs %. NEW) *)
-                                                             (* CEDAR (new NEW) *)
-          (COND
-             ((AND (EQ PARSE.ATOM 'NEW)
-                   (EQ PARSE.LANGUAGE 'CEDAR))
-              (PARSE.BIN))
-             (T 
-          
-          (* Throw away lhs. Interlisp doesn't have separate storage "zone"
-          (QUOTE s.) *)
-
-                (PARSE.LHS)
-                (PARSE.BIN '%.)
-                (PARSE.BIN 'NEW])
-
-(PARSE.OPTTYPE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* (opttype %, typeexp)
-                                                             (opttype) *)
-    (COND
-       ((EQ PARSE.ATOM '%,)
-        (PARSE.BIN)
-        (PARSE.TYPEEXP))
-       (T 'ANY])
-
-(PARSE.ARGLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* BOTH (arglist fieldlist)
-                                                             (arglist) *)
-                                                             (* CEDAR (arglist ANY) *)
-    (PROG (ARGLIST)
-          [SETQ ARGLIST (COND
-                           ((EQ PARSE.ATOM '%[)
-                            (COND
-                               ((EQ PARSE.ATOM 'ANY)
-                                (PARSE.THISIS.CEDAR)
-                                (PARSE.BIN))
-                               (T (PARSE.FIELDLIST 'ARGLIST]
-          (BUILD.STORE.ARGLIST ARGLIST])
-
-(PARSE.RETURNLIST
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 12:48")
-                                                             (* BOTH (returnlist RETURNS fieldlist)
-                                                             (returnlist) *)
-                                                             (* CEDAR (returnlist RETURNS ANY) *)
-    (PROG (RETURNLIST)
-          [SETQ RETURNLIST (COND
-                              ((EQ PARSE.ATOM 'RETURNS)
-                               (PARSE.BIN)
-                               (COND
-                                  ((EQ PARSE.ATOM 'ANY)
-                                   (PARSE.THISIS.CEDAR)
-                                   (PARSE.BIN))
-                                  (T (PARSE.FIELDLIST 'RETURNLIST]
-          (BUILD.STORE.RETURNLIST RETURNLIST])
-)
-
-
-
-(* ;; "BUILD ")
-
-
-(RPAQ? BUILD.NEXT.SCOPE NIL)
-
-(RPAQ? BUILD.CURRENT.SCOPE NIL)
-
-(RPAQ? BUILD.SCOPE.STACK NIL)
-
-(RPAQ? BUILD.PREFIX NIL)
-
-(RPAQ? BUILD.FILECOMS NIL)
-
-(RPAQ? BUILD.BOOLEAN.FNS 
-       '(AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP ZEROP MINUSP EVENP ODDP FGREATERP FLESSP 
-             FEQP GREATERP LESSP GEQ LEQ))
-
-(RPAQ? BUILD.CARDINAL.FNS 
-       '(ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN IMINUS IMOD IPLUS IQUOTIENT IREMAINDER ITIMES 
-              LOGAND LOGNOT LOGOR LOGXOR NTHCHARCODE SUB1))
-
-(RPAQ? BUILD.MIXED.FNS '(ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT REMAINDER TIMES))
-
-(RPAQ? BUILD.REAL.FNS 
-       '(ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE FLOAT FMAX FMIN FMINUS FMOD FPLUS 
-               FQUOTIENT FREMAINDER FTIMES LOG SIN SQRT TAN))
-
-(RPAQ? BUILD.QUALIFY.WORDS '(FREE NEW SIZE))
-
-(RPAQ? BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS '= 'IEQP)
-                                          (CONS '%# 'IEQP)
-                                          (CONS '< 'ILESSP)
-                                          (CONS '<= 'ILEQ)
-                                          (CONS '> 'IGREATERP)
-                                          (CONS '>= 'IGEQ)
-                                          (CONS '+ 'IPLUS)
-                                          (CONS '- 'IDIFFERENCE)
-                                          (CONS '* 'ITIMES)
-                                          (CONS '/ 'IQUOTIENT)
-                                          (CONS '0- 'IMINUS)
-                                          (CONS 'MAX 'IMAX)
-                                          (CONS 'MIN 'IMIN)
-                                          (CONS 'MOD 'IMOD)))
-
-(RPAQ? BUILD.MIXED.ARITHOP.ALIST (LIST (CONS '= 'EQP)
-                                       (CONS '%# 'EQP)
-                                       (CONS '< 'LESSP)
-                                       (CONS '<= 'GREATERP)
-                                       (CONS '> 'GREATERP)
-                                       (CONS '>= 'LESSP)
-                                       (CONS '+ 'PLUS)
-                                       (CONS '- 'DIFFERENCE)
-                                       (CONS '* 'TIMES)
-                                       (CONS '/ 'QUOTIENT)
-                                       (CONS '0- 'MINUS)
-                                       (CONS 'MAX 'MAX)
-                                       (CONS 'MIN 'MIN)
-                                       (CONS 'MOD 'IMOD)))
-
-(RPAQ? BUILD.REAL.ARITHOP.ALIST (LIST (CONS '= 'FEQP)
-                                      (CONS '%# 'FEQP)
-                                      (CONS '< 'FLESSP)
-                                      (CONS '<= 'FGREATERP)
-                                      (CONS '> 'FGREATERP)
-                                      (CONS '>= 'FLESSP)
-                                      (CONS '+ 'FPLUS)
-                                      (CONS '- 'FDIFFERENCE)
-                                      (CONS '* 'FTIMES)
-                                      (CONS '/ 'FQUOTIENT)
-                                      (CONS '0- 'FMINUS)
-                                      (CONS 'MAX 'FMAX)
-                                      (CONS 'MIN 'FMIN)
-                                      (CONS 'MOD 'IMOD)))
-
-(RPAQ? BUILD.CARDINAL.TYPES '(CARDINAL CHAR CHARACTER INT INTEGER NAT WORD))
-(DECLARE%: EVAL@COMPILE
-
-(RECORD SCOPE (ID SYMBOLTABLE INITLIST ARGLIST VARLIST RETURNLIST RETURNS OPEN)
-              [ACCESSFNS ((RETURNVARS (FOR PAIRITEM IN (fetch (PAIRLIST ITEMS)
-                                                          of (fetch (SCOPE RETURNLIST) of DATUM))
-                                         collect (BUILD.LOCALVARID NIL (fetch (PAIRITEM ID)
-                                                                          of PAIRITEM])
-)
-(DEFINEQ
-
-(BUILD.INIT
-  [LAMBDA (PREFIX)                                           (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (SETQ BUILD.PREFIX PREFIX)
-          (SETQ BUILD.FILECOMS (FILECOMS (U-CASE PREFIX)))
-          (SETTOPVAL BUILD.FILECOMS NIL)
-          (printout T "Creating " BUILD.FILECOMS T)
-          (SETQ BUILD.NEXT.SCOPE (create SCOPE
-                                        ID _ 'MODULE))
-          (SETQ BUILD.CURRENT.SCOPE NIL)
-          (SETQ BUILD.SCOPE.STACK NIL])
-
-(BUILD.PUSH.SCOPE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (COND
-             (BUILD.CURRENT.SCOPE (push BUILD.SCOPE.STACK BUILD.CURRENT.SCOPE)))
-          (SETQ BUILD.CURRENT.SCOPE BUILD.NEXT.SCOPE)
-          (SETQ BUILD.NEXT.SCOPE (create SCOPE))
-          (RETURN (CAR BUILD.SCOPE.STACK])
-
-(BUILD.POP.SCOPE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (SETQ BUILD.NEXT.SCOPE BUILD.CURRENT.SCOPE)
-          (SETQ BUILD.CURRENT.SCOPE (pop BUILD.SCOPE.STACK))
-          (RETURN BUILD.CURRENT.SCOPE])
-
-(BUILD.GC.SCOPE
-  [LAMBDA NIL                                                (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (SETQ BUILD.NEXT.SCOPE (create SCOPE])
-
-(BUILD.STORE.EXPORTS
-  [LAMBDA (EXPORTS)                                          (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (COND
-             (EXPORTS (SETQ BUILD.PREFIX (CAR EXPORTS])
-
-(BUILD.STORE.IDENTLIST
-  [LAMBDA (IDENTLIST)                                        (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (replace (SCOPE ID) of BUILD.NEXT.SCOPE with (CAR IDENTLIST])
-
-(BUILD.STORE.INTERFACES
-  [LAMBDA (INTERFACES)                                       (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (for INTERFACE in INTERFACES do (BUILD.STORE.INTERFACE INTERFACE])
-
-(BUILD.STORE.INTERFACE
-  [LAMBDA (INTERFACE)                                        (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (PUTPROP INTERFACE 'MESA.INTERFACE T])
-
-(BUILD.STORE.OPEN
-  [LAMBDA (OPEN)                                             (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (replace (SCOPE OPEN) of BUILD.NEXT.SCOPE with OPEN])
-
-(BUILD.STORE.USING
-  [LAMBDA (INTERFACE USING)                                  (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (for USE in USING do (PUTPROP USE 'MESA.USEDBY INTERFACE])
-
-(BUILD.INITIALIZATION
-  [LAMBDA (IDENTLIST TYPEEXP INITIALIZATION)                 (* kbr%: "25-Nov-85 17:27")
-    (PROG (ANSWER)
-          (SELECTQ (BUILD.TYPEATOM TYPEEXP)
-              (PROC (BUILD.INITIALIZE.FN (CAR IDENTLIST)
-                           TYPEEXP INITIALIZATION))
-              (MRECORD (BUILD.INITIALIZE.RECORD (CAR IDENTLIST)
-                              TYPEEXP INITIALIZATION))
-              (SETQ ANSWER (BUILD.INITIALIZE.VARS IDENTLIST TYPEEXP INITIALIZATION 
-                                  BUILD.CURRENT.SCOPE)))
-          (RETURN ANSWER])
-
-(BUILD.INITIALIZE.VARS
-  [LAMBDA (IDENTLIST TYPEEXP INITIALIZATION SCOPE)           (* kbr%: "25-Nov-85 17:27")
-    (PROG (ANSWER)
-          (SETQ ANSWER (for ID in IDENTLIST collect (BUILD.INITIALIZE.VAR ID TYPEEXP INITIALIZATION 
-                                                           SCOPE)))
-          (RETURN ANSWER])
-
-(BUILD.INITIALIZE.VAR
-  [LAMBDA (ID TYPEEXP INITIALIZATION SCOPE)                  (* kbr%: "25-Nov-85 17:27")
-    (PROG (PAIRITEM)
-          (SETQ PAIRITEM (create PAIRITEM
-                                ID _ ID
-                                TYPEEXP _ TYPEEXP
-                                DEFAULT _ INITIALIZATION))
-          (replace (SCOPE SYMBOLTABLE) of SCOPE with (NCONC (fetch (SCOPE SYMBOLTABLE) of SCOPE)
-                                                            (LIST PAIRITEM)))
-          (COND
-             ((NULL BUILD.SCOPE.STACK)
-              (BUILD.ADD.TO.FILECOMS (LIST ID (BUILD.COERCE INITIALIZATION TYPEEXP))
-                     'INITVARS)
-              (PRIN1 ID T)
-              (PRIN1 "," T)))
-          (RETURN ID])
-
-(BUILD.INITIALIZE.FN
-  [LAMBDA (ID TYPEEXP INITIALIZATION)                        (* kbr%: "25-Nov-85 17:27")
-    (PROG (PROCID ARGLIST RETURNLIST LAMBDA)
-          (SETQ PROCID (BUILD.PROCID BUILD.PREFIX ID))
-          (SETQ ARGLIST (fetch (SCOPE ARGLIST) of BUILD.NEXT.SCOPE))
-          (SETQ RETURNLIST (fetch (SCOPE RETURNLIST) of BUILD.NEXT.SCOPE))
-          (PUTPROP ID 'MESA.USEDBY BUILD.PREFIX)
-          (PUTPROP PROCID 'MESA.FN T)
-          (PUTPROP PROCID 'MESA.ARGLIST ARGLIST)
-          (PUTPROP PROCID 'MESA.RETURNLIST RETURNLIST)
-          (SETQ LAMBDA (BUILD.LAMBDA ARGLIST INITIALIZATION))
-          (PUTD PROCID LAMBDA)
-          (BUILD.ADD.TO.FILECOMS PROCID 'FNS)
-          (BUILD.GC.SCOPE)
-          (PRIN1 ID T)
-          (PRIN1 "," T])
-
-(BUILD.INITIALIZE.RECORD
-  [LAMBDA (ID TYPEEXP INITIALIZATION)                        (* kbr%: "25-Nov-85 17:27")
-    (PROG (RECORDID FIELDLIST RECORD)
-          (SETQ RECORDID (BUILD.RECORDID BUILD.PREFIX ID))
-          (replace (MRECORD RECORDID) of TYPEEXP with RECORDID)
-          (SETQ RECORD (BUILD.RECORD RECORDID TYPEEXP))
-          (EVAL RECORD)
-          (BUILD.ADD.TO.FILECOMS RECORDID 'RECORDS)
-          (PUTPROP ID 'MESA.USEDBY BUILD.PREFIX)
-          (PUTPROP RECORDID 'MESA.TYPE TYPEEXP)
-          (PRIN1 ID T)
-          (PRIN1 "," T])
-
-(BUILD.RECORD
-  [LAMBDA (RECORDID TYPEEXP)                                 (* kbr%: "25-Nov-85 17:27")
-    (PROG (FIELDLIST FIELDS DEFAULTS ANSWER)
-          (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of TYPEEXP))
-          (COND
-             [(NULL FIELDLIST)
-          
-          (* I'm not really sure what an empty FIELDLIST is supposed to get you in 
-          MESA/CEDAR. *)
-
-              (RETURN `(TYPERECORD ,RECORDID]
-             [(type? PAIRLIST FIELDLIST)
-              (for ITEM in (REVERSE (fetch (PAIRLIST ITEMS) of FIELDLIST))
-                 do (push FIELDS (fetch (PAIRITEM ID) of ITEM))
-                    (COND
-                       ((fetch (PAIRITEM DEFAULT) of ITEM)
-                        (SETQ DEFAULTS (NCONC DEFAULTS `(,(fetch (PAIRITEM ID) of ITEM)
-                                                         _
-                                                         ,(BUILD.COERCE (fetch (PAIRITEM DEFAULT)
-                                                                           of ITEM)
-                                                                 (fetch (PAIRITEM TYPEEXP)
-                                                                    of ITEM]
-             [(type? TYPELIST FIELDLIST)
-              (for ITEM in (REVERSE (fetch (TYPELIST ITEMS) of FIELDLIST)) as I from 1
-                 do (push FIELDS (PACK* 'FIELD I))
-                    (COND
-                       ((fetch (TYPEITEM DEFAULT) of ITEM)
-                        (SETQ DEFAULTS (NCONC DEFAULTS `(,(PACK* 'FIELD I)
-                                                         _
-                                                         ,(BUILD.COERCE (fetch (TYPEITEM DEFAULT)
-                                                                           of ITEM)
-                                                                 (fetch (TYPEITEM TYPEEXP)
-                                                                    of ITEM]
-             (T (SHOULDNT)))
-          [SETQ ANSWER `(RECORD ,RECORDID ,FIELDS ,@DEFAULTS]
-          (RETURN ANSWER])
-
-(BUILD.TYPE
-  [LAMBDA (IDENTLIST TYPEEXP DEFAULT)                        (* kbr%: "25-Nov-85 17:27")
-    (PROG (ID TYPEID)
-          (SELECTQ (BUILD.TYPEATOM TYPEEXP)
-              (MRECORD (BUILD.INITIALIZE.RECORD (CAR IDENTLIST)
-                              TYPEEXP DEFAULT))
-              (PROGN (SETQ TYPEID (BUILD.TYPEID BUILD.PREFIX (CAR IDENTLIST)))
-                     (COND
-                        ((NOT (EQ TYPEID TYPEEXP))
-                         (PUTPROP (CAR IDENTLIST)
-                                'MESA.USEDBY BUILD.PREFIX)
-                         (PUTPROP TYPEID 'MESA.TYPE TYPEEXP])
-
-(BUILD.STORE.ARGLIST
-  [LAMBDA (ARGLIST)                                          (* kbr%: "25-Nov-85 17:27")
-                                                             (* ARGLIST = args for coming function 
-                                                             scope. *)
-    (PROG NIL
-          (replace (SCOPE ARGLIST) of BUILD.NEXT.SCOPE with ARGLIST)
-          (COND
-             ((type? PAIRLIST ARGLIST)
-              (BUILD.STORE.PAIRLIST ARGLIST])
-
-(BUILD.STORE.RETURNLIST
-  [LAMBDA (RETURNLIST)                                       (* kbr%: "25-Nov-85 17:27")
-                                                             (* RETURNLIST = args for coming 
-                                                             function scope. *)
-    (PROG NIL
-          (replace (SCOPE RETURNLIST) of BUILD.NEXT.SCOPE with RETURNLIST)
-          (COND
-             ((type? PAIRLIST RETURNLIST)
-              (BUILD.STORE.PAIRLIST RETURNLIST])
-
-(BUILD.STORE.PAIRLIST
-  [LAMBDA (PAIRLIST)                                         (* kbr%: "25-Nov-85 17:27")
-          
-          (* PAIRLIST = args or return vals for coming function scope.
-          *)
-
-    (PROG NIL
-          (for PAIRITEM in (fetch (PAIRLIST ITEMS) of PAIRLIST) collect (BUILD.STORE.PAIRITEM 
-                                                                               PAIRITEM 
-                                                                               BUILD.NEXT.SCOPE])
-
-(BUILD.STORE.PAIRITEM
-  [LAMBDA (PAIRITEM SCOPE)                                   (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (replace (SCOPE SYMBOLTABLE) of SCOPE with (NCONC (fetch (SCOPE SYMBOLTABLE) of SCOPE)
-                                                            (LIST PAIRITEM)))
-          (RETURN (fetch (PAIRITEM ID) of PAIRITEM])
-
-(BUILD.STORE.VARLIST
-  [LAMBDA (VARLIST)                                          (* kbr%: "25-Nov-85 17:27")
-    (PROG NIL
-          (replace (SCOPE VARLIST) of BUILD.CURRENT.SCOPE with VARLIST])
-
-(BUILD.ID
-  [LAMBDA (INTERFACE ID)                                     (* kbr%: "25-Nov-85 17:27")
-    (PROG (ANSWER)
-          (COND
-             ((STRPOS "." ID)
-              (RETURN ID)))
-          [SETQ INTERFACE (OR INTERFACE (GETPROP ID 'MESA.USEDBY]
-          (SETQ ANSWER (COND
-                          (INTERFACE (PACK* INTERFACE "." ID))
-                          (T ID)))
-          (RETURN ANSWER])
-
-(BUILD.FIELDID
-  [LAMBDA (INTERFACE ID)                                     (* kbr%: "25-Nov-85 17:27")
-    ID])
-
-(BUILD.PROCID
-  [LAMBDA (INTERFACE ID)                                     (* kbr%: "25-Nov-85 17:27")
-    (BUILD.ID INTERFACE ID])
-
-(BUILD.RECORDID
-  [LAMBDA (INTERFACE ID)                                     (* kbr%: "25-Nov-85 17:27")
-    (BUILD.ID INTERFACE ID])
-
-(BUILD.TYPEID
-  [LAMBDA (INTERFACE ID)                                     (* kbr%: "25-Nov-85 17:27")
-    (COND
-       ((FMEMB ID PARSE.PREDEFINED.TYPES)
-        ID)
-       (T (BUILD.ID INTERFACE ID])
-
-(BUILD.VARID
-  [LAMBDA (INTERFACE ID)                                     (* kbr%: "25-Nov-85 17:27")
-    (PROG (ANSWER)
-          [SETQ ANSWER (COND
-                          ((BUILD.LOOKUP ID)
-                           (BUILD.LOCALVARID INTERFACE ID))
-                          (T (BUILD.GLOBALVARID INTERFACE ID]
-          (RETURN ANSWER])
-
-(BUILD.LOCALVARID
-  [LAMBDA (INTERFACE ID)                                     (* kbr%: "25-Nov-85 17:27")
-    ID])
-
-(BUILD.GLOBALVARID
-  [LAMBDA (INTERFACE ID)                                     (* kbr%: "25-Nov-85 17:27")
-    (BUILD.ID INTERFACE ID])
-
-(BUILD.ULTIMATE.TYPE
-  [LAMBDA (EXP)                                              (* kbr%: "25-Nov-85 17:27")
-    (BUILD.REFINE.TYPE (BUILD.IMMEDIATE.TYPE EXP])
-
-(BUILD.REFINE.TYPE
-  [LAMBDA (TYPE)                                             (* kbr%: "25-Nov-85 17:27")
-    (PROG (PAIRITEM NEXTTYPE)
-      LOOP
-          (SETQ NEXTTYPE (COND
-                            ((OR (FMEMB TYPE '(ANY MPROC INTERFACE))
-                                 (FMEMB TYPE PARSE.PREDEFINED.TYPES))
-                             (SELECTQ TYPE
-                                 (BOOL 'BOOLEAN)
-                                 (CHAR 'CHARACTER)
-                                 ((INT INTEGER NAT WORD) 
-                                      'CARDINAL)
-                                 (StringBody 'STRING)
-                                 (UNSPECIFIED 'ANY)
-                                 TYPE))
-                            ((LITATOM TYPE)
-                             (OR (BUILD.LOOKUP.TYPE TYPE)
-                                 (PROGN (printout T T TYPE " type unknown." T)
-                                        (PUTPROP TYPE 'MESA.TYPE 'UNDECLARED)
-                                        TYPE)))
-                            ((type? MINTERVAL TYPE)
-                             (fetch (MINTERVAL LBOUND) of TYPE))
-                            ((type? MPOINTER TYPE)
-                             (fetch (MPOINTER TYPE) of TYPE))
-                            ((type? MREF TYPE)
-                             (fetch (MREF TYPE) of TYPE))
-                            (T TYPE)))
-          (COND
-             ((EQ NEXTTYPE 'UNDECLARED)
-              (RETURN TYPE))
-             ((NOT (EQ NEXTTYPE TYPE))
-              (SETQ TYPE NEXTTYPE)
-              (GO LOOP)))
-          (RETURN TYPE])
-
-(BUILD.IMMEDIATE.TYPE
-  [LAMBDA (EXP)                                              (* kbr%: "25-Nov-85 17:27")
-    (PROG (TYPE FN RECORDNAME FIELDNAME MRECORD FIELDLIST PAIRITEM)
-          [SETQ TYPE (COND
-                        ((OR (NULL EXP)
-                             (EQ EXP T))
-                         'BOOLEAN)
-                        [(LITATOM EXP)
-                         (OR (BUILD.LOOKUP.TYPE EXP)
-                             (PROGN (printout T T EXP " type unknown." T)
-                                    'ANY]
-                        ((FIXP EXP)
-                         'CARDINAL)
-                        ((FLOATP EXP)
-                         'REAL)
-                        ((STRINGP EXP)
-                         'STRING)
-                        [(LISTP EXP)
-                         (SETQ FN (CAR EXP))
-                         (COND
-                            ((EQ FN 'SETQ)
-                             (BUILD.IMMEDIATE.TYPE (CADR EXP)))
-                            [(EQ FN 'CAR)
-                             (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP)))
-                             (COND
-                                ((type? MLIST TYPE)
-                                 (fetch (MLIST TYPE) of TYPE))
-                                (T (printout T T EXP " type unknown." T)
-                                   'ANY]
-                            [(EQ FN 'CDR)
-                             (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP)))
-                             (COND
-                                ((type? MLIST TYPE)
-                                 TYPE)
-                                (T (printout T T EXP " type unknown." T)
-                                   'ANY]
-                            [(FMEMB FN '(CONS LIST))
-                             (SETQ TYPE (BUILD.IMMEDIATE.TYPE (CADR EXP)))
-                             (COND
-                                (TYPE (create MLIST
-                                             TYPE _ TYPE))
-                                (T (printout T T EXP " type unknown." T)
-                                   'ANY]
-                            [(EQ FN 'COND)
-                             (BUILD.IMMEDIATE.TYPE (CADR (CADR EXP]
-                            [(EQ FN 'ELT)
-                             (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP)))
-                             (COND
-                                ((type? MARRAY TYPE)
-                                 (fetch (MARRAY TYPE) of TYPE))
-                                (T (printout T T EXP " type unknown." T)
-                                   'ANY]
-                            ((EQ FN 'create)
-                             (CADR EXP))
-                            [(EQ FN 'fetch)
-                             (SETQ RECORDNAME (CAR (CADR EXP)))
-                             (SETQ FIELDNAME (CADR (CADR EXP)))
-                             (SETQ MRECORD (GETPROP RECORDNAME 'MESA.TYPE))
-                             (COND
-                                ((EQ MRECORD 'UNDECLARED)
-                                 'ANY)
-                                (T (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of MRECORD))
-                                   (COND
-                                      ((type? PAIRLIST FIELDLIST)
-                                       (SETQ PAIRITEM (ASSOC FIELDNAME (fetch (PAIRLIST ITEMS)
-                                                                          of FIELDLIST)))
-                                       (fetch (PAIRITEM TYPEEXP) of PAIRITEM))
-                                      (T (printout T T EXP " type unknown." T)
-                                         'ANY]
-                            ((FMEMB FN BUILD.BOOLEAN.FNS)
-                             'BOOLEAN)
-                            ((FMEMB FN BUILD.CARDINAL.FNS)
-                             'CARDINAL)
-                            ((FMEMB FN BUILD.MIXED.FNS)
-                             'MIXED)
-                            ((FMEMB FN BUILD.REAL.FNS)
-                             'REAL)
-                            (T (printout T T EXP " type unknown." T)
-                               'ANY]
-                        (T (printout T T EXP " type unknown." T)
-                           'ANY]
-          (RETURN TYPE])
-
-(BUILD.LOOKUP.TYPE
-  [LAMBDA (ID)                                               (* kbr%: "25-Nov-85 17:27")
-    (PROG (PAIRITEM TYPE)
-          (SETQ PAIRITEM (BUILD.LOOKUP ID))
-          (COND
-             (PAIRITEM (SETQ TYPE (fetch (PAIRITEM TYPEEXP) of PAIRITEM))
-                    (RETURN TYPE)))
-          [SETQ TYPE (COND
-                        ((GETPROP ID 'MESA.TYPE))
-                        ((GETPROP ID 'MESA.USEDBY)
-                         (BUILD.ID (GETPROP ID 'MESA.USEDBY)
-                                ID))
-                        ((GETPROP ID 'MESA.FN)
-                         (RETURN 'MPROC))
-                        ((GETPROP ID 'MESA.INTERFACE)
-                         (RETURN 'INTERFACE]
-          (RETURN TYPE])
-
-(BUILD.LOOKUP
-  [LAMBDA (ID)                                               (* kbr%: "25-Nov-85 17:27")
-    (PROG (ANSWER)
-          [for SCOPE in (CONS BUILD.CURRENT.SCOPE BUILD.SCOPE.STACK)
-             do (SETQ ANSWER (ASSOC ID (fetch (SCOPE SYMBOLTABLE) of SCOPE)))
-                (COND
-                   (ANSWER (RETURN]
-          (RETURN ANSWER])
-
-(BUILD.TYPEATOM
-  [LAMBDA (TYPEEXP)                                          (* kbr%: "25-Nov-85 17:27")
-    (COND
-       ((LITATOM TYPEEXP)
-        TYPEEXP)
-       (T (CAR TYPEEXP])
-
-(BUILD.QUALIFY
-  [LAMBDA (LHS QUALIFIER)                                    (* kbr%: "25-Nov-85 17:27")
-    (PROG (TYPE TYPEATOM ANSWER)                             (* (qualifier %. prefixop)
-                                                             (qualifier %. typeop)
-                                                             (qualifier %. SIZE) (qualifier %[ 
-                                                             explist optcatch %])
-                                                             (qualifier %. id) (qualifier ^) *)
-          [SETQ ANSWER (COND
-                          ((FMEMB QUALIFIER PARSE.PREFIXOPS)
-                           (BUILD.QUALIFY.PREFIXOP LHS QUALIFIER))
-                          ((FMEMB QUALIFIER PARSE.TYPEOPS)
-                           (BUILD.QUALIFY.TYPEOP LHS QUALIFIER))
-                          ((EQ QUALIFIER 'SIZE)
-                           (PACK* LHS "." QUALIFIER))
-                          [(EQ QUALIFIER 'first)
-                           `(CAR ,LHS]
-                          [(EQ QUALIFIER 'rest)
-                           `(CDR ,LHS]
-                          ((OR (NULL QUALIFIER)
-                               (LISTP QUALIFIER))
-                           (BUILD.QUALIFY.EXPLIST LHS QUALIFIER))
-                          ((EQ QUALIFIER '^)
-                           LHS)
-                          (T (BUILD.QUALIFY.ID LHS QUALIFIER]
-          (RETURN ANSWER])
-
-(BUILD.QUALIFY.PREFIXOP
-  [LAMBDA (LHS QUALIFIER)                                    (* kbr%: "25-Nov-85 17:27")
-    (SELECTQ QUALIFIER
-        ((MAX MIN) 
-             (BUILD.ARITH.EXP* QUALIFIER LHS))
-        (CONS QUALIFIER LHS])
-
-(BUILD.QUALIFY.TYPEOP
-  [LAMBDA (LHS QUALIFIER)                                    (* kbr%: "25-Nov-85 17:27")
-    (CONS QUALIFIER LHS])
-
-(BUILD.QUALIFY.EXPLIST
-  [LAMBDA (LHS EXPLIST)                                      (* kbr%: "25-Nov-85 17:27")
-                                                             (* Qualify LHS with EXPLIST qualifier.
-                                                             *)
-    (PROG (TYPE TYPEATOM EXPITEMS ANSWER)
-          [COND
-             ((LITATOM LHS)
-              (SETQ LHS (BUILD.ID NIL LHS]
-          (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS))
-          (SETQ TYPEATOM (BUILD.TYPEATOM TYPE))
-          (SETQ EXPITEMS (fetch (EXPLIST ITEMS) of EXPLIST))
-          [SETQ ANSWER (SELECTQ TYPEATOM
-                           (MARRAY `(ELT ,LHS ,@EXPITEMS))
-                           (MPROC (BUILD.CALL LHS EXPLIST))
-                           (STRING `(NTHCHARCODE ,LHS ,@EXPITEMS))
-                           (MRECORD                          (* Presumably record contains 
-                                                             SEQUENCE. *)
-                                    `(ELT ,LHS ,@EXPITEMS))
-                           (COND
-                              ((AND (LISTP LHS)
-                                    (IEQP (LENGTH LHS)
-                                          2))                (* "ARG1.FN[ARG2,...,ARGn]" *)
-                               (APPEND LHS EXPITEMS))
-                              (T (printout T T LHS " qualified by " EXPLIST "?" T)
-                                 (COND
-                                    [(AND (type? ORDERLIST EXPLIST)
-                                          (IEQP (LENGTH EXPITEMS)
-                                                1))          (* Guess array access.
-                                                             *)
-                                     `(ELT ,LHS ,@EXPITEMS]
-                                    (T (CONS LHS EXPITEMS]
-          (RETURN ANSWER])
-
-(BUILD.QUALIFY.ID
-  [LAMBDA (LHS QUALIFIER)                                    (* kbr%: "25-Nov-85 17:27")
-                                                             (* Qualify LHS with id QUALIFIER.
-                                                             *)
-    (PROG (TYPE TYPEATOM ANSWER)
-          (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS))
-          (SETQ TYPEATOM (BUILD.TYPEATOM TYPE))
-          [SETQ ANSWER (SELECTQ TYPEATOM
-                           (MRECORD `(fetch (,(fetch (MRECORD RECORDID) of TYPE) ,QUALIFIER)
-                                        of ,LHS))
-                           (MARRAY (printout T T LHS " qualified by " QUALIFIER "?" T)
-                                   `(ELT ,LHS ,QUALIFIER))
-                           (INTERFACE (BUILD.ID LHS QUALIFIER))
-                           (MPROC (COND
-                                     (QUALIFIER (LIST LHS QUALIFIER))
-                                     (T (LIST LHS))))
-                           (STRING (printout T T LHS " qualified by " QUALIFIER "?" T)
-                                   `(NTHCHARCODE ,LHS ,QUALIFIER))
-                           (COND
-                              [(EQ (GETPROP TYPE 'MESA.TYPE)
-                                   'UNDECLARED)              (* Guess undeclared record.
-                                                             *)
-                               `(fetch (,TYPE ,QUALIFIER) of ,LHS]
-                              (T                             (* Guess undeclared fn.
-                                                             *)
-                                 (LIST QUALIFIER LHS]
-          (RETURN ANSWER])
-
-(BUILD.ARITH.EXP1
-  [LAMBDA (ARITHOP EXP1)                                     (* kbr%: "25-Nov-85 17:27")
-    [COND
-       ((EQ ARITHOP '-)
-        (SETQ ARITHOP '0-]
-    (BUILD.ARITH.EXP* ARITHOP (LIST EXP1])
-
-(BUILD.ARITH.EXP2
-  [LAMBDA (ARITHOP EXP1 EXP2)                                (* kbr%: "25-Nov-85 17:27")
-    (PROG (ANSWER)
-          (SETQ ANSWER (BUILD.ARITH.EXP* ARITHOP (LIST EXP1 EXP2)))
-          (RETURN ANSWER])
-
-(BUILD.ARITH.EXP*
-  [LAMBDA (ARITHOP EXPS)                                     (* kbr%: "25-Nov-85 17:27")
-    (PROG (TYPE NEWARITHOP ANSWER)
-          (SETQ TYPE (BUILD.STRONGEST.TYPE.AMONG EXPS))
-          (SETQ NEWARITHOP (BUILD.COERCE.ARITHOP ARITHOP TYPE))
-          [COND
-             ((EQ TYPE 'REAL)
-              (SETQ EXPS (for EXP in EXPS collect (COND
-                                                     ((FIXP EXP)
-                                                      (FLOAT EXP))
-                                                     (T EXP]
-          (SETQ ANSWER (CONS NEWARITHOP EXPS))
-          [COND
-             ((FMEMB NEWARITHOP '(IPLUS IDIFFERENCE))
-              (SETQ ANSWER (BUILD.ARITH.ADD1SUB1 ANSWER)))
-             [(AND (EQ ARITHOP '0-)
-                   (NUMBERP (CADR ANSWER)))
-              (SETQ ANSWER (APPLY* (CAR ANSWER)
-                                  (CADR ANSWER]
-             ([OR (EQ ARITHOP '%#)
-                  (AND (FMEMB ARITHOP (LIST '<= '>=))
-                       (NOT (EQ TYPE 'CARDINAL]
-              (SETQ ANSWER (LIST 'NOT ANSWER]
-          (RETURN ANSWER])
-
-(BUILD.ARITH.ADD1SUB1
-  [LAMBDA (EXP)                                              (* kbr%: "25-Nov-85 17:27")
-          
-          (* Use ADD1 or SUB1 instead of IPLUS or IDIFFERENCE if possible.
-          *)
-
-    (PROG (FN EXP1 EXP2 ANSWER)
-          (COND
-             ((NOT (IEQP (FLENGTH EXP)
-                         3))
-              (RETURN EXP)))
-          (SETQ FN (CAR EXP))
-          (SETQ EXP1 (CADR EXP))
-          (SETQ EXP2 (CADDR EXP))
-          (COND
-             [(EQ FN 'IPLUS)
-              (COND
-                 ((EQ EXP1 1)
-                  (SETQ ANSWER (BUILD.ADD1 EXP2)))
-                 ((EQ EXP2 1)
-                  (SETQ ANSWER (BUILD.ADD1 EXP1)))
-                 (T (SETQ ANSWER EXP]
-             ((AND (EQ FN 'IDIFFERENCE)
-                   (EQ EXP2 1))
-              (SETQ ANSWER (BUILD.SUB1 EXP1)))
-             (T (SETQ ANSWER EXP)))
-          (RETURN ANSWER])
-
-(BUILD.COERCE.ARITHOP
-  [LAMBDA (ARITHOP TYPE)                                     (* kbr%: "25-Nov-85 17:27")
-    (SELECTQ TYPE
-        (CARDINAL (CDR (ASSOC ARITHOP BUILD.CARDINAL.ARITHOP.ALIST)))
-        (MIXED (CDR (ASSOC ARITHOP BUILD.MIXED.ARITHOP.ALIST)))
-        (REAL (CDR (ASSOC ARITHOP BUILD.REAL.ARITHOP.ALIST)))
-        (SHOULDNT])
-
-(BUILD.STRONGEST.TYPE.AMONG
-  [LAMBDA (EXPS)                                             (* kbr%: "25-Nov-85 17:27")
-    (PROG (TYPE)
-          (SETQ TYPE 'CARDINAL)
-          [for EXP in EXPS while (NOT (EQ TYPE 'REAL)) do (SETQ TYPE (BUILD.STRONGEST.TYPE
-                                                                      TYPE
-                                                                      (BUILD.ULTIMATE.TYPE EXP]
-          (RETURN TYPE])
-
-(BUILD.STRONGEST.TYPE
-  [LAMBDA (TYPE1 TYPE2)                                      (* kbr%: "25-Nov-85 17:27")
-    [COND
-       ((FMEMB TYPE1 BUILD.CARDINAL.TYPES)
-        (SETQ TYPE1 'CARDINAL]
-    [COND
-       ((FMEMB TYPE2 BUILD.CARDINAL.TYPES)
-        (SETQ TYPE2 'CARDINAL]
-    (SELECTQ TYPE1
-        (CARDINAL (SELECTQ TYPE2
-                      (CARDINAL 'CARDINAL)
-                      (REAL 'REAL)
-                      'MIXED))
-        (MIXED (SELECTQ TYPE2
-                   (REAL 'REAL)
-                   'MIXED))
-        (REAL 'REAL)
-        'MIXED])
-
-(BUILD.COERCE
-  [LAMBDA (EXP TYPE)                                         (* kbr%: "25-Nov-85 17:27")
-    (PROG (TYPEEXP ANSWER)
-          (SETQ TYPEEXP (BUILD.REFINE.TYPE TYPE))
-          (SETQ ANSWER (COND
-                          ((type? MARRAY TYPEEXP)
-                           (FRESHLINE T)
-                           (printout T T "Coercion to " TYPE " array type." T)
-                           (BUILD.COERCE.MARRAY EXP TYPEEXP))
-                          ((type? MLIST TYPEEXP)
-                           (BUILD.COERCE.MLIST EXP TYPEEXP))
-                          ((type? EXPLIST EXP)
-                           (BUILD.COERCE.EXPLIST EXP TYPEEXP))
-                          (T EXP)))
-          (RETURN ANSWER])
-
-(BUILD.COERCE.MARRAY
-  [LAMBDA (EXP MARRAY)                                       (* kbr%: "25-Nov-85 17:27")
-    (PROG (TYPE ANSWER)
-          
-          (* This is legal MESA/CEDAR code with no very elegant Interlisp translation.
-          *)
-
-          (SETQ TYPE (fetch (MARRAY TYPE) of MARRAY))
-          (SETQ ANSWER (COND
-                          [(type? EXPLIST EXP)               (* Should be an ORDERLIST.
-                                                             *)
-                           (CONS 'LIST (for ITEM in (fetch (EXPLIST ITEMS) of EXP)
-                                          collect (BUILD.COERCE ITEM TYPE]
-                          (T                                 (* EXP might be an MARRAY var.
-                                                             *)
-                             EXP)))
-          (RETURN ANSWER])
-
-(BUILD.COERCE.MLIST
-  [LAMBDA (EXP MLIST)                                        (* kbr%: "25-Nov-85 17:27")
-    (PROG (TYPE ANSWER)
-          (SETQ TYPE (fetch (MLIST TYPE) of MLIST))
-          (SETQ ANSWER (COND
-                          ((NOT (LISTP EXP))
-                           EXP)
-                          [(EQ (CAR EXP)
-                               'LIST)
-                           `(LIST ,@(for ITEM in (CDR EXP) collect (BUILD.COERCE ITEM TYPE]
-                          [(EQ (CAR EXP)
-                               'CONS)
-                           `(CONS ,(BUILD.COERCE (CADR EXP)
-                                          TYPE) ,(BUILD.COERCE (CADDR EXP)
-                                                        MLIST]
-                          (T EXP)))
-          (RETURN ANSWER])
-
-(BUILD.COERCE.EXPLIST
-  [LAMBDA (EXPLIST MRECORD)                                  (* kbr%: "25-Nov-85 17:27")
-          
-          (* Converts a Mesa explist EXPLIST (ambiguous by itself) into a CREATE TYPE 
-          Lisp expression. *)
-
-    (PROG (FIELDLIST ALIGNMENT SETTINGS ANSWER)
-          (COND
-             ((NOT (type? EXPLIST EXPLIST))
-              (RETURN EXPLIST)))
-          [COND
-             ((NOT (type? MRECORD MRECORD))
-              (printout T T MRECORD " not a record" T)       (* Proceed to do the best we can.
-                                                             *)
-              [COND
-                 ((type? KEYLIST EXPLIST)
-                  [SETQ SETTINGS (for ITEM in (fetch (KEYLIST ITEMS) of EXPLIST)
-                                    join `(,(fetch (KEYITEM ID) of ITEM) _ ,(fetch (KEYITEM OPTEXP)
-                                                                               of ITEM]
-                  (RETURN `(create ,MRECORD ,@SETTINGS]
-              (RETURN `(,MRECORD ,@(fetch (EXPLIST ITEMS) of EXPLIST]
-          (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of MRECORD))
-          (SETQ ALIGNMENT (BUILD.ALIGN FIELDLIST EXPLIST))
-          [SETQ SETTINGS (COND
-                            [(type? PAIRLIST FIELDLIST)
-                             (for PAIRITEM in (fetch (PAIRLIST ITEMS) of FIELDLIST) as ALIGNVALUE
-                                in ALIGNMENT when [NOT (FMEMB ALIGNVALUE '(NIL TRASH]
-                                join `(,(fetch (PAIRITEM ID) of PAIRITEM) _ ,ALIGNVALUE]
-                            [(type? TYPELIST FIELDLIST)
-                             (for TYPEITEM in (fetch (TYPELIST ITEMS) of FIELDLIST) as ALIGNVALUE
-                                in ALIGNMENT as I from 1
-                                when [NOT (FMEMB ALIGNVALUE '(NIL TRASH]
-                                join `(,(PACK* 'FIELD I) _ ,ALIGNVALUE]
-                            (T (SHOULDNT]
-      EXIT
-          [SETQ ANSWER `(create ,(fetch (MRECORD RECORDID) of MRECORD) ,@SETTINGS]
-          (RETURN ANSWER])
-
-(BUILD.ALIGN
-  [LAMBDA (FIELDLIST EXPLIST)                                (* kbr%: "25-Nov-85 17:27")
-    (PROG (ANSWER)
-          [SETQ ANSWER (COND
-                          ((AND (NULL FIELDLIST)
-                                (NULL EXPLIST))
-                           NIL)
-                          ((EQ FIELDLIST 'ANY)
-                           (fetch (EXPLIST ITEMS) of EXPLIST))
-                          [(type? ORDERLIST EXPLIST)
-                           (COND
-                              ((type? PAIRLIST FIELDLIST)
-                               (for PAIRITEM in (fetch (PAIRLIST ITEMS) of FIELDLIST) as OPTEXP
-                                  in (fetch (ORDERLIST ITEMS) of EXPLIST)
-                                  collect (BUILD.ALIGN.VALUE (fetch (PAIRITEM TYPEEXP) of PAIRITEM)
-                                                 (fetch (PAIRITEM DEFAULT) of PAIRITEM)
-                                                 OPTEXP)))
-                              ((type? TYPELIST FIELDLIST)
-                               (for TYPEITEM in (fetch (TYPELIST ITEMS) of FIELDLIST) as OPTEXP
-                                  in (fetch (ORDERLIST ITEMS) of EXPLIST)
-                                  collect (BUILD.ALIGN.VALUE (fetch (TYPEITEM TYPEEXP) of TYPEITEM)
-                                                 (fetch (TYPEITEM DEFAULT) of TYPEITEM)
-                                                 OPTEXP)))
-                              (T (SHOULDNT]
-                          [(type? KEYLIST EXPLIST)
-                           (COND
-                              ((NOT (type? PAIRLIST FIELDLIST))
-                               (SHOULDNT)))
-                           (for PAIRITEM in (fetch (PAIRLIST ITEMS) of FIELDLIST)
-                              collect (BUILD.ALIGN.VALUE (fetch (PAIRITEM TYPEEXP) of PAIRITEM)
-                                             (fetch (PAIRITEM DEFAULT) of PAIRITEM)
-                                             (fetch (KEYITEM OPTEXP)
-                                                of (ASSOC (fetch (PAIRITEM ID) of PAIRITEM)
-                                                          (fetch (KEYLIST ITEMS) of EXPLIST]
-                          (T (SHOULDNT]
-          (RETURN ANSWER])
-
-(BUILD.ALIGN.VALUE
-  [LAMBDA (TYPEEXP DEFAULT OPTEXP)                           (* kbr%: "25-Nov-85 17:27")
-    (PROG (ANSWER)
-          [SETQ ANSWER (OR (COND
-                              ((AND (fetch (DEFAULT TRASH) of DEFAULT)
-                                    (EQ OPTEXP 'TRASH))
-                               'TRASH))
-                           (BUILD.COERCE OPTEXP TYPEEXP)
-                           (COPY (fetch (DEFAULT EXP) of DEFAULT]
-          (RETURN ANSWER])
-
-(BUILD.ADD.TO.FILECOMS
-  [LAMBDA (NAME TYPE)                                        (* kbr%: "25-Nov-85 17:27")
-    (PROG (FILECOMSVAR FILECOMS)
-          (SETQ FILECOMSVAR BUILD.FILECOMS)
-          (SETQ FILECOMS (GETTOPVAL FILECOMSVAR))            (* FILECOMS is reversed at this point.
-                                                             *)
-          [COND
-             ((AND FILECOMS (EQ (CAR (CAR FILECOMS))
-                                TYPE))
-              (NCONC (CAR FILECOMS)
-                     (LIST NAME)))
-             (T (push FILECOMS (LIST TYPE NAME]
-          (SETTOPVAL FILECOMSVAR FILECOMS])
-
-(BUILD.ADD1
-  [LAMBDA (EXP)                                              (* kbr%: "25-Nov-85 17:27")
-    (COND
-       ((FIXP EXP)
-        (ADD1 EXP))
-       (T `(ADD1 ,EXP])
-
-(BUILD.CALL
-  [LAMBDA (FN EXPLIST)                                       (* kbr%: "25-Nov-85 17:27")
-          
-          (* Function call. Cons FN onto front of coerced EXPLIST items.
-          *)
-
-    (CONS FN (BUILD.ALIGN (GETPROP FN 'MESA.ARGLIST)
-                    EXPLIST])
-
-(BUILD.CHARCODE
-  [LAMBDA (CHARCODE)                                         (* kbr%: "25-Nov-85 17:27")
-    (PROG (META CONTROL CHAR NAME ANSWER)
-          [SETQ NAME (SELECTQ CHARCODE
-                         (0 'NULL)
-                         (7 'BELL)
-                         (8 'BS)
-                         (9 'TAB)
-                         (10 'LF)
-                         (12 'FF)
-                         (13 'CR)
-                         (27 'ESC)
-                         (32 'SPACE)
-                         (127 'DEL)
-                         (PROGN [COND
-                                   ((IGEQ CHARCODE 128)
-                                    (SETQ META T)
-                                    (SETQ CHARCODE (IDIFFERENCE CHARCODE 128]
-                                [COND
-                                   ((ILESSP CHARCODE 32)
-                                    (SETQ CONTROL T)
-                                    (SETQ CHARCODE (IPLUS CHARCODE 32]
-                                (SETQ CHAR (MKATOM (CHARACTER CHARCODE)))
-                                (COND
-                                   ((AND META CONTROL)
-                                    (PACK* '%#^ CHAR))
-                                   (META (PACK* '%# CHAR))
-                                   (CONTROL (PACK* '^ CHAR))
-                                   (T CHAR]
-          (SETQ ANSWER (LIST 'CHARCODE NAME))
-          (RETURN ANSWER])
-
-(BUILD.COND
-  [LAMBDA (EXP1 EXP2 EXP3)                                   (* kbr%: "25-Nov-85 17:27")
-    (PROG (HEAD TAIL ANSWER)
-          (SETQ HEAD (CONS EXP1 (BUILD.TAIL EXP2)))
-          [SETQ TAIL (COND
-                        ((NULL EXP3)
-                         NIL)
-                        ((AND (LISTP EXP3)
-                              (EQ (CAR EXP3)
-                                  'COND))
-                         (CDR EXP3))
-                        (T `((T ,@(BUILD.TAIL EXP3]
-          [SETQ ANSWER `(COND
-                           ,HEAD
-                           ,@TAIL]
-          (RETURN ANSWER])
-
-(BUILD.COPY.OF
-  [LAMBDA (EXP)                                              (* kbr%: "25-Nov-85 17:27")
-    (COND
-       ((AND (LISTP EXP)
-             (EQ (CAR EXP)
-                 'SETQ))
-        (CADR EXP))
-       (T (COPY EXP])
-
-(BUILD.FETCH
-  [LAMBDA (RECORDNAME FIELDNAME DATUM)                       (* kbr%: "25-Nov-85 17:27")
-    (PROG (MRECORD ANSWER)
-          [SETQ MRECORD (COND
-                           (RECORDNAME (BUILD.REFINE.TYPE RECORDNAME))
-                           (T (BUILD.ULTIMATE.TYPE DATUM]
-          [SETQ ANSWER (COND
-                          [(type? MRECORD MRECORD)
-                           (SETQ RECORDNAME (fetch (MRECORD RECORDID) of MRECORD))
-                           `(fetch (,RECORDNAME ,FIELDNAME) of ,DATUM]
-                          (T (printout T T "Bad fetch " RECORDNAME " " FIELDNAME " " DATUM T)
-                             (LIST FIELDNAME DATUM]
-          (RETURN ANSWER])
-
-(BUILD.FORCLAUSE.BY
-  [LAMBDA (CONTROLID EXP1 EXP2)                              (* kbr%: "25-Nov-85 17:27")
-    `(for ,CONTROLID _ ,EXP1 by ,EXP2])
-
-(BUILD.FORCLAUSE.IN
-  [LAMBDA (CONTROLID DIRECTION RANGE)                        (* kbr%: "25-Nov-85 17:27")
-    (PROG (INTERVAL LBOUND UBOUND ANSWER)
-          (SETQ INTERVAL (fetch (MRANGE INTERVAL) of RANGE))
-          (SETQ LBOUND (fetch (MINTERVAL LBOUND) of INTERVAL))
-          (SETQ UBOUND (fetch (MINTERVAL UBOUND) of INTERVAL))
-          (SELECTQ (fetch (MINTERVAL KIND) of INTERVAL)
-              (CC)
-              (CO (SETQ UBOUND (BUILD.SUB1 UBOUND)))
-              (OC (SETQ LBOUND (BUILD.ADD1 LBOUND)))
-              (OO (SETQ LBOUND (BUILD.ADD1 LBOUND))
-                  (SETQ UBOUND (BUILD.SUB1 UBOUND)))
-              (SHOULDNT))
-          [SETQ ANSWER (COND
-                          ((EQ DIRECTION 'DECREASING)
-                           `(for ,CONTROLID from ,LBOUND to ,UBOUND by -1))
-                          (T `(for ,CONTROLID from ,LBOUND to ,UBOUND]
-          (RETURN ANSWER])
-
-(BUILD.FORCLAUSE.THROUGH
-  [LAMBDA (RANGE)                                            (* kbr%: "25-Nov-85 17:27")
-    (BUILD.FORCLAUSE.IN 'X NIL RANGE])
-
-(BUILD.IN
-  [LAMBDA (EXP RANGE)                                        (* kbr%: "25-Nov-85 17:28")
-    (PROG (INTERVAL EXP2 LPRED UPRED ANSWER)
-          (SETQ RANGE (BUILD.REFINE.TYPE RANGE))
-          [COND
-             ((NOT (type? MRANGE RANGE))
-              (printout T T RANGE " not a range." T)
-              (RETURN `(in ,RANGE]
-          (SETQ INTERVAL (fetch (MRANGE INTERVAL) of RANGE))
-          (SELECTQ (fetch (MINTERVAL KIND) of INTERVAL)
-              (CC (SETQ LPRED 'IGEQ)
-                  (SETQ UPRED 'ILEQ))
-              (CO (SETQ LPRED 'IGEQ)
-                  (SETQ UPRED 'ILESSP))
-              (OC (SETQ LPRED 'IGREATERP)
-                  (SETQ UPRED 'ILEQ))
-              (OO (SETQ LPRED 'ILESSP)
-                  (SETQ UPRED 'IGREATERP))
-              (SHOULDNT))
-          (SETQ EXP2 (BUILD.COPY.OF EXP))
-          [SETQ ANSWER `(AND (,LPRED ,EXP ,(fetch (MINTERVAL LBOUND) of INTERVAL))
-                             (,UPRED ,EXP2 ,(fetch (MINTERVAL UBOUND) of INTERVAL]
-          (RETURN ANSWER])
-
-(BUILD.ISTYPE
-  [LAMBDA (EXP TYPE)                                         (* kbr%: "25-Nov-85 17:28")
-    (PROG (MRECORD RECORDID ANSWER)
-          (SETQ MRECORD (BUILD.REFINE.TYPE TYPE))
-          (SETQ RECORDID (COND
-                            ((type? MRECORD MRECORD)
-                             (fetch (MRECORD RECORDID) of MRECORD))
-                            (T (printout T T "Bad istype " EXP " " TYPE T)
-                               TYPE)))
-          [SETQ ANSWER `(type? ,TYPE ,EXP]
-          (RETURN ANSWER])
-
-(BUILD.LAMBDA
-  [LAMBDA (PAIRLIST BODY)                                    (* kbr%: "25-Nov-85 17:28")
-    (PROG (ARGLIST ANSWER)
-          [SETQ ARGLIST (for ITEM in (fetch (PAIRLIST ITEMS) of PAIRLIST)
-                           collect (BUILD.LOCALVARID NIL (fetch (PAIRITEM ID) of ITEM]
-          [SETQ ANSWER `(LAMBDA ,ARGLIST
-                          ,@(BUILD.TAIL BODY]
-          (RETURN ANSWER])
-
-(BUILD.NEW
-  [LAMBDA (TYPEEXP INITIALIZATION)                           (* kbr%: "25-Nov-85 17:28")
-    (BUILD.COERCE INITIALIZATION TYPEEXP])
-
-(BUILD.OR
-  [LAMBDA (EXPS)                                             (* kbr%: "25-Nov-85 17:28")
-    (COND
-       ((NULL EXPS)
-        T)
-       ((NULL (CDR EXPS))
-        (CAR EXPS))
-       (T `(OR ,@EXPS])
-
-(BUILD.PROG
-  [LAMBDA (STATEMENTLIST)                                    (* kbr%: "25-Nov-85 17:28")
-    (PROG (VARS LAST ANSWER)
-          [SETQ ANSWER (APPEND (fetch (SCOPE INITLIST) of BUILD.CURRENT.SCOPE)
-                              (BUILD.TAIL (BUILD.PROGN STATEMENTLIST]
-          (SETQ VARS (APPEND (fetch (SCOPE VARLIST) of BUILD.CURRENT.SCOPE)
-                            (fetch (SCOPE RETURNVARS) of BUILD.CURRENT.SCOPE)))
-          [COND
-             [(OR VARS (fetch (SCOPE RETURNS) of BUILD.CURRENT.SCOPE)
-                  (for EXP in ANSWER thereis (LITATOM EXP))) (* Local vars, return, or go here.
-                                                             *)
-              [COND
-                 (ANSWER (SETQ LAST (CAR (LAST ANSWER]
-              [COND
-                 ([NOT (OR (NULL (fetch (SCOPE RETURNVARS) of BUILD.CURRENT.SCOPE))
-                           (AND (LISTP LAST)
-                                (FMEMB (CAR LAST)
-                                       '(GO RETURN]
-                  (SETQ ANSWER (APPEND ANSWER (LIST (BUILD.RETURN]
-              (SETQ ANSWER `(PROG ,VARS
-                                  ,@ANSWER]
-             (T (SETQ ANSWER (BUILD.PROGN ANSWER]
-          (RETURN ANSWER])
-
-(BUILD.PROGN
-  [LAMBDA (EXPS)                                             (* kbr%: "25-Nov-85 17:28")
-    (COND
-       ((NULL EXPS)
-        NIL)
-       ((NULL (CDR EXPS))
-        (CAR EXPS))
-       (T (CONS 'PROGN (for EXP in EXPS join (BUILD.TAIL EXP])
-
-(BUILD.REPLACE
-  [LAMBDA (RECORDNAME FIELDNAME DATUM VALUE)                 (* kbr%: "25-Nov-85 17:28")
-    (PROG (MRECORD ANSWER)
-          [SETQ MRECORD (COND
-                           (RECORDNAME (BUILD.REFINE.TYPE RECORDNAME))
-                           (T (BUILD.ULTIMATE.TYPE DATUM]
-          [SETQ ANSWER (COND
-                          [(type? MRECORD MRECORD)
-                           (SETQ RECORDNAME (fetch (MRECORD RECORDID) of MRECORD))
-                           `(replace (,RECORDNAME ,FIELDNAME) of ,DATUM with ,VALUE]
-                          (T (printout T T "Bad replace " RECORDNAME " " FIELDNAME " " DATUM " " 
-                                    VALUE T)
-                             (LIST FIELDNAME DATUM]
-          (RETURN ANSWER])
-
-(BUILD.RETURN
-  [LAMBDA (OPTARGS)                                          (* kbr%: "25-Nov-85 17:28")
-          
-          (* COPY so DEDIT won't get confused by shared structure.
-          *)
-
-    (PROG (SCOPE FN PROCID FIELDLIST EXPLIST ALIGNMENT ANSWER)
-                                                             (* Get scope of innermost PROC or DO.
-                                                             *)
-          (SETQ SCOPE (for SCOPE in (CONS BUILD.CURRENT.SCOPE BUILD.SCOPE.STACK)
-                         thereis (fetch (SCOPE ID) of SCOPE)))
-          (replace (SCOPE RETURNS) of SCOPE with T)
-          (SETQ FN (fetch (SCOPE ID) of SCOPE))
-          [SETQ ALIGNMENT (COND
-                             ((EQ FN 'DO)
-                              OPTARGS)
-                             (OPTARGS (SETQ PROCID (BUILD.PROCID BUILD.PREFIX FN))
-                                    [SETQ FIELDLIST
-                                     (OR (GETPROP PROCID 'MESA.RETURNLIST)
-                                         (PROGN (printout T T "No returnlist for " PROCID "." T)
-                                                'ANY]
-                                    (BUILD.ALIGN FIELDLIST OPTARGS))
-                             (T (fetch (SCOPE RETURNVARS) of SCOPE]
-          [SETQ ANSWER (COND
-                          ((NULL ALIGNMENT)
-                           (LIST 'RETURN))
-                          [(NULL (CDR ALIGNMENT))
-                           `(RETURN ,@ALIGNMENT]
-                          (T `(RETURN (LIST ,@ALIGNMENT]
-          (RETURN ANSWER])
-
-(BUILD.SELECTQ
-  [LAMBDA (CASEHEAD CLAUSES OTHERWISE)                       (* kbr%: "25-Nov-85 17:28")
-    (PROG (ID EXP OPTEXP TYPE FN CCLAUSES SCLAUSES ANSWER)
-          (SETQ ID (fetch (CASEHEAD ID) of CASEHEAD))
-          (SETQ EXP (fetch (CASEHEAD EXP) of CASEHEAD))
-          (SETQ OPTEXP (fetch (CASEHEAD OPTEXP) of CASEHEAD))
-          (SETQ EXP (OR OPTEXP ID EXP))
-          (COND
-             ((EQ EXP T)                                     (* Mesa SELECT TRUE FROM statement.
-                                                             *)
-              (SETQ ANSWER (BUILD.SELECTTRUEFROM CLAUSES OTHERWISE))
-              (RETURN ANSWER)))
-          (SETQ TYPE (BUILD.ULTIMATE.TYPE EXP))
-          (SETQ FN (BUILD.SELECTQ.FN TYPE))
-          [for CLAUSE in CLAUSES do (COND
-                                       ([for CASETEST in (CAR CLAUSE)
-                                           thereis (COND
-                                                      ((AND (LISTP CASETEST)
-                                                            (FMEMB (CAR CASETEST)
-                                                                   '(IN type?]
-                                        (push CCLAUSES CLAUSE))
-                                       (T (push SCLAUSES CLAUSE]
-          (SETQ CCLAUSES (DREVERSE CCLAUSES))
-          (SETQ SCLAUSES (DREVERSE SCLAUSES))
-          (SETQ CCLAUSES (for CCLAUSE in CCLAUSES collect (BUILD.SELECTQ.CCLAUSE EXP CCLAUSE TYPE)))
-          (SETQ SCLAUSES (for SCLAUSE in SCLAUSES collect (BUILD.SELECTQ.SCLAUSE SCLAUSE TYPE)))
-          (SETQ ANSWER (COND
-                          [SCLAUSES `(,FN ,EXP ,@SCLAUSES ,OTHERWISE]
-                          (T OTHERWISE)))
-          (SETQ ANSWER (COND
-                          [CCLAUSES (COND
-                                       [ANSWER `(COND
-                                                   ,@CCLAUSES
-                                                   (T ,@(BUILD.TAIL ANSWER]
-                                       (T `(COND
-                                              ,@CCLAUSES]
-                          (T ANSWER)))
-          (RETURN ANSWER])
-
-(BUILD.SELECTQ.FN
-  [LAMBDA (TYPE)                                             (* kbr%: "25-Nov-85 17:28")
-    (COND
-       ((EQ TYPE 'CHARACTER)
-        'SELCHARQ)
-       (T 'SELECTQ])
-
-(BUILD.SELECTQ.CCLAUSE
-  [LAMBDA (EXP CCLAUSE TYPE)                                 (* kbr%: "25-Nov-85 17:28")
-    (PROG (EXP2 KEYS TESTS ANSWER)
-          (SETQ EXP2 (BUILD.COPY.OF EXP))
-          (SETQ KEYS (CAR CCLAUSE))
-          [SETQ TESTS (CONS (BUILD.SELECTQ.TEST EXP (CAR KEYS))
-                            (for KEY in (CDR KEYS) collect (BUILD.SELECTQ.TEST EXP KEY]
-          [COND
-             ((NULL (CDR TESTS))
-              (SETQ TESTS (CAR TESTS)))
-             (T (SETQ TESTS (CONS 'OR TESTS]
-          (SETQ ANSWER (CONS TESTS (CDR CCLAUSE)))
-          (RETURN ANSWER])
-
-(BUILD.SELECTQ.TEST
-  [LAMBDA (EXP KEY)                                          (* kbr%: "25-Nov-85 17:28")
-    (COND
-       ((AND (LISTP KEY)
-             (EQ (CAR KEY)
-                 'IN))
-        (BUILD.IN EXP (CADR KEY)))
-       ((AND (LISTP KEY)
-             (EQ (CAR KEY)
-                 'type?))
-        KEY)
-       (T `(FMEMB ,EXP ',KEY])
-
-(BUILD.SELECTQ.SCLAUSE
-  [LAMBDA (SCLAUSE TYPE)                                     (* kbr%: "25-Nov-85 17:28")
-    (PROG (KEYS ANSWER)
-          (SETQ KEYS (CAR SCLAUSE))
-          (SETQ KEYS (for KEY in KEYS collect (BUILD.SELECTQ.KEY KEY TYPE)))
-          [COND
-             ((NULL (CDR KEYS))
-              (SETQ KEYS (CAR KEYS]
-          (SETQ ANSWER (CONS KEYS (CDR SCLAUSE)))
-          (RETURN ANSWER])
-
-(BUILD.SELECTQ.KEY
-  [LAMBDA (KEY TYPE)                                         (* kbr%: "25-Nov-85 17:28")
-    (COND
-       ((EQ TYPE 'CHARACTER)
-        (COND
-           [(LISTP KEY)
-            (COND
-               ((EQ (CAR KEY)
-                    'CHARCODE)
-                (CADR KEY))
-               ((EQ (CAR KEY)
-                    'IN)
-                (LIST 'IN (LIST (CAR (CADR KEY))
-                                (BUILD.SELECTQ.KEY (CADR (CADR KEY))
-                                       'CHARACTER)
-                                (BUILD.SELECTQ.KEY (CADDR (CADR KEY))
-                                       'CHARACTER]
-           (T KEY)))
-       (T KEY])
-
-(BUILD.SELECTTRUEFROM
-  [LAMBDA (CLAUSES OTHERWISE)                                (* kbr%: "25-Nov-85 17:28")
-    (PROG (ANSWER)
-          (SETQ CLAUSES (for CLAUSE in CLAUSES collect (BUILD.SELECTTRUEFROM.CLAUSE CLAUSE)))
-          (SETQ ANSWER (COND
-                          [CLAUSES (COND
-                                      [OTHERWISE `(COND
-                                                     ,@CLAUSES
-                                                     (T ,@(BUILD.TAIL OTHERWISE]
-                                      (T `(COND
-                                             ,@CLAUSES]
-                          (T OTHERWISE)))
-          (RETURN ANSWER])
-
-(BUILD.SELECTTRUEFROM.CLAUSE
-  [LAMBDA (CLAUSE)                                           (* kbr%: "25-Nov-85 17:28")
-    (CONS (BUILD.OR (CAR CLAUSE))
-          (CDR CLAUSE])
-
-(BUILD.SETQ
-  [LAMBDA (LHS RHS)                                          (* kbr%: "25-Nov-85 17:28")
-    (PROG (TYPE ANSWER)
-          (COND
-             ((type? ORDERLIST LHS)
-              (SETQ ANSWER (BUILD.SETQ.ORDERLIST LHS RHS))
-              (RETURN ANSWER)))
-          (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS))
-          (SETQ RHS (BUILD.COERCE RHS TYPE))
-          [SETQ ANSWER (COND
-                          ((NULL LHS)
-                           RHS)
-                          ((type? MARRAY TYPE)
-                           (BUILD.SETQ.ARRAY LHS RHS))
-                          [(LISTP LHS)
-                           (SELECTQ (CAR LHS)
-                               (ELT `(SETA ,(CADR LHS) ,(CADDR LHS) ,RHS))
-                               (fetch `(replace ,@(CDR LHS) with ,RHS))
-                               (NTHCHARCODE `(RPLCHARCODE ,(CADR LHS) ,(CADDR LHS) ,RHS))
-                               (PROGN (printout T "Bad setq " LHS " " RHS)
-                                      (COND
-                                         [(IEQP (LENGTH LHS)
-                                                2)
-                                          (COND
-                                             [(FIXP (CADR LHS))
-                                                             (* Guess array access.
-                                                             *)
-                                              `(SETA ,(CAR LHS) ,(CADR LHS) ,RHS]
-                                             (T              (* Guess record access.
-                                                             *)
-                                                (BUILD.REPLACE NIL (CAR LHS)
-                                                       (CADR LHS)
-                                                       RHS]
-                                         (T                  (* Guess it could be anything.
-                                                             *)
-                                            `(SETQ ,LHS ,RHS]
-                          (T `(SETQ ,LHS ,RHS]
-          (RETURN ANSWER])
-
-(BUILD.SETQ.ARRAY
-  [LAMBDA (LHS RHS)                                          (* kbr%: "25-Nov-85 17:28")
-                                                             (* SETQ array LHS. I.e., FILLARRAY.
-                                                             *)
-    (PROG (EXPS ANSWER)
-          (COND
-             ((NOT (type? ORDERLIST RHS))
-              (printout T T "Bad setq array " LHS " " RHS T)
-              [SETQ ANSWER `(SETQ ,LHS ,RHS]
-              (RETURN ANSWER)))
-          (SETQ EXPS (for ORDERITEM in (fetch (ORDERLIST ITEMS) of RHS) as I from 0
-                        collect (BUILD.SETQ `(ELT ,LHS ,I) ORDERITEM)))
-          (SETQ ANSWER (BUILD.PROGN EXPS))
-          (RETURN ANSWER])
-
-(BUILD.SETQ.ORDERLIST
-  [LAMBDA (ORDERLIST RHS)                                    (* kbr%: "25-Nov-85 17:28")
-                                                             (* SETQ orderlist ORDERLIST.
-                                                             *)
-    (PROG (ORDERITEMS TEMP TEMPPOS EXPS ANSWER)              (* Get ORDERITEMS *)
-          (SETQ ORDERITEMS (fetch (ORDERLIST ITEMS) of ORDERLIST))
-          (COND
-             ((NULL ORDERITEMS)
-              (RETURN RHS))
-             ((NULL (CDR ORDERITEMS))
-              [SETQ ANSWER (BUILD.SETQ (CAR ORDERITEMS)
-                                  `(CAR ,RHS]
-              (RETURN ANSWER)))                              (* Get TEMPorary variable.
-                                                             *)
-          (SETQ TEMP (CAR RHS))
-          (SETQ TEMPPOS (STRPOS "." TEMP))
-          [COND
-             (TEMPPOS (SETQ TEMP (SUBATOM TEMP (ADD1 TEMPPOS)
-                                        -1]                  (* Get EXPS. *)
-          [SETQ EXPS (COND
-                        [(ILEQ (LENGTH ORDERITEMS)
-                               3)
-                         (for ID in ORDERITEMS when ID as ACCESS in '(CAR CADR CADDR)
-                            collect (BUILD.SETQ ID `(,ACCESS ,TEMP]
-                        (T (for ID in ORDERITEMS when ID
-                              collect (BUILD.SETQ ID `(POP ,TEMP]
-          [push EXPS `(SETQ ,TEMP ,RHS]                      (* Build PROGN ANSWER.
-                                                             *)
-          (SETQ ANSWER (BUILD.PROGN EXPS))
-          (RETURN ANSWER])
-
-(BUILD.SUB1
-  [LAMBDA (EXP)                                              (* kbr%: "25-Nov-85 17:28")
-    (COND
-       ((FIXP EXP)
-        (SUB1 EXP))
-       (T `(SUB1 ,EXP])
-
-(BUILD.TAIL
-  [LAMBDA (EXP)                                              (* kbr%: "25-Nov-85 17:28")
-    (COND
-       ((NULL EXP)
-        NIL)
-       ((AND (LISTP EXP)
-             (EQ (CAR EXP)
-                 'PROGN))
-        (CDR EXP))
-       (T (LIST EXP])
-)
-(BUILD.INIT)
-(PRETTYCOMPRINT MESATOLISPCOMS)
-
-(RPAQQ MESATOLISPCOMS 
-       [  
-          (* ;; "MESATOLISP -- By Kelly Roach.  Lyricized by L. Masinter")
-
-        (COMS 
-
-(* ;;; "SCAN: reading mesa/cedar files")
-
-              [INITVARS (SCAN.STRING (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT '#\A :ELEMENT-TYPE
-                                            'CL:CHARACTER :ADJUSTABLE T :FILL-POINTER 0))
-                     (SCAN.CHAR NIL)
-                     (SCAN.QDOT NIL)
-                     (SCAN.BOTH.RESERVED '(! %# %( %) * + %, - %. |..| / %: ; < <= = => > >= @ ABS 
-                                             ALL AND ANY APPLY ARRAY BASE BEGIN BROADCAST CODE 
-                                             COMPUTED CONTINUE DECREASING DEFINITIONS DEPENDENT 
-                                             DESCRIPTOR DIRECTORY DO ELSE ENABLE END ENDCASE ENDLOOP 
-                                             ENTRY ERROR EXIT EXITS EXPORTS FINISHED FIRST FOR FORK 
-                                             FRAME FREE FROM GO GOTO IF IMPORTS IN INLINE INTERNAL 
-                                             ISTYPE JOIN LAST LENGTH LOCKS LONG LOOP LOOPHOLE MACHINE 
-                                             MAX MIN MOD MONITOR MONITORED NARROW NEW NILL NOT NOTIFY 
-                                             NULL OF OPEN OR ORD ORDERED OVERLAID PACKED POINTER PORT 
-                                             PRED PRIVATE PROC PROCEDURE PROCESS PROGRAM PUBLIC 
-                                             READONLY RECORD REJECT RELATIVE REPEAT RESTART RESUME 
-                                             RETRY RETURN RETURNS SELECT SEQUENCE SHARES SIGNAL SIZE 
-                                             START STATE STOP SUCC THEN THROUGH TO TRANSFER TRASH 
-                                             TYPE UNCOUNTED UNTIL USING VAL VAR WAIT WHILE WITH ZONE 
-                                             %[ %] ^ _ { %| } ~))
-                     (SCAN.CEDAR.RESERVED '(CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED 
-                                                  UNCHECKED UNSAFE))
-                     (SCAN.MESA.RESERVED '(RESIDENT]
-              (FNS SCAN.INIT SCAN.START SCAN.TEST SCAN.TESTFILE SCAN.OPENSTREAM SCAN.TOKEN 
-                   SCAN.NUMBER SCAN.ACCEPT SCAN.APPENDDECIMAL SCAN.APPENDOCTAL SCAN.APPENDHEX 
-                   SCAN.APPENDTOSCALE SCAN.VALIDFRACTION SCAN.DECIMAL SCAN.OCTAL SCAN.OCTALCHAR 
-                   SCAN.HEX SCAN.FLOATING SCAN.ESCAPE)
-              (P (SCAN.INIT)))
-        (COMS                                                (* ; "PARSE *")
-              [INITVARS (PARSE.FILELST NIL)
-                     (PARSE.STREAM NIL)
-                     (PARSE.FILECOMS NIL)
-                     (PARSE.LANGUAGE NIL)
-                     (PARSE.DIRLST NIL)
-                     (PARSE.CLASS NIL)
-                     (PARSE.ATOM NIL)
-                     (PARSE.CLASS2 NIL)
-                     (PARSE.ATOM2 NIL)
-                     (PARSE.CASEHEAD.FIRST '(WITH SELECT))
-                     (PARSE.DEFHEAD.FIRST '(DEFINITIONS))
-                     (PARSE.DEPENDENT.FIRST '(MACHINE))
-                     (PARSE.DOTEST.FIRST '(UNTIL WHILE))
-                     (PARSE.FORCLAUSE.FIRST '(FOR THROUGH))
-                     (PARSE.HEAP.FIRST '(UNCOUNTED))
-                     (PARSE.INTERVAL.FIRST '(%( %[))
-                     (PARSE.OPTRELATION.FIRST '(%# < <= = > >= IN NOT ~))
-                     (PARSE.ORDERED.FIRST '(ORDERED))
-                     (PARSE.ORDERLIST.FOLLOW '(! ; END %] }))
-                     (PARSE.PACKED.FIRST '(PACKED))
-                     (PARSE.PREFIXOP.FIRST '(ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC))
-                     (PARSE.PROGHEAD.FIRST '(MONITOR PROGRAM RESIDENT))
-                     (PARSE.QUALIFIER.FIRST '(%. %[ ^))
-                     (PARSE.RANGE.FOLLOW '(! %) %, |..| %: ; => AND DO ELSE END ENDCASE ENDLOOP EXITS 
-                                             FINISHED FROM NULL OR REPEAT SELECT THEN TRASH UNTIL 
-                                             WHILE %] }))
-                     (PARSE.TRANSFER.FIRST '(BROADCAST ERROR JOIN NOTIFY RESTART RETURN SIGNAL START 
-                                                   TRANSFER))
-                     (PARSE.TRANSFERMODE.FIRST '(ERROR PORT PROCESS PROGRAM SIGNAL))
-                     (PARSE.TRANSFEROP.FIRST '(ERROR FORK JOIN NEW SIGNAL START))
-                     (PARSE.TYPECONS.FIRST '(%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG MACHINE 
-                                                MONITORED ORDERED PACKED POINTER PORT PROC PORCEDURE 
-                                                PROCESS PROGRAM RECORD SIGNAL UNCOUNTED VAR %[ {))
-                     (PARSE.TYPEOP.FIRST '(FIRST LAST NILL))
-                     (PARSE.VARIANTPART.FIRST '(PACKED SELECT SEQUENCE))
-                     (PARSE.CATCHLIST.FOLLOW '(END %] }))
-                     (PARSE.CONTROLID.FOLLOW '(DECREASING IN _))
-                     (PARSE.DECLIST.FOLLOW '(; END }))
-                     (PARSE.DEFAULTOPT.FOLLOW '(%, ; END %] }))
-                     (PARSE.EXITLIST.FOLLOW '(END ENDLOOP FINISHED }))
-                     (PARSE.MODULELIST.FOLLOW '(IEQP EXPORTS SHARES))
-                     (PARSE.OPTARGS.FOLLOW '(; ELSE END ENDCASE ENDLOOP EXITS FINISHED REPEAT %] }))
-                     (PARSE.OPTEXP.FOLLOW '(! %, ; END FROM %] }))
-                     (PARSE.SCOPE.FOLLOW '(END EXITS }))
-                     (PARSE.STATEMENTLIST.FOLLOW '(END ENDLOOP EXITS REPEAT }))
-                     (PARSE.TYPEEXP.FOLLOW '(! %, ; = => DECREASING END EXPORTS FROM IMPORTS IN OF 
-                                               SHARES %] _ }))
-                     (PARSE.PREDEFINED.TYPES '(ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER CONDITION 
-                                                    INT INTEGER MDSZone MONITORLOCK NAT REAL STRING 
-                                                    StringBody UNSPECIFIED WORD))
-                     (PARSE.RELOPS (LIST '= '%# '< '<= '> '>=))
-                     (PARSE.ADDOPS (LIST '+ '-))
-                     (PARSE.MULTOPS (LIST '* '/ 'MOD))
-                     (PARSE.TRANSFEROPS '(SIGNAL ERROR START JOIN NEW FORK))
-                     (PARSE.PREFIXOPS '(LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH))
-                     (PARSE.TYPEOPS '(FIRST LAST NILL))
-                     (PARSE.NOTS '(~ NOT]
-              (RECORDS PARSERSTATE MINTERVAL MRANGE MRELATIVE MPAINTED MENUMERATED MRECORD MVAR 
-                     MARRAY MDESCRIPTOR MFRAME MREF MLIST PAIRITEM DEFAULT TYPELIST TYPEITEM MPOINTER 
-                     CASEHEAD BINDITEM KEYITEM FIELDLIST PAIRLIST ORDERLIST KEYLIST EXPLIST)
-              (FNS PARSE.MESA PARSE.CEDAR PARSE.FILE PARSE.GET.STATE PARSE.SET.STATE PARSE.BIN 
-                   PARSE.VARID PARSE.SMURF PARSE.THISIS.MESA PARSE.THISIS.CEDAR PARSE.MODULE 
-                   PARSE.INCLUDEITEM PARSE.INCLUDECHECK PARSE.SEADIRT PARSE.PROGHEAD PARSE.RESIDENT 
-                   PARSE.SAFE PARSE.DEFHEAD PARSE.TILDE PARSE.DEFINITIONS PARSE.DEFBODY PARSE.LOCKS 
-                   PARSE.LAMBDA PARSE.MODULEITEM PARSE.DECLARATION PARSE.PUBLIC PARSE.ENTRY 
-                   PARSE.IDLIST PARSE.IDENTLIST PARSE.POSITION PARSE.OPTBITS PARSE.INTERVAL 
-                   PARSE.TYPEEXP.HERE PARSE.TYPEEXP PARSE.RANGE PARSE.TYPEAPPL PARSE.TYPEAPPL.CONT 
-                   PARSE.TYPEID PARSE.TYPEID.CONT PARSE.TYPECONS PARSE.TYPECONS1 PARSE.TYPECONS.CONT 
-                   PARSE.TYPECONS.RANGE PARSE.TYPECONS.RELATIVE PARSE.TYPECONS.PAINTED 
-                   PARSE.TYPECONS2 PARSE.TYPECONS.INTERVAL PARSE.TYPECONS.DEPENDENT 
-                   PARSE.TYPECONS.ENUMERATED PARSE.TYPECONS.RECORD PARSE.TYPECONS.ORDERED 
-                   PARSE.TYPECONS.VAR PARSE.TYPECONS.PACKED PARSE.TYPECONS.DESCRIPTOR 
-                   PARSE.TYPECONS.SAFE PARSE.TYPECONS.HEAP PARSE.TYPECONS.LONG PARSE.TYPECONS.FRAME 
-                   PARSE.TYPECONS.REF PARSE.TYPECONS.LIST PARSE.IDENT PARSE.ELEMENT PARSE.MONITORED 
-                   PARSE.DEPENDENT PARSE.RECLIST PARSE.VARIANTPAIR PARSE.PAIRITEM PARSE.DEFAULTOPT 
-                   PARSE.VARIANTPART PARSE.VCASEHEAD PARSE.TAGTYPE PARSE.VARIANTITEM PARSE.TYPELIST 
-                   PARSE.TYPEITEM PARSE.POINTERTYPE PARSE.TRANSFERMODE PARSE.INITIALIZATION 
-                   PARSE.INITVALUE PARSE.CHECKED PARSE.CODELIST PARSE.STATEMENT PARSE.STATEMENT1 
-                   PARSE.STATEMENT2 PARSE.STATEMENT.CASEHEAD PARSE.STATEMENT.FORCLAUSE 
-                   PARSE.STATEMENT.RETURN PARSE.STATEMENT.TRANSFER PARSE.STATEMENT.LBRACKET 
-                   PARSE.STATEMENT.IF PARSE.BLOCK PARSE.SCOPE PARSE.BINDITEM PARSE.EXITS 
-                   PARSE.CASESTMTITEM PARSE.CASEEXPITEM PARSE.EXITITEM PARSE.CASETEST PARSE.CONTROLID 
-                   PARSE.FORCLAUSE PARSE.DIRECTION PARSE.DOTEST PARSE.DOEXIT PARSE.ENABLES 
-                   PARSE.CATCHLIST PARSE.CATCHCASE PARSE.OPTARGS PARSE.TRANSFER PARSE.KEYITEM 
-                   PARSE.OPTEXP PARSE.EXP PARSE.EXP1 PARSE.EXP2 PARSE.EXP.TRANSFEROP PARSE.EXP.IF 
-                   PARSE.EXP.CASEHEAD PARSE.EXP.LHS PARSE.EXP.LBRACKET PARSE.EXP.ERROR 
-                   PARSE.EXP.DISJUNCT PARSE.DISJUNCT PARSE.CONJUNCT PARSE.NEGATION PARSE.RELATION 
-                   PARSE.SUM PARSE.PRODUCT PARSE.OPTRELATION PARSE.RELATIONTAIL PARSE.RELOP 
-                   PARSE.ADDOP PARSE.MULTOP PARSE.FACTOR PARSE.PRIMARY PARSE.ATOM PARSE.PRIMARY.NIL 
-                   PARSE.PRIMARY.LBRACKET PARSE.PRIMARY.PREFIXOP PARSE.PRIMARY.VAL PARSE.PRIMARY.ALL 
-                   PARSE.PRIMARY.NEW PARSE.PRIMARY.TYPEOP PARSE.PRIMARY.SIZE PARSE.PRIMARY.ISTYPE 
-                   PARSE.PRIMARY.AT PARSE.PRIMARY.DESCRIPTOR PARSE.PRIMARY.CONS PARSE.PRIMARY.LIST 
-                   PARSE.PRIMARY.LHS PARSE.PRIMARY.LHS.NEW PARSE.PRIMARY.LHS.CONS 
-                   PARSE.PRIMARY.LHS.LIST PARSE.QUALIFIER PARSE.LHS PARSE.QUALIFIER.HERE 
-                   PARSE.OPTCATCH PARSE.TRANSFEROP PARSE.PREFIXOP PARSE.TYPEOP PARSE.DESCLIST 
-                   PARSE.DIRECTORY PARSE.IMPORTS PARSE.POINTERPREFIX PARSE.EXPORTS PARSE.FIELDLIST 
-                   PARSE.USING PARSE.CATCHHEAD PARSE.DECLIST PARSE.PAIRLIST PARSE.VARIANTLIST 
-                   PARSE.ORDERLIST PARSE.LHSLIST PARSE.INCLUDELIST PARSE.MODULELIST PARSE.ELEMENTLIST 
-                   PARSE.BINDLIST PARSE.STATEMENTLIST PARSE.CASESTMTLIST PARSE.CASELABEL 
-                   PARSE.EXITLIST PARSE.KEYLIST PARSE.CASEEXPLIST PARSE.EXPLIST PARSE.OPEN 
-                   PARSE.CLASS PARSE.CASEHEAD PARSE.READONLY PARSE.ORDERED PARSE.BASE PARSE.PACKED 
-                   PARSE.HEAP PARSE.INLINE PARSE.ARGUMENTS PARSE.INTERFACE PARSE.SHARES PARSE.DEFAULT 
-                   PARSE.OPTSIZE PARSE.BOUNDS PARSE.LENGTH PARSE.INDEXTYPE PARSE.ELSEPART 
-                   PARSE.OTHERPART PARSE.FREE PARSE.CATCHANY PARSE.NOT PARSE.NEW PARSE.OPTTYPE 
-                   PARSE.ARGLIST PARSE.RETURNLIST))
-        (COMS 
-          
-          (* ;; "BUILD ")
-
-              [INITVARS (BUILD.NEXT.SCOPE NIL)
-                     (BUILD.CURRENT.SCOPE NIL)
-                     (BUILD.SCOPE.STACK NIL)
-                     (BUILD.PREFIX NIL)
-                     (BUILD.FILECOMS NIL)
-                     (BUILD.BOOLEAN.FNS '(AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP ZEROP 
-                                              MINUSP EVENP ODDP FGREATERP FLESSP FEQP GREATERP LESSP 
-                                              GEQ LEQ))
-                     (BUILD.CARDINAL.FNS '(ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN IMINUS IMOD 
-                                                IPLUS IQUOTIENT IREMAINDER ITIMES LOGAND LOGNOT LOGOR 
-                                                LOGXOR NTHCHARCODE SUB1))
-                     (BUILD.MIXED.FNS '(ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT REMAINDER 
-                                            TIMES))
-                     (BUILD.REAL.FNS '(ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE FLOAT 
-                                             FMAX FMIN FMINUS FMOD FPLUS FQUOTIENT FREMAINDER FTIMES 
-                                             LOG SIN SQRT TAN))
-                     (BUILD.QUALIFY.WORDS '(FREE NEW SIZE))
-                     [BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS '= 'IEQP)
-                                                         (CONS '%# 'IEQP)
-                                                         (CONS '< 'ILESSP)
-                                                         (CONS '<= 'ILEQ)
-                                                         (CONS '> 'IGREATERP)
-                                                         (CONS '>= 'IGEQ)
-                                                         (CONS '+ 'IPLUS)
-                                                         (CONS '- 'IDIFFERENCE)
-                                                         (CONS '* 'ITIMES)
-                                                         (CONS '/ 'IQUOTIENT)
-                                                         (CONS '0- 'IMINUS)
-                                                         (CONS 'MAX 'IMAX)
-                                                         (CONS 'MIN 'IMIN)
-                                                         (CONS 'MOD 'IMOD]
-                     [BUILD.MIXED.ARITHOP.ALIST (LIST (CONS '= 'EQP)
-                                                      (CONS '%# 'EQP)
-                                                      (CONS '< 'LESSP)
-                                                      (CONS '<= 'GREATERP)
-                                                      (CONS '> 'GREATERP)
-                                                      (CONS '>= 'LESSP)
-                                                      (CONS '+ 'PLUS)
-                                                      (CONS '- 'DIFFERENCE)
-                                                      (CONS '* 'TIMES)
-                                                      (CONS '/ 'QUOTIENT)
-                                                      (CONS '0- 'MINUS)
-                                                      (CONS 'MAX 'MAX)
-                                                      (CONS 'MIN 'MIN)
-                                                      (CONS 'MOD 'IMOD]
-                     [BUILD.REAL.ARITHOP.ALIST (LIST (CONS '= 'FEQP)
-                                                     (CONS '%# 'FEQP)
-                                                     (CONS '< 'FLESSP)
-                                                     (CONS '<= 'FGREATERP)
-                                                     (CONS '> 'FGREATERP)
-                                                     (CONS '>= 'FLESSP)
-                                                     (CONS '+ 'FPLUS)
-                                                     (CONS '- 'FDIFFERENCE)
-                                                     (CONS '* 'FTIMES)
-                                                     (CONS '/ 'FQUOTIENT)
-                                                     (CONS '0- 'FMINUS)
-                                                     (CONS 'MAX 'FMAX)
-                                                     (CONS 'MIN 'FMIN)
-                                                     (CONS 'MOD 'IMOD]
-                     (BUILD.CARDINAL.TYPES '(CARDINAL CHAR CHARACTER INT INTEGER NAT WORD]
-              (RECORDS SCOPE)
-              (FNS BUILD.INIT BUILD.PUSH.SCOPE BUILD.POP.SCOPE BUILD.GC.SCOPE BUILD.STORE.EXPORTS 
-                   BUILD.STORE.IDENTLIST BUILD.STORE.INTERFACES BUILD.STORE.INTERFACE 
-                   BUILD.STORE.OPEN BUILD.STORE.USING BUILD.INITIALIZATION BUILD.INITIALIZE.VARS 
-                   BUILD.INITIALIZE.VAR BUILD.INITIALIZE.FN BUILD.INITIALIZE.RECORD BUILD.RECORD 
-                   BUILD.TYPE BUILD.STORE.ARGLIST BUILD.STORE.RETURNLIST BUILD.STORE.PAIRLIST 
-                   BUILD.STORE.PAIRITEM BUILD.STORE.VARLIST BUILD.ID BUILD.FIELDID BUILD.PROCID 
-                   BUILD.RECORDID BUILD.TYPEID BUILD.VARID BUILD.LOCALVARID BUILD.GLOBALVARID 
-                   BUILD.ULTIMATE.TYPE BUILD.REFINE.TYPE BUILD.IMMEDIATE.TYPE BUILD.LOOKUP.TYPE 
-                   BUILD.LOOKUP BUILD.TYPEATOM BUILD.QUALIFY BUILD.QUALIFY.PREFIXOP 
-                   BUILD.QUALIFY.TYPEOP BUILD.QUALIFY.EXPLIST BUILD.QUALIFY.ID BUILD.ARITH.EXP1 
-                   BUILD.ARITH.EXP2 BUILD.ARITH.EXP* BUILD.ARITH.ADD1SUB1 BUILD.COERCE.ARITHOP 
-                   BUILD.STRONGEST.TYPE.AMONG BUILD.STRONGEST.TYPE BUILD.COERCE BUILD.COERCE.MARRAY 
-                   BUILD.COERCE.MLIST BUILD.COERCE.EXPLIST BUILD.ALIGN BUILD.ALIGN.VALUE 
-                   BUILD.ADD.TO.FILECOMS BUILD.ADD1 BUILD.CALL BUILD.CHARCODE BUILD.COND 
-                   BUILD.COPY.OF BUILD.FETCH BUILD.FORCLAUSE.BY BUILD.FORCLAUSE.IN 
-                   BUILD.FORCLAUSE.THROUGH BUILD.IN BUILD.ISTYPE BUILD.LAMBDA BUILD.NEW BUILD.OR 
-                   BUILD.PROG BUILD.PROGN BUILD.REPLACE BUILD.RETURN BUILD.SELECTQ BUILD.SELECTQ.FN 
-                   BUILD.SELECTQ.CCLAUSE BUILD.SELECTQ.TEST BUILD.SELECTQ.SCLAUSE BUILD.SELECTQ.KEY 
-                   BUILD.SELECTTRUEFROM BUILD.SELECTTRUEFROM.CLAUSE BUILD.SETQ BUILD.SETQ.ARRAY 
-                   BUILD.SETQ.ORDERLIST BUILD.SUB1 BUILD.TAIL)
-              (P (BUILD.INIT)))
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA PARSE.BIN 
-                                                                                   PARSE.FILE 
-                                                                                   PARSE.CEDAR])
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA )
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA PARSE.BIN PARSE.FILE PARSE.CEDAR)
-)
-(PUTPROPS MESATOLISP COPYRIGHT ("Xerox Corporation" 1985 1987))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (19182 54761 (SCAN.INIT 19192 . 19601) (SCAN.START 19603 . 19785) (SCAN.TEST 19787 . 
-20251) (SCAN.TESTFILE 20253 . 20746) (SCAN.OPENSTREAM 20748 . 21252) (SCAN.TOKEN 21254 . 32584) (
-SCAN.NUMBER 32586 . 36881) (SCAN.ACCEPT 36883 . 37101) (SCAN.APPENDDECIMAL 37103 . 37792) (
-SCAN.APPENDOCTAL 37794 . 38356) (SCAN.APPENDHEX 38358 . 39122) (SCAN.APPENDTOSCALE 39124 . 39808) (
-SCAN.VALIDFRACTION 39810 . 40403) (SCAN.DECIMAL 40405 . 42476) (SCAN.OCTAL 42478 . 44543) (
-SCAN.OCTALCHAR 44545 . 45852) (SCAN.HEX 45854 . 48496) (SCAN.FLOATING 48498 . 52403) (SCAN.ESCAPE 
-52405 . 54759)) (59379 203256 (PARSE.MESA 59389 . 59541) (PARSE.CEDAR 59543 . 59715) (PARSE.FILE 59717
- . 60284) (PARSE.GET.STATE 60286 . 61074) (PARSE.SET.STATE 61076 . 62387) (PARSE.BIN 62389 . 63223) (
-PARSE.VARID 63225 . 63384) (PARSE.SMURF 63386 . 64515) (PARSE.THISIS.MESA 64517 . 64797) (
-PARSE.THISIS.CEDAR 64799 . 65082) (PARSE.MODULE 65084 . 66127) (PARSE.INCLUDEITEM 66129 . 67429) (
-PARSE.INCLUDECHECK 67431 . 68401) (PARSE.SEADIRT 68403 . 68792) (PARSE.PROGHEAD 68794 . 69523) (
-PARSE.RESIDENT 69525 . 69925) (PARSE.SAFE 69927 . 70400) (PARSE.DEFHEAD 70402 . 70889) (PARSE.TILDE 
-70891 . 71346) (PARSE.DEFINITIONS 71348 . 71585) (PARSE.DEFBODY 71587 . 72486) (PARSE.LOCKS 72488 . 
-72925) (PARSE.LAMBDA 72927 . 73472) (PARSE.MODULEITEM 73474 . 74008) (PARSE.DECLARATION 74010 . 76112)
- (PARSE.PUBLIC 76114 . 76485) (PARSE.ENTRY 76487 . 76854) (PARSE.IDLIST 76856 . 77416) (
-PARSE.IDENTLIST 77418 . 79049) (PARSE.POSITION 79051 . 79489) (PARSE.OPTBITS 79491 . 79866) (
-PARSE.INTERVAL 79868 . 81120) (PARSE.TYPEEXP.HERE 81122 . 81252) (PARSE.TYPEEXP 81254 . 82083) (
-PARSE.RANGE 82085 . 83410) (PARSE.TYPEAPPL 83412 . 83919) (PARSE.TYPEAPPL.CONT 83921 . 84674) (
-PARSE.TYPEID 84676 . 84838) (PARSE.TYPEID.CONT 84840 . 85782) (PARSE.TYPECONS 85784 . 86003) (
-PARSE.TYPECONS1 86005 . 87479) (PARSE.TYPECONS.CONT 87481 . 89721) (PARSE.TYPECONS.RANGE 89723 . 90085
-) (PARSE.TYPECONS.RELATIVE 90087 . 90476) (PARSE.TYPECONS.PAINTED 90478 . 90900) (PARSE.TYPECONS2 
-90902 . 93362) (PARSE.TYPECONS.INTERVAL 93364 . 93760) (PARSE.TYPECONS.DEPENDENT 93762 . 94424) (
-PARSE.TYPECONS.ENUMERATED 94426 . 94800) (PARSE.TYPECONS.RECORD 94802 . 95191) (PARSE.TYPECONS.ORDERED
- 95193 . 95622) (PARSE.TYPECONS.VAR 95624 . 96022) (PARSE.TYPECONS.PACKED 96024 . 96691) (
-PARSE.TYPECONS.DESCRIPTOR 96693 . 97260) (PARSE.TYPECONS.SAFE 97262 . 97706) (PARSE.TYPECONS.HEAP 
-97708 . 98006) (PARSE.TYPECONS.LONG 98008 . 98327) (PARSE.TYPECONS.FRAME 98329 . 98807) (
-PARSE.TYPECONS.REF 98809 . 99718) (PARSE.TYPECONS.LIST 99720 . 100302) (PARSE.IDENT 100304 . 100807) (
-PARSE.ELEMENT 100809 . 101464) (PARSE.MONITORED 101466 . 101823) (PARSE.DEPENDENT 101825 . 102251) (
-PARSE.RECLIST 102253 . 104422) (PARSE.VARIANTPAIR 104424 . 105219) (PARSE.PAIRITEM 105221 . 106764) (
-PARSE.DEFAULTOPT 106766 . 107902) (PARSE.VARIANTPART 107904 . 109341) (PARSE.VCASEHEAD 109343 . 110179
-) (PARSE.TAGTYPE 110181 . 110490) (PARSE.VARIANTITEM 110492 . 110918) (PARSE.TYPELIST 110920 . 112135)
- (PARSE.TYPEITEM 112137 . 112690) (PARSE.POINTERTYPE 112692 . 113443) (PARSE.TRANSFERMODE 113445 . 
-114181) (PARSE.INITIALIZATION 114183 . 115006) (PARSE.INITVALUE 115008 . 116738) (PARSE.CHECKED 116740
- . 117329) (PARSE.CODELIST 117331 . 117727) (PARSE.STATEMENT 117729 . 117959) (PARSE.STATEMENT1 117961
- . 119184) (PARSE.STATEMENT2 119186 . 122631) (PARSE.STATEMENT.CASEHEAD 122633 . 123653) (
-PARSE.STATEMENT.FORCLAUSE 123655 . 124768) (PARSE.STATEMENT.RETURN 124770 . 125149) (
-PARSE.STATEMENT.TRANSFER 125151 . 125525) (PARSE.STATEMENT.LBRACKET 125527 . 126007) (
-PARSE.STATEMENT.IF 126009 . 126595) (PARSE.BLOCK 126597 . 127191) (PARSE.SCOPE 127193 . 127945) (
-PARSE.BINDITEM 127947 . 128924) (PARSE.EXITS 128926 . 129301) (PARSE.CASESTMTITEM 129303 . 129821) (
-PARSE.CASEEXPITEM 129823 . 130249) (PARSE.EXITITEM 130251 . 130699) (PARSE.CASETEST 130701 . 131268) (
-PARSE.CONTROLID 131270 . 131909) (PARSE.FORCLAUSE 131911 . 133290) (PARSE.DIRECTION 133292 . 133651) (
-PARSE.DOTEST 133653 . 134147) (PARSE.DOEXIT 134149 . 135169) (PARSE.ENABLES 135171 . 136397) (
-PARSE.CATCHLIST 136399 . 137433) (PARSE.CATCHCASE 137435 . 137867) (PARSE.OPTARGS 137869 . 138471) (
-PARSE.TRANSFER 138473 . 139189) (PARSE.KEYITEM 139191 . 139969) (PARSE.OPTEXP 139971 . 140612) (
-PARSE.EXP 140614 . 140818) (PARSE.EXP1 140820 . 141490) (PARSE.EXP2 141492 . 143831) (
-PARSE.EXP.TRANSFEROP 143833 . 144203) (PARSE.EXP.IF 144205 . 144712) (PARSE.EXP.CASEHEAD 144714 . 
-145311) (PARSE.EXP.LHS 145313 . 145686) (PARSE.EXP.LBRACKET 145688 . 146148) (PARSE.EXP.ERROR 146150
- . 146394) (PARSE.EXP.DISJUNCT 146396 . 146628) (PARSE.DISJUNCT 146630 . 147337) (PARSE.CONJUNCT 
-147339 . 148050) (PARSE.NEGATION 148052 . 148582) (PARSE.RELATION 148584 . 149671) (PARSE.SUM 149673
- . 151062) (PARSE.PRODUCT 151064 . 152814) (PARSE.OPTRELATION 152816 . 153620) (PARSE.RELATIONTAIL 
-153622 . 154261) (PARSE.RELOP 154263 . 154661) (PARSE.ADDOP 154663 . 154888) (PARSE.MULTOP 154890 . 
-155196) (PARSE.FACTOR 155198 . 155767) (PARSE.PRIMARY 155769 . 158651) (PARSE.ATOM 158653 . 158899) (
-PARSE.PRIMARY.NIL 158901 . 159141) (PARSE.PRIMARY.LBRACKET 159143 . 159493) (PARSE.PRIMARY.PREFIXOP 
-159495 . 160061) (PARSE.PRIMARY.VAL 160063 . 160533) (PARSE.PRIMARY.ALL 160535 . 161005) (
-PARSE.PRIMARY.NEW 161007 . 161626) (PARSE.PRIMARY.TYPEOP 161628 . 162073) (PARSE.PRIMARY.SIZE 162075
- . 162835) (PARSE.PRIMARY.ISTYPE 162837 . 163453) (PARSE.PRIMARY.AT 163455 . 163781) (
-PARSE.PRIMARY.DESCRIPTOR 163783 . 164306) (PARSE.PRIMARY.CONS 164308 . 164919) (PARSE.PRIMARY.LIST 
-164921 . 165492) (PARSE.PRIMARY.LHS 165494 . 166806) (PARSE.PRIMARY.LHS.NEW 166808 . 167439) (
-PARSE.PRIMARY.LHS.CONS 167441 . 167987) (PARSE.PRIMARY.LHS.LIST 167989 . 168499) (PARSE.QUALIFIER 
-168501 . 170328) (PARSE.LHS 170330 . 172571) (PARSE.QUALIFIER.HERE 172573 . 172955) (PARSE.OPTCATCH 
-172957 . 173398) (PARSE.TRANSFEROP 173400 . 173916) (PARSE.PREFIXOP 173918 . 174257) (PARSE.TYPEOP 
-174259 . 174743) (PARSE.DESCLIST 174745 . 175423) (PARSE.DIRECTORY 175425 . 176044) (PARSE.IMPORTS 
-176046 . 176542) (PARSE.POINTERPREFIX 176544 . 177053) (PARSE.EXPORTS 177055 . 177576) (
-PARSE.FIELDLIST 177578 . 178417) (PARSE.USING 178419 . 179118) (PARSE.CATCHHEAD 179120 . 179975) (
-PARSE.DECLIST 179977 . 180828) (PARSE.PAIRLIST 180830 . 181860) (PARSE.VARIANTLIST 181862 . 182556) (
-PARSE.ORDERLIST 182558 . 183281) (PARSE.LHSLIST 183283 . 183820) (PARSE.INCLUDELIST 183822 . 184373) (
-PARSE.MODULELIST 184375 . 185140) (PARSE.ELEMENTLIST 185142 . 185722) (PARSE.BINDLIST 185724 . 186299)
- (PARSE.STATEMENTLIST 186301 . 187188) (PARSE.CASESTMTLIST 187190 . 187990) (PARSE.CASELABEL 187992 . 
-189129) (PARSE.EXITLIST 189131 . 189981) (PARSE.KEYLIST 189983 . 190606) (PARSE.CASEEXPLIST 190608 . 
-191400) (PARSE.EXPLIST 191402 . 191952) (PARSE.OPEN 191954 . 192427) (PARSE.CLASS 192429 . 192684) (
-PARSE.CASEHEAD 192686 . 193790) (PARSE.READONLY 193792 . 194144) (PARSE.ORDERED 194146 . 194493) (
-PARSE.BASE 194495 . 194762) (PARSE.PACKED 194764 . 195041) (PARSE.HEAP 195043 . 195438) (PARSE.INLINE 
-195440 . 195717) (PARSE.ARGUMENTS 195719 . 196002) (PARSE.INTERFACE 196004 . 196383) (PARSE.SHARES 
-196385 . 196773) (PARSE.DEFAULT 196775 . 197152) (PARSE.OPTSIZE 197154 . 197651) (PARSE.BOUNDS 197653
- . 198036) (PARSE.LENGTH 198038 . 198394) (PARSE.INDEXTYPE 198396 . 198754) (PARSE.ELSEPART 198756 . 
-199140) (PARSE.OTHERPART 199142 . 199525) (PARSE.FREE 199527 . 199896) (PARSE.CATCHANY 199898 . 200296
-) (PARSE.NOT 200298 . 200519) (PARSE.NEW 200521 . 201189) (PARSE.OPTTYPE 201191 . 201581) (
-PARSE.ARGLIST 201583 . 202361) (PARSE.RETURNLIST 202363 . 203254)) (207200 267345 (BUILD.INIT 207210
- . 207712) (BUILD.PUSH.SCOPE 207714 . 208097) (BUILD.POP.SCOPE 208099 . 208389) (BUILD.GC.SCOPE 208391
- . 208574) (BUILD.STORE.EXPORTS 208576 . 208783) (BUILD.STORE.IDENTLIST 208785 . 209006) (
-BUILD.STORE.INTERFACES 209008 . 209239) (BUILD.STORE.INTERFACE 209241 . 209427) (BUILD.STORE.OPEN 
-209429 . 209637) (BUILD.STORE.USING 209639 . 209853) (BUILD.INITIALIZATION 209855 . 210452) (
-BUILD.INITIALIZE.VARS 210454 . 210808) (BUILD.INITIALIZE.VAR 210810 . 211603) (BUILD.INITIALIZE.FN 
-211605 . 212407) (BUILD.INITIALIZE.RECORD 212409 . 212996) (BUILD.RECORD 212998 . 215217) (BUILD.TYPE 
-215219 . 215849) (BUILD.STORE.ARGLIST 215851 . 216355) (BUILD.STORE.RETURNLIST 216357 . 216879) (
-BUILD.STORE.PAIRLIST 216881 . 217427) (BUILD.STORE.PAIRITEM 217429 . 217821) (BUILD.STORE.VARLIST 
-217823 . 218043) (BUILD.ID 218045 . 218468) (BUILD.FIELDID 218470 . 218594) (BUILD.PROCID 218596 . 
-218743) (BUILD.RECORDID 218745 . 218894) (BUILD.TYPEID 218896 . 219113) (BUILD.VARID 219115 . 219482) 
-(BUILD.LOCALVARID 219484 . 219611) (BUILD.GLOBALVARID 219613 . 219765) (BUILD.ULTIMATE.TYPE 219767 . 
-219947) (BUILD.REFINE.TYPE 219949 . 221606) (BUILD.IMMEDIATE.TYPE 221608 . 225952) (BUILD.LOOKUP.TYPE 
-225954 . 226724) (BUILD.LOOKUP 226726 . 227111) (BUILD.TYPEATOM 227113 . 227307) (BUILD.QUALIFY 227309
- . 228793) (BUILD.QUALIFY.PREFIXOP 228795 . 229043) (BUILD.QUALIFY.TYPEOP 229045 . 229193) (
-BUILD.QUALIFY.EXPLIST 229195 . 231109) (BUILD.QUALIFY.ID 231111 . 232833) (BUILD.ARITH.EXP1 232835 . 
-233061) (BUILD.ARITH.EXP2 233063 . 233299) (BUILD.ARITH.EXP* 233301 . 234455) (BUILD.ARITH.ADD1SUB1 
-234457 . 235388) (BUILD.COERCE.ARITHOP 235390 . 235746) (BUILD.STRONGEST.TYPE.AMONG 235748 . 236236) (
-BUILD.STRONGEST.TYPE 236238 . 236817) (BUILD.COERCE 236819 . 237582) (BUILD.COERCE.MARRAY 237584 . 
-238513) (BUILD.COERCE.MLIST 238515 . 239360) (BUILD.COERCE.EXPLIST 239362 . 241622) (BUILD.ALIGN 
-241624 . 244083) (BUILD.ALIGN.VALUE 244085 . 244593) (BUILD.ADD.TO.FILECOMS 244595 . 245242) (
-BUILD.ADD1 245244 . 245429) (BUILD.CALL 245431 . 245736) (BUILD.CHARCODE 245738 . 247182) (BUILD.COND 
-247184 . 247823) (BUILD.COPY.OF 247825 . 248069) (BUILD.FETCH 248071 . 248805) (BUILD.FORCLAUSE.BY 
-248807 . 248975) (BUILD.FORCLAUSE.IN 248977 . 249971) (BUILD.FORCLAUSE.THROUGH 249973 . 250141) (
-BUILD.IN 250143 . 251232) (BUILD.ISTYPE 251234 . 251790) (BUILD.LAMBDA 251792 . 252244) (BUILD.NEW 
-252246 . 252404) (BUILD.OR 252406 . 252627) (BUILD.PROG 252629 . 253951) (BUILD.PROGN 253953 . 254234)
- (BUILD.REPLACE 254236 . 255039) (BUILD.RETURN 255041 . 256699) (BUILD.SELECTQ 256701 . 258976) (
-BUILD.SELECTQ.FN 258978 . 259175) (BUILD.SELECTQ.CCLAUSE 259177 . 259801) (BUILD.SELECTQ.TEST 259803
- . 260169) (BUILD.SELECTQ.SCLAUSE 260171 . 260608) (BUILD.SELECTQ.KEY 260610 . 261303) (
-BUILD.SELECTTRUEFROM 261305 . 262003) (BUILD.SELECTTRUEFROM.CLAUSE 262005 . 262196) (BUILD.SETQ 262198
- . 264370) (BUILD.SETQ.ARRAY 264372 . 265145) (BUILD.SETQ.ORDERLIST 265147 . 266881) (BUILD.SUB1 
-266883 . 267068) (BUILD.TAIL 267070 . 267343)))))
-STOP
diff --git a/obsolete/lispusers/MICROTEK b/obsolete/lispusers/MICROTEK
deleted file mode 100644
index 59a68a15..00000000
--- a/obsolete/lispusers/MICROTEK
+++ /dev/null
@@ -1,344 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-(FILECREATED " 8-Sep-88 21:43:21" {LISPUSERS}MICROTEK.\;1 63396  
-
-      |changes| |to:|  (FNS MT.START.SCANNING MT.SETUPSCANFILE MT.INIT MT.SHRINKFN MICROTEKSCANNER RULERX RULEX# RULERY RULEY# MT.GETLENGTH MT.CURSOR.IN MT.CURSOR.OUT MT.PRINT.STATUS MT.CHANGE.BRIGHTBAR MT.CHANGE.CONTRASTBAR MT.DRAWAREABOX MT.COMMAND.MENU MT.SCAN MT.SENDCOMMAND MT.COMPUTECHECKSUM MT.SENDACK MT.SENDNAK MT.STOP.SCANNING MT.PAGEMAP MT.QUIT MT.DISPLAY.MENU MT.CREATEBM MT.BITMAPCREATE MT.CONVERTIMAGETOBM MT.CREATE.BIG.BM MT.REPAINTWINDOW MT.RESHAPEWINDOW MT.SEND.SCAN.PARAMETERS MT.PRINT.ERROR.MSG MT.RESET)
- (PROPS (MICROTEK MAKEFILE-ENVIRONMENT))
-
-      |previous| |date:| "23-Jul-88 15:16:49" {PHYLUM}<LISPUSERS>MEDLEY>MICROTEK.\;1)
-
-
-; Copyright (c) 1987, 1988 by XEROX Corporation.  All rights reserved.
-
-(PRETTYCOMPRINT MICROTEKCOMS)
-
-(RPAQQ MICROTEKCOMS ((P (FILESLOAD DLRS232C EDITBITMAP)) (* * |Microtek| |Initialization| |and| |Menu| |Functions|) (FNS MT.INIT MT.SHRINKFN MICROTEKSCANNER RULERX RULEX# RULERY RULEY# MT.GETLENGTH MT.CURSOR.IN MT.CURSOR.OUT MT.PRINT.STATUS MT.CONTROL.MENU MT.CHANGE.BRIGHTBAR MT.RAISEBRIGHTNESS MT.LOWERBRIGHTNESS MT.CHANGE.CONTRASTBAR MT.RAISECONTRAST MT.LOWERCONTRAST MT.SELECT.BACKGROUND MT.GETTRANSFRAME MT.GETWINDOW1 MT.GETWINDOW2 MT.GETWINDOW3 MT.GETWINDOW4 MT.UPDATE.HTWINDOWS MT.DRAWAREABOX) (* * |Command| |Functions|) (FNS MT.COMMAND.MENU MT.GET.OUTFILENAME MT.SCAN MT.START.SCANNING MT.SETUPSCANFILE MT.SEND.SCAN.PARAMETERS MT.SENDCOMMAND MT.COMPUTECHECKSUM MT.PRINT.ERROR.MSG MT.SENDACK MT.SENDNAK MT.STOP.SCANNING MT.RESET MT.PAGEMAP MT.QUIT) (* * |Functions| |to| |convert| |and| |print| |scanned| |images|) (FNS MT.DISPLAY.MENU MT.GET.SOURCEFILENAME MT.GET.BITMAPNAME MT.CREATEBM MT.BITMAPCREATE MT.CONVERTIMAGETOBM MT.CREATE.BIG.BM MT.CREATE.DISPLAYWINDOW MT.REPAINTWINDOW MT.RESHAPEWINDOW) (ADDVARS (|BackgroundMenuCommands| ("MicrotekScanner" (MT.INIT) "Open Microtek Scanner Command and Display windows, initilalize RS232 port and verifies Microtek Scanner is ready"))) (VARS (|BackgroundMenu| NIL)) (VARS MT.ICON MT.ICON.MASK BRIGHTBAR CONTRASTBAR INITIALBRIGHTBAR INITIALCONTRASTBAR LEFTARROW MANCURSOR RIGHTARROW MT.POINTER) (INITVARS (MT.BAUDRATE 19200) (MT.RS232C.FRAME.TIMEOUT 2) (MT.DISPLAYFRAME (QUOTE YES)) (MT.PAPERLENGTH 4) (MT.REDUCTION 0) (MT.CONTRAST 0) (MT.BRIGHTNESS 0) (MT.GREYLEVEL 0) (MT.DATACOMPRESSION (QUOTE NO)) (MT.BACKGROUND (QUOTE HALFTONE)) (MT.WINDOW (QUOTE LINEART)) (MT.FRAME (QUOTE (0 0 40 24))) (MT.FRAME.BOX (QUOTE (0 460 200 120))) (MT.TEXTW1 (QUOTE (0 0 0 0))) (MT.TEXTW2 (QUOTE (0 0 0 0))) (MT.TEXTW3 (QUOTE (0 0 0 0))) (MT.TEXTW4 (QUOTE (0 0 0 0))) (MT.TEXTW1BOX (QUOTE (0 0 0 0))) (MT.TEXTW2BOX (QUOTE (0 0 0 0))) (MT.TEXTW3BOX (QUOTE (0 0 0 0))) (MT.TEXTW4BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW1 (QUOTE (0 0 0 0))) (MT.HALFTONEW2 (QUOTE (0 0 0 0))) (MT.HALFTONEW3 (QUOTE (0 0 0 0))) (MT.HALFTONEW4 (QUOTE (0 0 0 0))) (MT.HALFTONEW1BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW2BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW3BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW4BOX (QUOTE (0 0 0 0))) (MT.OUTSTREAM NIL) (MT.INSTREAM NIL) (MT.BMSHRINKFACTOR 1)) (GLOBALVARS MT.RS232C.FRAME.TIMEOUT MT.STATUSWINDOW MT.HEIGHTRULER MT.GRID MT.PAPERLENGTH MT.REDUCTION MT.BRIGHTNESS MT.CONTRAST MT.GREYLEVEL MT.DATACOMPRESSION MT.BACKGROUND MT.WINDOW MT.HEIGHTWINDOW MT.FRAME MT.FRAME.BOX MT.TEXTW1 MT.TEXTW2 MT.TEXTW3 MT.TEXTW4 MT.HALFTONEW1 MT.HALFTONEW2 MT.HALFTONEW3 MT.HALFTONEW4 MT.OUTSTREAM MT.INSTREAM BRIGHTBAR CONTRASTBAR LEFTARROW MANCURSOR RIGHTARROW) (PROP MAKEFILE-ENVIRONMENT MICROTEK)))
-
-(FILESLOAD DLRS232C EDITBITMAP)
-(* * |Microtek| |Initialization| |and| |Menu| |Functions|)
-
-(DEFINEQ
-
-(MT.INIT
-(LAMBDA NIL (* \; "Edited  8-Sep-88 18:58 by Briggs") (* \; "Edited 20-May-87 11:20 by ") (MICROTEKSCANNER) (MT.CONTROL.MENU) (MT.COMMAND.MENU) (MT.DISPLAY.MENU) (SETQ MT.STATUSWINDOW (CREATEW (QUOTE (0 0 387 30)) "Microtek Status Window")) (ATTACHWINDOW MT.COMMAND.MENUWINDOW MT.CONTROL.MENUWINDOW (QUOTE TOP) (QUOTE JUSTIFY)) (ATTACHWINDOW MT.DISPLAY.MENUWINDOW MT.CONTROL.MENUWINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY)) (ATTACHWINDOW MT.STATUSWINDOW MT.COMMAND.MENUWINDOW (QUOTE TOP) (QUOTE JUSTIFY)) (|if| (FNTYP (QUOTE MT.PRINT.MENU)) |then| (MT.PRINT.MENU)) (MOVEW MT.CONTROL.MENUWINDOW (QUOTE (500 . 160))) (WINDOWPROP MT.CONTROL.MENUWINDOW (QUOTE ICONFN) (QUOTE MT.SHRINKFN)) (BITBLT MT.POINTER 0 0 MTHEIGHTRULER 20 (IDIFFERENCE 453 (FIX (FTIMES 5 (FDIFFERENCE (FQUOTIENT MT.PAPERLENGTH 0.125) 24))))) (CLOSEF? MT.OUTSTREAM) (CLOSEF? MT.INSTREAM) (|if| \\RS232C.READY |then| (RS232C.SHUTDOWN)) (SETQ MT.OUTSTREAM (OPENSTREAM (QUOTE {RS232}) (QUOTE OUTPUT) NIL (QUOTE ((|BaudRate| 19200) (|BitsPerSerialChar| 8) (|Parity| NONE) (|NoOfStopBits| 1) (|FlowControl| NIL) (DTR T))))) (SETQ MT.INSTREAM (RS232C.OTHER.STREAM MT.OUTSTREAM)) (SETQ MT.OLD.RS232C.FRAME.TIME.OUT (RS232C.GET.PARAMETERS (QUOTE (FRAME.TIMEOUT)))) (RS232C.SET.PARAMETERS (LIST (BQUOTE (FRAME.TIMEOUT \\\, MT.RS232C.FRAME.TIMEOUT)))) (MT.SENDCOMMAND 1 (LIST (QUOTE !))) (|if| (SETQ RESPONSE (MT.SENDCOMMAND 1 (LIST (QUOTE !)))) |then| (CLRPROMPT) (MT.PRINT.STATUS (CONCAT RESPONSE " ready")) |else| (RINGBELLS) (MT.PRINT.STATUS "Microtek Not Responding ...Check scanner and cables")))
-)
-
-(MT.SHRINKFN
-(LAMBDA (WINDOW ICON) (* \; "Edited  8-Sep-88 18:59 by Briggs") (PROG NIL (CLOSEW MTDISPLAYWINDOW) (CLOSEW MTDISPLAYWINDOW) (|if| (WINDOWPROP MT.CONTROL.MENUWINDOW (QUOTE ICONWINDOW)) |then| (RETURN (WINDOWPROP MT.CONTROL.MENUWINDOW (QUOTE ICONWINDOW))) |else| (RETURN (ICONW MT.ICON MT.ICON.MASK NIL T)))))
-)
-
-(MICROTEKSCANNER
-(LAMBDA NIL (* \; "Edited  8-Sep-88 18:59 by Briggs") (PROG (MTWIDTHRULER YHEIGHT) (SETQ MTDISPLAYWINDOW (DECODE.WINDOW.ARG (QUOTE (100 . 100)) 350 579 "Microtek Scanner Page Map" 5)) (SETQ MTHEIGHTRULER (DECODE.WINDOW.ARG (QUOTE (100 . 100)) 50 570 NIL 5 T)) (SETQ MTWIDTHRULER (DECODE.WINDOW.ARG (QUOTE (100 . 100)) 350 50 NIL 5 T)) (DSPFONT (FONTCREATE (QUOTE GACHA) 10 (QUOTE BRR)) MTHEIGHTRULER) (DSPFONT (FONTCREATE (QUOTE GACHA) 10 (QUOTE BRR)) MTWIDTHRULER) (ATTACHWINDOW MTHEIGHTRULER MTDISPLAYWINDOW (QUOTE LEFT) (QUOTE JUSTIFY)) (ATTACHWINDOW MTWIDTHRULER MTDISPLAYWINDOW (QUOTE TOP) (QUOTE CENTER)) (WINDOWPROP MTDISPLAYWINDOW (QUOTE RESHAPEFN) (QUOTE (DON\'T))) (WINDOWPROP MTHEIGHTRULER (QUOTE RESHAPEFN) (QUOTE (DON\'T))) (WINDOWPROP MTHEIGHTRULER (QUOTE CURSORINFN) (QUOTE MT.CURSOR.IN)) (WINDOWPROP MTHEIGHTRULER (QUOTE CURSOROUTFN) (QUOTE MT.CURSOR.OUT)) (WINDOWPROP MTHEIGHTRULER (QUOTE BUTTONEVENTFN) (QUOTE MT.GETLENGTH)) (WINDOWPROP MTWIDTHRULER (QUOTE RESHAPEFN) (QUOTE (DON\'T))) (RULERX 0 1 16 16 40 1 MTWIDTHRULER) (RULERX 0 1 12 32 20 1 MTWIDTHRULER) (RULERX 0 1 8 64 10 1 MTWIDTHRULER) (RULERX 0 1 4 128 5 1 MTWIDTHRULER) (RULEX# 0 20 40 0 8 MTWIDTHRULER) (SETQ YHEIGHT 580) (RULERY YHEIGHT 1 16 15 -40 1 MTHEIGHTRULER) (RULERY YHEIGHT 1 12 28 -20 1 MTHEIGHTRULER) (RULERY YHEIGHT 1 8 56 -10 1 MTHEIGHTRULER) (RULERY YHEIGHT 1 4 112 -5 1 MTHEIGHTRULER) (RULEY# 0 YHEIGHT -40 0 14 MTHEIGHTRULER) (SETQ MT.HEIGHT.BM (BITMAPCREATE 50 588)) (BITBLT MTHEIGHTRULER 0 0 MT.HEIGHT.BM) (SETQ MT.GRID (BITMAPCREATE 350 579)) (GRID (QUOTE (0 20 10 10)) 42 56 (QUOTE POINT) MTDISPLAYWINDOW) (BITBLT MTDISPLAYWINDOW 0 0 MT.GRID)))
-)
-
-(RULERX
-(LAMBDA (STARTX STARTY LEN NUMLINES INCR LINEWIDTH WIND) (* \; "Edited  8-Sep-88 19:00 by Briggs") (|for| I |from| 1 |to| NUMLINES |do| (DRAWLINE STARTX 1 STARTX LEN LINEWIDTH NIL WIND) (SETQ STARTX (PLUS STARTX INCR))))
-)
-
-(RULEX#
-(LAMBDA (STARTX STARTY INCR STARTNUMBER ENDNUMBER WIND) (* \; "Edited  8-Sep-88 19:00 by Briggs") (|for| I |from| STARTNUMBER |to| ENDNUMBER |do| (MOVETO STARTX STARTY WIND) (PRINT I WIND) (SETQ STARTX (PLUS STARTX INCR))))
-)
-
-(RULERY
-(LAMBDA (STARTY STARTX LEN NUMLINES INCR LINEWIDTH WIND) (* \; "Edited  8-Sep-88 19:00 by Briggs") (|for| I |from| 1 |to| NUMLINES |do| (DRAWLINE (DIFFERENCE (WINDOWPROP WIND (QUOTE WIDTH)) STARTX) STARTY (DIFFERENCE (DIFFERENCE (WINDOWPROP WIND (QUOTE WIDTH)) STARTX) LEN) STARTY LINEWIDTH NIL WIND) (SETQ STARTY (PLUS STARTY INCR))))
-)
-
-(RULEY#
-(LAMBDA (STARTX STARTY INCR STARTNUMBER ENDNUMBER WIND) (* \; "Edited  8-Sep-88 19:00 by Briggs") (|for| I |from| STARTNUMBER |to| ENDNUMBER |do| (MOVETO STARTX STARTY WIND) (PRINT I WIND) (SETQ STARTY (PLUS STARTY INCR))))
-)
-
-(MT.GETLENGTH
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:00 by Briggs") (TOTOPW MTHEIGHTRULER) (|if| (MOUSESTATE LEFT) |then| (SETQ MT.PAPERLENGTH (IMIN 453 (CDR (CURSORPOSITION NIL MTHEIGHTRULER)))) (CLEARW MTHEIGHTRULER) (BITBLT MT.HEIGHT.BM 0 0 MTHEIGHTRULER 0 0) (BITBLT MT.POINTER 0 0 MTHEIGHTRULER 20 MT.PAPERLENGTH) (SETQ MT.PAPERLENGTH (FTIMES (FIX (FPLUS 24.0 (FQUOTIENT (FDIFFERENCE 453 MT.PAPERLENGTH) 5))) 0.125)) (FM.CHANGESTATE (FM.GETITEM (QUOTE PAGELENGTH) NIL MT.CONTROL.MENUWINDOW) MT.PAPERLENGTH MT.CONTROL.MENUWINDOW)))
-)
-
-(MT.CURSOR.IN
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:00 by Briggs") (CURSOR (CURSORCREATE MT.POINTER 8 0))))
-
-(MT.CURSOR.OUT
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:00 by Briggs") (CURSOR T)))
-
-(MT.PRINT.STATUS
-(LAMBDA (MSG) (* \; "Edited  8-Sep-88 19:00 by Briggs") (CLEARW MT.STATUSWINDOW) (PRIN1 MSG MT.STATUSWINDOW))
-)
-
-(MT.CONTROL.MENU
-(LAMBDA NIL (* \; "Edited 12-Mar-87 14:32 by rdc") (PROG (MENU.DESCRIPTION) (SETQ MENU.DESCRIPTION (BQUOTE (((PROPS ID RC) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL "   Grain Size   Levels" BOX 1 FONT (MODERN 10 BOLD) HJUSTIFY RIGHT)) ((TYPE STATE LABEL "Reduction!" MENUITEMS (" 0% = 300 DPI" " 5% = 285 DPI" "10% = 270 DPI" "15% = 255 DPI" "20% = 240 DPI" "25% = 225 DPI" "33% = 200 DPI" "35% = 195 DPI" "40% = 180 DPI" "45% = 165 DPI" "50% = 150 DPI" "55% = 135 DPI" "60% = 120 DPI" "67% = 100 DPI" "70% =  90 DPI" "75% =  75 DPI") INITSTATE " 0% = 300 DPI" LINKS (DISPLAY (GROUP REDUCTION)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID REDUCTION LABEL "" MAXWIDTH 120 BOX 1) (TYPE STATE LABEL "Gray Level!" MENUITEMS (" 0 =   8X8    33" " 1 =   8X8    33" " 2 =   8X8    33" " 3 =   8X8    33" " 4 =   6X6    37" " 5 =   5X5    26" " 6 =   5X5    18" " 7 =   4X4    17" " 8 =   4X4    17" " 9 =   4X4    17" "10 =   3X3    10" "11 =   2X2     5") INITSTATE " 0 =   8X8    33" LINKS (DISPLAY (GROUP GREYLEVEL)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID GREYLEVEL LABEL "" MAXWIDTH 120 BOX 1)) ((TYPE DISPLAY LABEL "")))) ((PROPS ID CD) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE DISPLAY LABEL "Contrast:" FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY LABEL \, LEFTARROW HELDFN MT.LOWERCONTRAST MESSAGE "" BOX 1) (TYPE DISPLAY LABEL \, CONTRASTBAR ID CONTRASTBAR MAXWIDTH 130 BOX 1) (TYPE DISPLAY LABEL \, RIGHTARROW HELDFN MT.RAISECONTRAST MESSAGE "" BOX 1) (TYPE EDIT ID CONTRAST LABEL 0 BOX 1 MAXWIDTH 23)) ((TYPE DISPLAY LABEL |Brightness:| FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY LABEL \, LEFTARROW HELDFN MT.LOWERBRIGHTNESS MESSAGE "" BOX 1) (TYPE DISPLAY LABEL \, BRIGHTBAR ID BRIGHTBAR MAXWIDTH 130 BOX 1) (TYPE DISPLAY LABEL \, RIGHTARROW HELDFN MT.RAISEBRIGHTNESS MESSAGE "" BOX 1) (TYPE EDIT ID BRIGHTNESS LABEL 0 BOX 1 MAXWIDTH 23)) ((TYPE DISPLAY LABEL "")))) ((PROPS ID MODE) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE STATE LABEL "Background!" ID BACK MENUITEMS ("HALFTONE" "LINEART") INITSTATE "HALFTONE" LINKS (DISPLAY (GROUP BACKGROUNDDISPLAY)) SELECTEDFN MT.SELECT.BACKGROUND FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY LABEL "" ID BACKGROUNDDISPLAY MAXWIDTH 57 BOX 1) (TYPE DISPLAY LABEL "Window Mode:" FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOWTYPE LABEL (\\\, MT.WINDOW) MAXWIDTH 58 BOX 1) (TYPE DISPLAY LABEL "Page Length:" FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID PAGELENGTH LABEL "" BOX 1 MAXWIDTH 45)) ((TYPE DISPLAY LABEL "")))) ((PROPS ID WINDOW) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE MOMENTARY LABEL "Frame! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETTRANSFRAME BOX 1) (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TX1 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TY1 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TX2 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TY2 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE DISPLAY LABEL "")) ((TYPE MOMENTARY LABEL "Window 1! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW1 BOX 1) (TYPE STATE LABEL "ON?" ID SW1 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW1)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW1 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X11 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y11 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X21 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y21 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE MOMENTARY LABEL "Window 2! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW2 BOX 1) (TYPE STATE LABEL "ON?" ID SW2 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW2)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW2 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X12 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y12 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X22 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y22 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE MOMENTARY LABEL "Window 3! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW3 BOX 1) (TYPE STATE LABEL "ON?" ID SW3 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW3)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW3 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X13 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y13 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X23 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y23 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE MOMENTARY LABEL "Window 4! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW4 BOX 1) (TYPE STATE LABEL "ON?" ID SW4 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW4)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW4 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X14 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y14 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X24 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y24 LABEL "" MAXWIDTH 45 BOX 1))))))) (SETQ MT.CONTROL.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Configuration Menu" 23130 5)) (FM.CHANGESTATE (FM.GETITEM (QUOTE BACK) NIL MT.CONTROL.MENUWINDOW) MT.BACKGROUND MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX1) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY1) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX2) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY2) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (MT.SELECT.BACKGROUND) (FM.CHANGESTATE (FM.GETITEM (QUOTE PAGELENGTH) NIL MT.CONTROL.MENUWINDOW) MT.PAPERLENGTH MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE REDUCTION) NIL MT.CONTROL.MENUWINDOW) MT.REDUCTION MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE CONTRAST) NIL MT.CONTROL.MENUWINDOW) MT.CONTRAST MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE BRIGHTNESS) NIL MT.CONTROL.MENUWINDOW) MT.BRIGHTNESS MT.CONTROL.MENUWINDOW) (MT.CHANGE.BRIGHTBAR MT.BRIGHTNESS) (MT.CHANGE.CONTRASTBAR MT.CONTRAST) (OPENW MT.CONTROL.MENUWINDOW)))
-)
-
-(MT.CHANGE.BRIGHTBAR
-(LAMBDA (BRIGHTNESS) (* \; "Edited  8-Sep-88 19:01 by Briggs") (* |;;;| "Moves the cursor in BRIGHTBAR from one place to another.") (BITBLT INITIALBRIGHTBAR NIL NIL BRIGHTBAR NIL NIL NIL NIL NIL (QUOTE REPLACE)) (BITBLT MANCURSOR NIL NIL BRIGHTBAR (IPLUS 60 (FIX (TIMES BRIGHTNESS 2))) 0 10 10 NIL (QUOTE INVERT)) (FM.CHANGELABEL (FM.GETITEM (QUOTE BRIGHTBAR) NIL MT.CONTROL.MENUWINDOW) BRIGHTBAR MT.CONTROL.MENUWINDOW))
-)
-
-(MT.RAISEBRIGHTNESS
-(LAMBDA NIL (* \; "Edited  5-Mar-87 13:05 by RDC") (|if| (LEQ (IPLUS MT.BRIGHTNESS 4) 28) |then| (MT.CHANGE.BRIGHTBAR (SETQ MT.BRIGHTNESS (IPLUS MT.BRIGHTNESS 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE BRIGHTNESS) NIL MT.CONTROL.MENUWINDOW) MT.BRIGHTNESS MT.CONTROL.MENUWINDOW))
-)
-
-(MT.LOWERBRIGHTNESS
-(LAMBDA NIL (* \; "Edited  5-Mar-87 13:04 by RDC") (|if| (GEQ (IDIFFERENCE MT.BRIGHTNESS 4) -24) |then| (MT.CHANGE.BRIGHTBAR (SETQ MT.BRIGHTNESS (IDIFFERENCE MT.BRIGHTNESS 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE BRIGHTNESS) NIL MT.CONTROL.MENUWINDOW) MT.BRIGHTNESS MT.CONTROL.MENUWINDOW))
-)
-
-(MT.CHANGE.CONTRASTBAR
-(LAMBDA (CONTRAST) (* \; "Edited  8-Sep-88 19:01 by Briggs") (* |;;;| "Moves the diamond cursor around inside CONTRASTBAR.") (BITBLT INITIALCONTRASTBAR NIL NIL CONTRASTBAR NIL NIL NIL NIL NIL (QUOTE REPLACE)) (BITBLT MANCURSOR NIL NIL CONTRASTBAR (IPLUS 60 (FIX (TIMES CONTRAST 2))) 0 10 10 NIL (QUOTE INVERT)) (FM.CHANGELABEL (FM.GETITEM (QUOTE CONTRASTBAR) NIL MT.CONTROL.MENUWINDOW) CONTRASTBAR MT.CONTROL.MENUWINDOW))
-)
-
-(MT.RAISECONTRAST
-(LAMBDA NIL (* \; "Edited  5-Mar-87 13:04 by RDC") (|if| (LEQ (IPLUS MT.CONTRAST 4) 28) |then| (MT.CHANGE.CONTRASTBAR (SETQ MT.CONTRAST (IPLUS MT.CONTRAST 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE CONTRAST) NIL MT.CONTROL.MENUWINDOW) MT.CONTRAST MT.CONTROL.MENUWINDOW))
-)
-
-(MT.LOWERCONTRAST
-(LAMBDA NIL (* \; "Edited  5-Mar-87 13:03 by RDC") (|if| (GEQ (IDIFFERENCE MT.CONTRAST 4) -24) |then| (MT.CHANGE.CONTRASTBAR (SETQ MT.CONTRAST (IDIFFERENCE MT.CONTRAST 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE CONTRAST) NIL MT.CONTROL.MENUWINDOW) MT.CONTRAST MT.CONTROL.MENUWINDOW))
-)
-
-(MT.SELECT.BACKGROUND
-(LAMBDA NIL (* \; "Edited  5-Mar-87 15:09 by RDC") (SETQ MT.BACKGROUND (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) (|if| (STREQUAL MT.BACKGROUND "LINEART") |then| (FM.CHANGELABEL (FM.GETITEM (QUOTE WINDOWTYPE) NIL MT.CONTROL.MENUWINDOW) "HALFTONE" MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) |else| (FM.CHANGELABEL (FM.GETITEM (QUOTE WINDOWTYPE) NIL MT.CONTROL.MENUWINDOW) "LINEART" MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW)) (MT.UPDATE.HTWINDOWS))
-)
-
-(MT.GETTRANSFRAME
-(LAMBDA NIL (* \; "Edited  5-Mar-87 13:28 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX1) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY1) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX2) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY2) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (SETQ MT.FRAME (LIST X1 Y1 X2 Y2)) (SETQ MT.FRAME.BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) (MT.UPDATE.HTWINDOWS)))
-)
-
-(MT.GETWINDOW1
-(LAMBDA NIL (* \; "Edited  5-Mar-87 14:23 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X11) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y11) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X21) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y21) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW1 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW1BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW1 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW1BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS)))
-)
-
-(MT.GETWINDOW2
-(LAMBDA NIL (* \; "Edited  5-Mar-87 14:24 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X12) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y12) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X22) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y22) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW2 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW2BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW2 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW2BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS)))
-)
-
-(MT.GETWINDOW3
-(LAMBDA NIL (* \; "Edited  5-Mar-87 14:25 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X13) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y13) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X23) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y23) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW3 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW3BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW3 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW3BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS)))
-)
-
-(MT.GETWINDOW4
-(LAMBDA NIL (* \; "Edited  5-Mar-87 14:26 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X14) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y14) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X24) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y24) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW4 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW4BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW4 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW4BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS)))
-)
-
-(MT.UPDATE.HTWINDOWS
-(LAMBDA NIL (* \; "Edited 12-Mar-87 12:29 by rdc") (PROG ((PARAMETER.LIST (FM.GETSTATE MT.CONTROL.MENUWINDOW)) (WINDOW (LIST 0 0 0 0))) (CLEARW MTDISPLAYWINDOW) (BITBLT MT.GRID 0 0 MTDISPLAYWINDOW) (MT.DRAWAREABOX (CAR MT.FRAME.BOX) (CADR MT.FRAME.BOX) (CADDR MT.FRAME.BOX) (CADDDR MT.FRAME.BOX) 2 NIL MTDISPLAYWINDOW) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW1)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW1BOX) |else| (SETQ WINDOW MT.HALFTONEW1BOX))) (BLTSHADE 2000 MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW2)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW2BOX) |else| (SETQ WINDOW MT.HALFTONEW2BOX))) (BLTSHADE GRAYSHADE MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW3)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW3BOX) |else| (SETQ WINDOW MT.HALFTONEW3BOX))) (BLTSHADE 45 MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW4)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW4BOX) |else| (SETQ WINDOW MT.HALFTONEW4BOX))) (BLTSHADE 50000 MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW))))
-)
-
-(MT.DRAWAREABOX
-(LAMBDA (BOXLEFT BOXBOTTOM BOXWIDTH BOXHEIGHT BORDER OP W TEXTURE) (* \; "Edited  8-Sep-88 19:02 by Briggs") (OR TEXTURE (SETQ TEXTURE BLACKSHADE)) (* \; "draws lines inside the region.") (* \; "draw left edge") (BITBLT NIL NIL NIL W BOXLEFT BOXBOTTOM BORDER BOXHEIGHT (QUOTE TEXTURE) OP TEXTURE) (* \; "draw top") (BITBLT NIL NIL NIL W (PLUS BOXLEFT BORDER) (DIFFERENCE (PLUS BOXBOTTOM BOXHEIGHT) BORDER) (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) BORDER (QUOTE TEXTURE) OP TEXTURE) (* \; "draw bottom") (BITBLT NIL NIL NIL W (PLUS BOXLEFT BORDER) BOXBOTTOM (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) BORDER (QUOTE TEXTURE) OP TEXTURE) (* \; "draw right edge") (BITBLT NIL NIL NIL W (DIFFERENCE (PLUS BOXLEFT BOXWIDTH) BORDER) BOXBOTTOM BORDER BOXHEIGHT (QUOTE TEXTURE) OP TEXTURE))
-)
-)
-(* * |Command| |Functions|)
-
-(DEFINEQ
-
-(MT.COMMAND.MENU
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:02 by Briggs") (PROG (MENU.DESCRIPTION) (SETQ MENU.DESCRIPTION (BQUOTE (((PROPS ID COMMAND) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE MOMENTARY LABEL SCAN! FONT (MODERN 12 BOLD) SELECTEDFN MT.SCAN BOX 3) (TYPE MOMENTARY LABEL STOP! FONT (MODERN 12 BOLD) SELECTEDFN MT.STOP.SCANNING BOX 3) (TYPE MOMENTARY LABEL RESET! FONT (MODERN 12 BOLD) SELECTEDFN MT.RESET BOX 3) (TYPE MOMENTARY LABEL PAGEMAP! FONT (MODERN 12 BOLD) SELECTEDFN MT.PAGEMAP BOX 3) (TYPE MOMENTARY LABEL QUIT! ID QUIT FONT (MODERN 12 BOLD) SELECTEDFN MT.QUIT BOX 3)))) ((PROPS ID COMMAND2) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE MOMENTARY LABEL "Output Filename!: " FONT (MODERN 10 BOLD) SELECTEDFN MT.GET.OUTFILENAME BOX 1) (TYPE EDIT ID OUTFILENAME LABEL {DSK}<LISPFILES>IMAGE BOX 1 MAXWIDTH 375))))))) (SETQ MT.COMMAND.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Command Menu" 23130 5)) (OPENW MT.COMMAND.MENUWINDOW)))
-)
-
-(MT.GET.OUTFILENAME
-(LAMBDA NIL (* \; "Edited 12-Mar-87 14:48 by rdc") (FM.EDITITEM (FM.GETITEM (QUOTE OUTFILENAME) NIL MT.COMMAND.MENUWINDOW) MT.COMMAND.MENUWINDOW))
-)
-
-(MT.SCAN
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:02 by Briggs") (ADD.PROCESS (QUOTE (MT.START.SCANNING)) (QUOTE NAME) (QUOTE MICROTEK.SCANNING)))
-)
-
-(MT.START.SCANNING
-(LAMBDA NIL (* \; "Edited  8-Sep-88 21:36 by Briggs") (PROG (HDR DATACOUNT (SCANLINECOUNT 0) CHECKSUM NUMBEROFBYTES OUTFILESTREAM CORESTREAM SOR RT (LINEBUFFERSIZE 0) LINEBUFFER GREYLEVEL REDUCTION DATASIZE) (* |;;| "Reset the Scanner") (MT.RESET) (* |;;| "Send the scan parameters") (|if| (NOT (MT.SEND.SCAN.PARAMETERS)) |then| (MT.PRINT.STATUS "Scanning parameters not valid") (RINGBELLS) (BLOCK 2000) (MT.RESET) (RETURN NIL)) (* |;;| "Setup the Core output file") (SETQ CORESTREAM (MT.SETUPSCANFILE)) (* |;;| "Send start scanning command") (MT.SENDCOMMAND 1 (LIST (QUOTE S))) (MT.PRINT.STATUS "[scanning]") (* |;;| "Get headerof each line") AGAIN (SETQ SOR (BIN MT.INSTREAM)) (SETQ RT (BIN MT.INSTREAM)) (SETQ DATACOUNT (IPLUS (ITIMES 256 (BIN MT.INSTREAM)) (BIN MT.INSTREAM))) (SELECTQ RT ((0 4) (* |;;| "since we never NAK, we can speed up the processing by ACKing early") (MT.SENDACK) (SETQ DATASIZE DATACOUNT) (* \; "needed later") (SETQ SCANLINECOUNT (IPLUS SCANLINECOUNT 1)) (COND ((IGREATERP DATACOUNT LINEBUFFERSIZE) (SETQ LINEBUFFER (ARRAY DATACOUNT (QUOTE BYTE) 0 0)))) (AIN LINEBUFFER 0 DATACOUNT MT.INSTREAM) (AOUT LINEBUFFER 0 DATACOUNT CORESTREAM) (SETQ CHECKSUM (BIN MT.INSTREAM)) (GO AGAIN)) (128 (SELCHARQ (BIN MT.INSTREAM) (E (BIN MT.INSTREAM) (MT.SENDACK) (MT.PRINT.STATUS "[scanning done]")) (? (|to| DATACOUNT |do| (MT.PRINT.ERROR.MSG (BIN MT.INSTREAM))) (MT.SENDACK) (CLOSEF? CORESTREAM) (RETURN NIL)) NIL)) (PROGN (MT.PRINT.STATUS "[ERROR: unrecognized record type from scanner]") (RETURN NIL))) (MT.PRINT.STATUS "[copying to file]") (SETQ NUMBEROFBYTES (GETFILEPTR CORESTREAM)) (SETQ OUTFILESTREAM (OPENSTREAM (LISTGET (FM.GETSTATE MT.COMMAND.MENUWINDOW) (QUOTE OUTFILENAME)) (QUOTE OUTPUT))) (* |;;| "print header on file, the  NO indicates that this file does not contain compressed data") (PRINT (QUOTE NO) OUTFILESTREAM) (SETQ REDUCTION (SUBSTRING (CADR (MEMBER "Reduction!" (FM.GETSTATE MT.CONTROL.MENUWINDOW))) 1 2)) (|if| (STREQUAL (SUBSTRING REDUCTION 1 1) " ") |then| (SETQ REDUCTION (SUBSTRING REDUCTION 2 2))) (PRINT (MKATOM REDUCTION) OUTFILESTREAM) (SETQ GREYLEVEL (SUBSTRING (CADR (MEMBER "Gray Level!" (FM.GETSTATE MT.CONTROL.MENUWINDOW))) 1 2)) (|if| (STREQUAL (SUBSTRING GREYLEVEL 1 1) " ") |then| (SETQ GREYLEVEL (SUBSTRING GREYLEVEL 2 2))) (PRINT (MKATOM GREYLEVEL) OUTFILESTREAM) (PRINT (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE CONTRAST)) OUTFILESTREAM) (PRINT (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BRIGHTNESS)) OUTFILESTREAM) (PRINT SCANLINECOUNT OUTFILESTREAM) (PRINT DATASIZE OUTFILESTREAM) (SETFILEPTR CORESTREAM 0) (COPYBYTES CORESTREAM OUTFILESTREAM NUMBEROFBYTES) (CLOSEF OUTFILESTREAM) (CLOSEF CORESTREAM) (MT.PRINT.STATUS "[done]")))
-)
-
-(MT.SETUPSCANFILE
-(LAMBDA NIL (* \; "Edited  8-Sep-88 21:13 by Briggs") (* |;;;| "will check to see if the scratch file is in core.  If it is it will dirty 500 pages to bring them into real memory (speedup when writing to them!).  If there wasn't a file, it creates it and then dirtys 500 pgs.  RETURNS: stream to the file") (PROG (RECOG FILE) (MT.PRINT.STATUS "[setting up scratch file]") (SETQ FILE (OPENSTREAM (QUOTE {SCRATCH}) (QUOTE BOTH) (QUOTE NEW) (QUOTE (SEQUENTIAL T)))) (* |;;;| "now expand the file so you can read and transfer fast") (|for| I |from| 0 |to| 260000 |by| 512 |do| (SETFILEPTR FILE I) (BOUT FILE 1)) (* |;;;| "and reset to the beginning") (SETFILEPTR FILE 0) (MT.PRINT.STATUS "[scratch file set up]") (RETURN FILE)))
-)
-
-(MT.SEND.SCAN.PARAMETERS
-(LAMBDA NIL (DECLARE (GLOBALVARS MT.CONTROL.MENUWINDOW MT.PAPERLENGTH MT.FRAME)) (* \; "Edited  8-Sep-88 18:38 by Briggs") (PROG (PARAMETER.LIST PAPERLENGTH SCANFRAME BACKGROUND GREYLEVEL CONTRAST BRIGHTNESS RESOLUTION REDUCTION DATACOMPRESSION (NO.OF.WINDOWS 0) (COORD.LIST NIL)) (SETQ PARAMETER.LIST (FM.GETSTATE MT.CONTROL.MENUWINDOW)) (SETQ PAPERLENGTH (IPLUS 24 (QUOTIENT (FDIFFERENCE MT.PAPERLENGTH 3.0) 0.125))) (SETQ SCANFRAME MT.FRAME) (|if| (EQ (MKATOM (LISTGET PARAMETER.LIST (QUOTE BACK))) (QUOTE HALFTONE)) |then| (SETQ BACKGROUND (QUOTE H)) |else| (SETQ BACKGROUND (QUOTE T))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW1)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW1 |else| MT.HALFTONEW1)))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW2)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW2 |else| MT.HALFTONEW2)))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW3)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW3 |else| MT.HALFTONEW3)))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW4)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW4 |else| MT.HALFTONEW4)))) (|if| (STREQUAL (SUBSTRING (SETQ GREYLEVEL (SUBSTRING (CADR (MEMBER "Gray Level!" PARAMETER.LIST)) 1 2)) 1 1) " ") |then| (SETQ GREYLEVEL (SUBSTRING GREYLEVEL 2 2))) (SETQ GREYLEVEL (MKATOM GREYLEVEL)) (SETQ CONTRAST (IPLUS 7 (IQUOTIENT (MKATOM (LISTGET PARAMETER.LIST (QUOTE CONTRAST))) 4))) (SETQ BRIGHTNESS (IPLUS 7 (IQUOTIENT (MKATOM (LISTGET PARAMETER.LIST (QUOTE BRIGHTNESS))) 4))) (|if| (STREQUAL (SUBSTRING (SETQ REDUCTION (SUBSTRING (CADR (MEMBER "Reduction!" PARAMETER.LIST)) 1 2)) 1 1) " ") |then| (SETQ REDUCTION (SUBSTRING REDUCTION 2 2))) (SETQ RESOLUTION (LISTGET (QUOTE (0 16 5 17 10 18 15 19 20 20 25 21 33 22 35 23 40 24 45 25 50 26 55 27 60 28 67 29 70 30 75 31)) (MKATOM REDUCTION))) (|if| (EQ (QUOTE YES) (MKATOM (LISTGET PARAMETER.LIST (QUOTE COMPRESSDATA)))) |then| (SETQ DATACOMPRESSION 1) |else| (SETQ DATACOMPRESSION 0)) (|if| (AND (MT.SENDCOMMAND 2 (LIST (QUOTE L) PAPERLENGTH)) (MT.SENDCOMMAND 5 (APPEND (LIST (QUOTE F)) SCANFRAME)) (|if| (GREATERP NO.OF.WINDOWS 0) |then| (MT.SENDCOMMAND (IPLUS 2 (ITIMES NO.OF.WINDOWS 4)) (APPEND (LIST BACKGROUND) (LIST NO.OF.WINDOWS) COORD.LIST)) |else| (MT.SENDCOMMAND 2 (APPEND (LIST BACKGROUND) (LIST 0)))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE G)) (LIST GREYLEVEL))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE K)) (LIST CONTRAST))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE B)) (LIST BRIGHTNESS))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE R)) (LIST RESOLUTION))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE C)) (LIST DATACOMPRESSION)))) |then| (RETURN T) |else| (RETURN NIL))))
-)
-
-(MT.SENDCOMMAND
-(LAMBDA (DATACOUNT DATALIST) (* \; "Edited  8-Sep-88 19:03 by Briggs") (PROG (DATA RESPONSE (CHECKSUM 0) (RETRYCOUNT 0)) (* \; "SEND \\ AND 80H") RETRY (BOUT MT.OUTSTREAM (CHARCODE "\\")) (BOUT MT.OUTSTREAM 128) (BOUT MT.OUTSTREAM 0) (BOUT MT.OUTSTREAM DATACOUNT) (SETQ CHECKSUM (IPLUS CHECKSUM 128 0 DATACOUNT)) (|for| DATA |in| DATALIST |do| (|if| (NUMBERP DATA) |then| (BOUT MT.OUTSTREAM DATA) (SETQ CHECKSUM (IPLUS CHECKSUM DATA)) |else| (BOUT MT.OUTSTREAM (CAR (CHCON DATA))) (SETQ CHECKSUM (IPLUS CHECKSUM (CAR (CHCON DATA)))))) (FORCEOUTPUT MT.OUTSTREAM) (BOUT MT.OUTSTREAM (IPLUS (LOGXOR 255 CHECKSUM) 1)) (FORCEOUTPUT MT.OUTSTREAM) REREAD (BLOCK 500) (SETQ RESPONSE (|while| (READP MT.INSTREAM) |collect| (BIN MT.INSTREAM))) (|if| (AND (NEQ (CAR RESPONSE) 92) (NEQ (CAR RESPONSE) 6)) |then| (SETQ CHECKSUM 0) (SETQ RETRYCOUNT (IPLUS RETRYCOUNT 1)) (|if| (EQ RETRYCOUNT 5) |then| (RETURN NIL) |else| (GO RETRY))) (|if| (GREATERP (LENGTH RESPONSE) 2) |then| (* |;;;| "Compute checksum on all characters after the \\") (|if| (NOT (SETQ RESPONSE (MT.COMPUTECHECKSUM (CDR (MEMBER (CHARCODE "\\") RESPONSE))))) |then| (GO REREAD)) (|if| (EQP (CAR RESPONSE) (CHARCODE ?)) |then| (MT.PRINT.ERROR.MSG (CADR RESPONSE)) (RETURN NIL) |else| (RETURN (PACKC RESPONSE))) |else| (RETURN T))))
-)
-
-(MT.COMPUTECHECKSUM
-(LAMBDA (RESPONSE) (* \; "Edited  8-Sep-88 19:03 by Briggs") (* |;;;| "Response should be all bytes after the \\.  Byte 1 = Command type Byte 2 = High part data count Byte 3 = Low part of data count after databytes should be Checksum and remaining data after this is extraneous") (PROG (DATACOUNT LENGTHDIFF DATALIST CHECKSUM (SUMCHECK 0)) (SETQ DATALIST RESPONSE) (SETQ DATACOUNT (IPLUS (LLSH (CADR RESPONSE) 8) (CADDR RESPONSE))) (SETQ LENGTHDIFF (IDIFFERENCE (LENGTH RESPONSE) (IPLUS DATACOUNT 3))) (|for| I |from| 1 |to| LENGTHDIFF |do| (SETQ DATALIST (REVERSE (CDR (REVERSE DATALIST))))) (SETQ CHECKSUM (CAR (NTH RESPONSE (IPLUS 4 DATACOUNT)))) (|for| DATA |in| DATALIST |do| (SETQ SUMCHECK (IPLUS SUMCHECK DATA))) (|if| (OR (EQP CHECKSUM (IPLUS (LOGXOR 255 (LRSH (LLSH SUMCHECK 24) 24)) 1)) (EQ CHECKSUM 0)) |then| (MT.SENDACK) (* |;;;| "Return data minus the response type, hi & low data count and checksum") (RETURN (CDDDR DATALIST)) |else| (MT.SENDNAK) (RETURN NIL))))
-)
-
-(MT.PRINT.ERROR.MSG
-(LAMBDA (ERRORCODE) (* \; "Edited  8-Sep-88 12:52 by Briggs") (RINGBELLS) (SELECTQ ERRORCODE (1 (MT.PRINT.STATUS "U88 ROM FAILURE")) (2 (MT.PRINT.STATUS "U81 ROM FAILURE")) (3 (MT.PRINT.STATUS "U64 ROM FAILURE")) (4 (MT.PRINT.STATUS "U72 ROM FAILURE")) (6 (MT.PRINT.STATUS "U23 ROM FAILURE")) (7 (MT.PRINT.STATUS "U31 ROM FAILURE")) (8 (MT.PRINT.STATUS "U29 ROM FAILURE")) (9 (MT.PRINT.STATUS "Paper sensor failure")) (16 (MT.PRINT.STATUS "Lamp failure or image sensor circuit failure")) (128 (MT.PRINT.STATUS "Illegal Command")) (129 (MT.PRINT.STATUS "Illegal Gray Scale Setting")) (131 (MT.PRINT.STATUS "Illegal Resolution Setting")) (132 (MT.PRINT.STATUS "Illegal Data Compression Parameter")) (133 (MT.PRINT.STATUS "Illegal Scanning Frame Coordinate")) (134 (MT.PRINT.STATUS "Illegal number of windows")) (135 (MT.PRINT.STATUS "Illegal window coordinate")) (136 (MT.PRINT.STATUS "Illegal Contrast Setting")) (137 (MT.PRINT.STATUS "Illegal Paper Length setting")) (138 (MT.PRINT.STATUS "Record Type error")) (139 (MT.PRINT.STATUS "NAK receiced on 5 consecutive transmissions")) (140 (MT.PRINT.STATUS "Paper jammed or longer than length setting")) (141 (MT.PRINT.STATUS "Illegal Brightness setting")) NIL))
-)
-
-(MT.SENDACK
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:03 by Briggs") (BOUT MT.OUTSTREAM 6) (FORCEOUTPUT MT.OUTSTREAM))
-)
-
-(MT.SENDNAK
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:03 by Briggs") (BOUT MT.OUTSTREAM 21) (FORCEOUTPUT MT.OUTSTREAM))
-)
-
-(MT.STOP.SCANNING
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:03 by Briggs") (PROG NIL (BOUT MT.OUTSTREAM 3) (FORCEOUTPUT MT.OUTSTREAM) (DEL.PROCESS (BQUOTE MICROTEK.SCANNING)) (MT.RESET)))
-)
-
-(MT.RESET
-(LAMBDA NIL (* \; "Edited  8-Sep-88 12:51 by Briggs") (|if| (AND (EQ \\RS232C.READY T) (EQ (CDAR (RS232C.GET.PARAMETERS (QUOTE (|BaudRate|)))) MT.BAUDRATE) (EQ (CADAR (RS232C.GET.PARAMETERS (QUOTE (|FlowControl|)))) 0) (LEQ (CDAR (RS232C.GET.PARAMETERS (QUOTE (FRAME.TIMEOUT)))) 50) (OPENP MT.OUTSTREAM) (OPENP MT.INSTREAM)) |then| (MT.SENDCOMMAND 1 (LIST (QUOTE X))) |else| (RS232C.INIT MT.BAUDRATE 8 (QUOTE NONE) 1 (QUOTE DTR)) (CLOSEF? MT.OUTSTREAM) (CLOSEF? MT.INSTREAM) (SETQ MT.OUTSTREAM (OPENSTREAM (QUOTE {RS232}) (QUOTE OUTPUT))) (SETQ MT.INSTREAM (RS232C.OTHER.STREAM MT.OUTSTREAM)) (RS232C.SET.PARAMETERS (LIST (BQUOTE (FRAME.TIMEOUT \\\, MT.RS232C.FRAME.TIMEOUT))))) (DELFILE (CLOSEF? (QUOTE {CORE}SCANNER.SCRATCH))) (MT.SENDCOMMAND 1 (LIST (QUOTE !))) (MT.SENDCOMMAND 1 (LIST (QUOTE !))) (LET ((RESPONSE (MT.SENDCOMMAND 1 (LIST (QUOTE !))))) (|if| RESPONSE |then| (CLRPROMPT) (MT.PRINT.STATUS (CONCAT RESPONSE " ready")) |else| (RINGBELLS) (MT.PRINT.STATUS "Microtek Not Responding ...Check scanner and cables"))))
-)
-
-(MT.PAGEMAP
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:04 by Briggs") (|if| (OPENWP MTDISPLAYWINDOW) |then| (CLOSEW MTDISPLAYWINDOW) |else| (OPENW MTDISPLAYWINDOW)))
-)
-
-(MT.QUIT
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:04 by Briggs") (SETQ RESPONSE (MENU (|create| MENU ITEMS _ (QUOTE ("QUIT" "SHUTDOWN RS232 PORT ONLY")) MENUFONT _ (FONTCREATE (QUOTE MODERN) 10 (QUOTE BOLD))))) (CLOSEF? MT.INSTREAM) (CLOSEF? MT.OUTSTREAM) (RS232C.SHUTDOWN) (|if| (STREQUAL RESPONSE "QUIT") |then| (DELFILE (CLOSEF? (QUOTE {CORE}SCANNER.SCRATCH))) (CLOSEW MTDISPLAYWINDOW) (CLOSEW MT.CONTROL.MENUWINDOW)))
-)
-)
-(* * |Functions| |to| |convert| |and| |print| |scanned| |images|)
-
-(DEFINEQ
-
-(MT.DISPLAY.MENU
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:04 by Briggs") (PROG (MENU.DESCRIPTION) (SETQ MENU.DESCRIPTION (BQUOTE (((PROPS ID DISPLAY1) (GROUP (PROPS FORMAT EXPLICIT COORDINATES GROUP BACKGROUND 23130) (TYPE MOMENTARY LABEL "CREATE BITMAP!" FONT (MODERN 12 BOLD) SELECTEDFN MT.CREATEBM BOX 3 LEFT 1 BOTTOM 35) (TYPE MOMENTARY LABEL "Bitmap Name!: " FONT (MODERN 10 BOLD) SELECTEDFN MT.GET.BITMAPNAME BOX 1 LEFT 1 BOTTOM 18) (TYPE EDIT ID BITMAPNAME LABEL "IMAGE" BOX 1 LEFT 100 BOTTOM 18 MAXWIDTH 170) (TYPE STATE LABEL "Shrinkfactor! " MENUITEMS (10 9 8 7 6 5 4 3 2 1) INITSTATE 1 LINKS (DISPLAY (GROUP BMSHRINKFACTOR)) FONT (MODERN 10 BOLD) BOX 1 LEFT 278 BOTTOM 18) (TYPE DISPLAY LABEL "" ID BMSHRINKFACTOR BOX 1 LEFT 350 BOTTOM 18 MAXWIDTH 16) (TYPE STATE LABEL "Rotation! " MENUITEMS ("NONE" "LEFT" "RIGHT") LINKS (DISPLAY (GROUP ROTATE)) INITSTATE "NONE" FONT (MODERN 10 BOLD) BOX 1 LEFT 382 BOTTOM 18) (TYPE DISPLAY LABEL "" ID ROTATE BOX 1 LEFT 439 BOTTOM 18 MAXWIDTH 37) (TYPE DISPLAY LABEL "Source Filename!: " FONT (MODERN 10 BOLD) SELECTEDFN MT.GET.SOURCEFILENAME BOX 1 LEFT 1 BOTTOM 1) (TYPE EDIT ID SOURCEFILENAME LABEL {DSK}<LISPFILES>IMAGE BOX 1 LEFT 100 BOTTOM 1 MAXWIDTH 379)))))) (SETQ MT.DISPLAY.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Display Menu" 23130 5)) (FM.CHANGESTATE (FM.GETITEM (QUOTE BMSHRINKFACTOR) NIL MT.DISPLAY.MENUWINDOW) MT.BMSHRINKFACTOR MT.DISPLAY.MENUWINDOW) (OPENW MT.DISPLAY.MENUWINDOW)))
-)
-
-(MT.GET.SOURCEFILENAME
-(LAMBDA NIL (* \; "Edited 12-Mar-87 15:41 by rdc") (FM.EDITITEM (FM.GETITEM (QUOTE SOURCEFILENAME) NIL MT.DISPLAY.MENUWINDOW) MT.DISPLAY.MENUWINDOW))
-)
-
-(MT.GET.BITMAPNAME
-(LAMBDA NIL (* \; "Edited 12-Mar-87 15:42 by rdc") (FM.EDITITEM (FM.GETITEM (QUOTE BITMAPNAME) NIL MT.DISPLAY.MENUWINDOW) MT.DISPLAY.MENUWINDOW))
-)
-
-(MT.CREATEBM
-(LAMBDA NIL (* \; "Edited  8-Sep-88 19:04 by Briggs") (MT.BITMAPCREATE (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) (QUOTE BITMAPNAME)) (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) (QUOTE SOURCEFILENAME)) (CADR (MEMBER "Shrinkfactor! " (FM.GETSTATE MT.DISPLAY.MENUWINDOW))) (MKATOM (CADR (MEMBER "Rotation! " (FM.GETSTATE MT.DISPLAY.MENUWINDOW))))))
-)
-
-(MT.BITMAPCREATE
-(LAMBDA (BITMAPNAME INFILENAME BMSHRINKFACTOR ROTATION) (* \; "Edited  8-Sep-88 19:04 by Briggs") (PROG* (SCANFILE COMPRESSION RESOLUTION GREYLEVEL CONTRAST BRIGHTNESS SCANLINES SCANTYPE BYTESPERSCANLINE SCANDENSITY FINISHEDBM) (SETQ FINISHEDBM (MKATOM BITMAPNAME)) (|if| (AND INFILENAME FINISHEDBM) |then| (SETQ SCANFILE (OPENSTREAM INFILENAME (QUOTE INPUT))) (SETQ COMPRESSION (READ SCANFILE)) (SETQ RESOLUTION (READ SCANFILE)) (SETQ GREYLEVEL (READ SCANFILE)) (SETQ CONTRAST (READ SCANFILE)) (SETQ BRIGHTNESS (READ SCANFILE)) (SETQ SCANLINES (READ SCANFILE)) (SETQ BYTESPERSCANLINE (READ SCANFILE)) (* |;;;| "To Pick up trailing CR") (BIN SCANFILE) (|if| (EQ COMPRESSION (QUOTE NO)) |then| (SET FINISHEDBM (MT.CONVERTIMAGETOBM SCANFILE SCANLINES BYTESPERSCANLINE FINISHEDBM BMSHRINKFACTOR ROTATION)) (PUTPROP (MKATOM BITMAPNAME) (QUOTE RESOLUTION) RESOLUTION) |else| (MT.PRINT.STATUS "NOT YET IMPLEMENTED") (CLOSEF? SCANFILE)) |else| (MT.PRINT.STATUS "ERROR IN BITMAP OR SCANFILE NAME") (CLOSEF? SCANFILE)) (RETURN FINISHEDBM)))
-)
-
-(MT.CONVERTIMAGETOBM
-(LAMBDA (BFILE SCANLINES BYTESPERSCANLINE BMAPNAME SCANNERSHRINKFACTOR ROTATION) (* \; "Edited  8-Sep-88 19:04 by Briggs") (* |;;;| "Returns a bitmap that is shrunken (by factor) image of the data.  Creates a temporary bitmap that is exact width but only 200 lines max long.  That is shrunken then blt'ed into the final bitmap") (PROG (OFFSET BITWIDTH LINEOFFSET TEMPBM FINALBMOFFSET FINALBMWNAME FINALBMOFFSETFACTOR FINALBM FINALBMLINES CLINE BMPTR CBYTE SHRINKHEIGHTFACTOR SHRINKWIDTHFACTOR) (SETQ OFFSET 0) (SETQ BITWIDTH (ITIMES BYTESPERSCANLINE 8)) (SETQ LINEOFFSET (|if| (ODDP BYTESPERSCANLINE) |then| (IPLUS BYTESPERSCANLINE 1) |else| BYTESPERSCANLINE)) (SETQ TEMPBM (BITMAPCREATE BITWIDTH 200)) (SETQ FINALBMOFFSET -1) (SETQ FINALBMWNAME (MKATOM (CONCAT BMAPNAME (QUOTE WINDOW)))) (SETQ FINALBMOFFSETFACTOR (QUOTIENT 200 SCANNERSHRINKFACTOR)) (MT.PRINT.STATUS "SETTING UP BITMAP...") (* |;;;| "Set up the bmap parameters") (SETQ SHRINKHEIGHTFACTOR SCANNERSHRINKFACTOR) (SETQ SHRINKWIDTHFACTOR SCANNERSHRINKFACTOR) (* |;;;| "Set number of lines in final bitmap") (SETQ FINALBMLINES (IPLUS (IQUOTIENT SCANLINES SHRINKHEIGHTFACTOR) 1)) (* |;;;| "create the final bitmap FACTOR width and FACTOR high") (SETQ FINALBM (|if| (GEQ (ITIMES BITWIDTH SCANLINES) 2000000) |then| (MT.CREATE.BIG.BM BITWIDTH SCANLINES) |else| (BITMAPCREATE (QUOTIENT (ITIMES BYTESPERSCANLINE 8) SHRINKWIDTHFACTOR) FINALBMLINES))) (* |;;;| "make a window that you can bitblt the image to while you are working...") (* |;;;| "now start doing the serious work") (MT.PRINT.STATUS "WORKING...") (SETQ BMPTR (|fetch| BITMAPBASE |of| TEMPBM)) (|for| Y |from| 0 |to| (SUB1 SCANLINES) |do| (|if| (EQ OFFSET 200) |then| (* \; "We've done 200 lines, so now lets move it and reset the offset pointers!") (MT.PRINT.STATUS "BLT'ING A CHUNK...") (* |;;;| "first reset everything") (SETQ BMPTR (|fetch| BITMAPBASE |of| TEMPBM)) (SETQ OFFSET 0) (* |;;;| "set the new offset into the final bitmap DONT forget we are working top down in BMAP") (SETQ FINALBMOFFSET (IPLUS FINALBMOFFSET FINALBMOFFSETFACTOR)) (* |;;;| "BITBLT the shrunken bitmap (by SHRINKHEIGHTFACTOR) to the final bitmap and then the finalbitmap to the display window") (BITBLT (SHRINKBITMAP TEMPBM SHRINKWIDTHFACTOR SHRINKHEIGHTFACTOR) 0 0 FINALBM 0 (IDIFFERENCE FINALBMLINES FINALBMOFFSET)) (MT.PRINT.STATUS "DONE...WORKING...")) (SETQ CLINE (ITIMES OFFSET LINEOFFSET)) (|for| X |from| 0 |to| (IDIFFERENCE BYTESPERSCANLINE 1) |do| (\\PUTBASEBYTE BMPTR (PLUS X CLINE) (BIN BFILE))) (SETQ OFFSET (ADD1 OFFSET))) (* |;;;| "Now do the final shrink and blt") (MT.PRINT.STATUS " BLT'ING FINAL CHUNK...") (SETQ OFFSET (IPLUS (IMOD OFFSET SHRINKHEIGHTFACTOR) (QUOTIENT OFFSET SHRINKHEIGHTFACTOR))) (SETQ FINALBMOFFSET (IPLUS FINALBMOFFSET OFFSET)) (BITBLT (SHRINKBITMAP TEMPBM SHRINKWIDTHFACTOR SHRINKHEIGHTFACTOR) 0 (IDIFFERENCE FINALBMOFFSETFACTOR OFFSET) FINALBM 0 (IDIFFERENCE FINALBMLINES FINALBMOFFSET)) (MT.CREATE.DISPLAYWINDOW (|if| (EQ ROTATION (QUOTE LEFT)) |then| (MT.PRINT.STATUS "..ROTATING BITMAP...PLEASE WAIT") (SETQ FINALBM (ROTATE.BITMAP.LEFT FINALBM)) |elseif| (EQ ROTATION (QUOTE RIGHT)) |then| (MT.PRINT.STATUS "..ROTATING BITMAP...PLEASE WAIT") (SETQ FINALBM (ROTATE.BITMAP.RIGHT FINALBM)) |else| FINALBM)) (MT.PRINT.STATUS "DONE") (CLOSEF BFILE) (CLRPROMPT) (RETURN FINALBM)))
-)
-
-(MT.CREATE.BIG.BM
-(LAMBDA (WIDTH HEIGHT) (* \; "Edited  8-Sep-88 19:05 by Briggs") (LET* ((RASTERWIDTH (IQUOTIENT (IPLUS WIDTH (IDIFFERENCE 16 (IMOD WIDTH 16))) 16)) (TOTALBYTES (ITIMES HEIGHT (ITIMES RASTERWIDTH 2))) (NPAGES (COND ((ZEROP (IMOD TOTALBYTES 512)) (IQUOTIENT TOTALBYTES 512)) (T (ADD1 (IQUOTIENT TOTALBYTES 512))))) (BMPTR (\\ALLOCPAGEBLOCK NPAGES)) (REALLYBIGBM (|create| BITMAP BITMAPBASE _ BMPTR BITMAPRASTERWIDTH _ RASTERWIDTH BITMAPHEIGHT _ HEIGHT BITMAPWIDTH _ WIDTH BITMAPBITSPERPIXEL _ 1))) (BLTSHADE WHITESHADE REALLYBIGBM) REALLYBIGBM))
-)
-
-(MT.CREATE.DISPLAYWINDOW
-(LAMBDA (BITMAP) (* \; "Edited 13-Mar-87 15:10 by rdc") (PROG (WINDOW) (RINGBELLS) (MT.PRINT.STATUS "SWEEP OUT WINDOW FOR BITMAP") (SETQ WINDOW (CREATEW NIL (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) (QUOTE BITMAPNAME)))) (WINDOWPROP WINDOW (QUOTE SRCBM) BITMAP) (WINDOWPROP WINDOW (QUOTE REPAINTFN) (FUNCTION MT.REPAINTWINDOW)) (WINDOWPROP WINDOW (QUOTE RESHAPEFN) (FUNCTION MT.RESHAPEWINDOW)) (WINDOWPROP WINDOW (QUOTE SCROLLFN) (FUNCTION SCROLLBYREPAINTFN)) (MT.RESHAPEWINDOW WINDOW) (RETURN WINDOW)))
-)
-
-(MT.REPAINTWINDOW
-(LAMBDA (WINDOW REGION) (* \; "Edited  8-Sep-88 19:05 by Briggs") (MOVETO (WINDOWPROP WINDOW (QUOTE BMORIGX)) (WINDOWPROP WINDOW (QUOTE BMORIGY)) WINDOW) (BITBLT (WINDOWPROP WINDOW (QUOTE SRCBM)) 0 0 WINDOW))
-)
-
-(MT.RESHAPEWINDOW
-(LAMBDA (WINDOW) (* \; "Edited  8-Sep-88 19:05 by Briggs") (PROG NIL (DSPRESET WINDOW) (WINDOWPROP WINDOW (QUOTE BMORIGX) (DSPXPOSITION NIL WINDOW)) (WINDOWPROP WINDOW (QUOTE BMORIGY) (DSPYPOSITION NIL WINDOW)) (MT.REPAINTWINDOW WINDOW) (WINDOWPROP WINDOW (QUOTE EXTENT) (CREATEREGION 0 0 (BITMAPWIDTH (WINDOWPROP WINDOW (QUOTE SRCBM))) (BITMAPHEIGHT (WINDOWPROP WINDOW (QUOTE SRCBM)))))))
-)
-)
-
-(ADDTOVAR |BackgroundMenuCommands| ("MicrotekScanner" (MT.INIT) "Open Microtek Scanner Command and Display windows, initilalize RS232 port and verifies Microtek Scanner is ready"))
-
-(RPAQQ |BackgroundMenu| NIL)
-
-(RPAQQ MT.ICON #*(50 50)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOH@@@@@@@@@@H@@@@H@@@@@@@@@@H@@@@H@@@@@@@@@@H@@@@OOOOL@@@@@AH@@@@H@@@L@@@@@BH@@@@H@@AD@@@@@DH@@@@H@@BD@@@@@HH@@@@H@@DD@@@@A@H@@@@H@@HD@@@@B@H@@@@H@A@D@@@@DCH@@@@N@B@D@@@@HCOOOOON@D@D@@@A@@@@@@@@@H@D@@@B@@@@@@@@A@@D@@@GOOOOOOOON@@H@@@D@@@@@@@@B@A@@@@D@@@@@@@@B@B@@@@D@@@@@@@@B@D@@@@DOOOOOOOOB@H@@@@DH@@@@@@ABA@@@@@DH@@@@@@ABB@@@@@DH@@@@@@ABD@@@@@DH@@@@@@ABH@@@@@DH@@@@@@AC@@@@@@GOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@)
-
-(RPAQQ MT.ICON.MASK #*(50 50)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOH@@@@@@@@@@OOOOOH@@@@@@@@@@OOOOOH@@@@@@@@@@OOOOOOOOOL@@@@@AOOOOOOOOOL@@@@@COOOOOOOOOL@@@@@GOOOOOOOOOL@@@@@OOOOOOOOOOL@@@@AOOOOOOOOOOL@@@@COOOOOOOOOOL@@@@GOOOOOOOOOOL@@@@OOOOOOOOOOOL@@@AOOOOOOOOOOOL@@@COOOOOOOOOOOL@@@GOOOOOOOOOOOH@@@GOOOOOOOOOOO@@@@GOOOOOOOOOON@@@@GOOOOOOOOOOL@@@@GOOOOOOOOOOH@@@@GOOOOOOOOOO@@@@@GOOOOOOOOON@@@@@GOOOOOOOOOL@@@@@GOOOOOOOOOH@@@@@GOOOOOOOOO@@@@@@GOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@)
-
-(RPAQQ BRIGHTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@OGH@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO)
-
-(RPAQQ CONTRASTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@OGH@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO)
-
-(RPAQQ INITIALBRIGHTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO)
-
-(RPAQQ INITIALCONTRASTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO)
-
-(RPAQQ LEFTARROW #*(10 10)@H@@AH@@CH@@GOL@OOL@OOL@GOL@CH@@AH@@@H@@)
-
-(RPAQQ MANCURSOR #*(9 9)@H@@AL@@CN@@GO@@OOH@GO@@CN@@AL@@@@@@)
-
-(RPAQQ RIGHTARROW #*(10 10)@D@@@F@@@G@@OOH@OOL@OOL@OOH@@G@@@F@@@D@@)
-
-(RPAQQ MT.POINTER #*(16 16)L@@@O@@@OL@@OO@@OOL@OOO@OOOLOOOOOOOOOOOLOOO@OOL@OO@@OL@@O@@@L@@@)
-
-(RPAQ? MT.BAUDRATE 19200)
-
-(RPAQ? MT.RS232C.FRAME.TIMEOUT 2)
-
-(RPAQ? MT.DISPLAYFRAME (QUOTE YES))
-
-(RPAQ? MT.PAPERLENGTH 4)
-
-(RPAQ? MT.REDUCTION 0)
-
-(RPAQ? MT.CONTRAST 0)
-
-(RPAQ? MT.BRIGHTNESS 0)
-
-(RPAQ? MT.GREYLEVEL 0)
-
-(RPAQ? MT.DATACOMPRESSION (QUOTE NO))
-
-(RPAQ? MT.BACKGROUND (QUOTE HALFTONE))
-
-(RPAQ? MT.WINDOW (QUOTE LINEART))
-
-(RPAQ? MT.FRAME (QUOTE (0 0 40 24)))
-
-(RPAQ? MT.FRAME.BOX (QUOTE (0 460 200 120)))
-
-(RPAQ? MT.TEXTW1 (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.TEXTW2 (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.TEXTW3 (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.TEXTW4 (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.TEXTW1BOX (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.TEXTW2BOX (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.TEXTW3BOX (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.TEXTW4BOX (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.HALFTONEW1 (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.HALFTONEW2 (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.HALFTONEW3 (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.HALFTONEW4 (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.HALFTONEW1BOX (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.HALFTONEW2BOX (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.HALFTONEW3BOX (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.HALFTONEW4BOX (QUOTE (0 0 0 0)))
-
-(RPAQ? MT.OUTSTREAM NIL)
-
-(RPAQ? MT.INSTREAM NIL)
-
-(RPAQ? MT.BMSHRINKFACTOR 1)
-(DECLARE\: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS MT.RS232C.FRAME.TIMEOUT MT.STATUSWINDOW MT.HEIGHTRULER MT.GRID MT.PAPERLENGTH MT.REDUCTION MT.BRIGHTNESS MT.CONTRAST MT.GREYLEVEL MT.DATACOMPRESSION MT.BACKGROUND MT.WINDOW MT.HEIGHTWINDOW MT.FRAME MT.FRAME.BOX MT.TEXTW1 MT.TEXTW2 MT.TEXTW3 MT.TEXTW4 MT.HALFTONEW1 MT.HALFTONEW2 MT.HALFTONEW3 MT.HALFTONEW4 MT.OUTSTREAM MT.INSTREAM BRIGHTBAR CONTRASTBAR LEFTARROW MANCURSOR RIGHTARROW)
-)
-
-(PUTPROPS MICROTEK MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "INTERLISP"))
-(PUTPROPS MICROTEK COPYRIGHT ("XEROX Corporation" 1987 1988))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL (3704 36121 (MT.INIT 3714 . 5283) (MT.SHRINKFN 5285 . 5611) (MICROTEKSCANNER 5613 . 7281
-) (RULERX 7283 . 7517) (RULEX# 7519 . 7756) (RULERY 7758 . 8107) (RULEY# 8109 . 8346) (MT.GETLENGTH 
-8348 . 8889) (MT.CURSOR.IN 8891 . 9003) (MT.CURSOR.OUT 9005 . 9090) (MT.PRINT.STATUS 9092 . 9224) (
-MT.CONTROL.MENU 9226 . 16550) (MT.CHANGE.BRIGHTBAR 16552 . 16999) (MT.RAISEBRIGHTNESS 17001 . 17303) (
-MT.LOWERBRIGHTNESS 17305 . 17620) (MT.CHANGE.CONTRASTBAR 17622 . 18072) (MT.RAISECONTRAST 18074 . 
-18366) (MT.LOWERCONTRAST 18368 . 18673) (MT.SELECT.BACKGROUND 18675 . 23111) (MT.GETTRANSFRAME 23113
- . 25079) (MT.GETWINDOW1 25081 . 27252) (MT.GETWINDOW2 27254 . 29425) (MT.GETWINDOW3 29427 . 31598) (
-MT.GETWINDOW4 31600 . 33771) (MT.UPDATE.HTWINDOWS 33773 . 35312) (MT.DRAWAREABOX 35314 . 36119)) (
-36156 49637 (MT.COMMAND.MENU 36166 . 37143) (MT.GET.OUTFILENAME 37145 . 37317) (MT.SCAN 37319 . 37469)
- (MT.START.SCANNING 37471 . 40210) (MT.SETUPSCANFILE 40212 . 40960) (MT.SEND.SCAN.PARAMETERS 40962 . 
-44005) (MT.SENDCOMMAND 44007 . 45314) (MT.COMPUTECHECKSUM 45316 . 46319) (MT.PRINT.ERROR.MSG 46321 . 
-47555) (MT.SENDACK 47557 . 47678) (MT.SENDNAK 47680 . 47802) (MT.STOP.SCANNING 47804 . 47994) (
-MT.RESET 47996 . 49039) (MT.PAGEMAP 49041 . 49208) (MT.QUIT 49210 . 49635)) (49710 58061 (
-MT.DISPLAY.MENU 49720 . 51177) (MT.GET.SOURCEFILENAME 51179 . 51357) (MT.GET.BITMAPNAME 51359 . 51529)
- (MT.CREATEBM 51531 . 51899) (MT.BITMAPCREATE 51901 . 52955) (MT.CONVERTIMAGETOBM 52957 . 56302) (
-MT.CREATE.BIG.BM 56304 . 56871) (MT.CREATE.DISPLAYWINDOW 56873 . 57410) (MT.REPAINTWINDOW 57412 . 
-57644) (MT.RESHAPEWINDOW 57646 . 58059)))))
-STOP
diff --git a/obsolete/lispusers/MICROTEK.LCOM b/obsolete/lispusers/MICROTEK.LCOM
deleted file mode 100644
index 2fa62f63..00000000
Binary files a/obsolete/lispusers/MICROTEK.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/MICROTEKPRINT b/obsolete/lispusers/MICROTEKPRINT
deleted file mode 100644
index f61bea39..00000000
--- a/obsolete/lispusers/MICROTEKPRINT
+++ /dev/null
@@ -1,187 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "27-Jan-89 10:23:15" {DSK}<LISPFILES>MICROTEK>MICROTEKPRINT.;1 10179  
-
-      changes to%:  (FNS MT.CREATEPRINTMASTER)
-
-      previous date%: "23-Jul-88 15:18:48" {ERINYES}<LISP>MEDLEY>LISPUSERS>MICROTEKPRINT.;1)
-
-
-(* "
-Copyright (c) 1986, 1987, 1988, 1989 by XEROX Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT MICROTEKPRINTCOMS)
-
-(RPAQQ MICROTEKPRINTCOMS
-       [(P (FILESLOAD MICROTEK))
-        (FNS MT.PRINT.MENU MT.GETXPOS MT.GETYPOS MT.CREATEPRINT MT.CREATEPRINTMASTER 
-             MT.SELECT.SCALEFACTOR)
-        (P (IF (AND (BOUNDP 'MT.DISPLAY.MENUWINDOW)
-                    (OPENWP MT.DISPLAY.MENUWINDOW))
-               THEN
-               (MT.PRINT.MENU])
-
-(FILESLOAD MICROTEK)
-(DEFINEQ
-
-(MT.PRINT.MENU
-  [LAMBDA NIL                                     (* ; 
-                                                 "Edited 21-May-87 09:23 by ronald clarke:xsis:xerox")
-
-    (PROG (MENU.DESCRIPTION)
-          [SETQ MENU.DESCRIPTION
-           `(((PROPS ID MPRINT)
-              (GROUP (PROPS FORMAT EXPLICIT COORDINATES GROUP BACKGROUND 23130)
-                     (TYPE MOMENTARY LABEL "PRINT" BOX 3 LEFT 0 BOTTOM 2 FONT (MODERN 12 BOLD)
-                           SELECTEDFN MT.CREATEPRINT)
-                     (TYPE STATE LABEL "Printer!: " ID PRINTERTYPE MENUITEMS (8044 4045)
-                           INITSTATE 8044 LINKS (DISPLAY (GROUP PRINTER))
-                           FONT
-                           (MODERN 10 BOLD)
-                           BOX 1 LEFT 60 BOTTOM 3)
-                     (TYPE DISPLAY ID PRINTER LABEL "" LEFT 115 BOTTOM 3 BOX 1 MAXWIDTH 30)
-                     (TYPE MOMENTARY LABEL "XPOS!: " SELECTEDFN MT.GETXPOS FONT (MODERN 10 BOLD)
-                           LEFT 175 BOTTOM 3 BOX 1)
-                     (TYPE EDIT ID XPOS LABEL 0 MAXWIDTH 45 LEFT 220 BOTTOM 3 BOX 1)
-                     (TYPE MOMENTARY LABEL "YPOS!: " SELECTEDFN MT.GETYPOS FONT (MODERN 10 BOLD)
-                           LEFT 280 BOTTOM 3 BOX 1)
-                     (TYPE EDIT ID YPOS LABEL 0 MAXWIDTH 45 LEFT 325 BOTTOM 3 BOX 1)
-                     (TYPE MOMENTARY LABEL "SCALE!: " FONT (MODERN 10 BOLD)
-                           LEFT 385 BOTTOM 3 BOX 1 SELECTEDFN MT.SELECT.SCALEFACTOR)
-                     (TYPE EDIT LABEL "1:1" ID SCALEFACTOR LEFT 435 BOTTOM 3 BOX 1]
-          (SETQ MT.PRINT.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Print Menu" 23130 5))
-          (OPENW MT.PRINT.MENUWINDOW)
-          (ATTACHWINDOW MT.PRINT.MENUWINDOW MT.DISPLAY.MENUWINDOW 'BOTTOM 'JUSTIFY])
-
-(MT.GETXPOS
-  [LAMBDA NIL                                     (* ; 
-                                                 "Edited 21-May-87 09:15 by ronald clarke:xsis:xerox")
-
-    (FM.EDITITEM (FM.GETITEM 'XPOS NIL MT.PRINT.MENUWINDOW)
-           MT.PRINT.MENUWINDOW])
-
-(MT.GETYPOS
-  [LAMBDA NIL                                     (* ; 
-                                                 "Edited 21-May-87 09:17 by ronald clarke:xsis:xerox")
-
-    (FM.EDITITEM (FM.GETITEM 'YPOS NIL MT.PRINT.MENUWINDOW)
-           MT.PRINT.MENUWINDOW])
-
-(MT.CREATEPRINT
-  [LAMBDA NIL                                     (* ; 
-                                                 "Edited 21-May-87 09:29 by ronald clarke:xsis:xerox")
-
-    (PROG NIL
-          (if (AND [BOUNDP (SETQ BITMAP (MKATOM (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW)
-                                                       'BITMAPNAME]
-                   (BITMAPP (SETQ BITMAP (EVAL BITMAP)))
-                   (if (OR [AND (EQ (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
-                                                   'PRINTERTYPE))
-                                    4045)
-                                (FMEMB (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
-                                                      'SCALEFACTOR))
-                                       '(4%:1 2%:1 1%:1 1%:2 1%:4]
-                           (EQ (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
-                                              'PRINTERTYPE))
-                               8044))
-                       then T
-                     else (FLASHWINDOW MT.STATUSWINDOW 3)
-                          (MT.PRINT.STATUS "Not a valid scale for 4045 printer")
-                          (RETURN NIL)))
-              then (MT.PRINT.STATUS "")
-                   [MT.CREATEPRINTMASTER BITMAP (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
-                                                               'XPOS))
-                          (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
-                                         'YPOS))
-                          (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
-                                         'SCALEFACTOR]
-            else (FLASHWINDOW MT.STATUSWINDOW 3)
-                 (MT.PRINT.STATUS "This atom is not a bitmap")
-                 (RETURN NIL])
-
-(MT.CREATEPRINTMASTER
-  [LAMBDA (BITMAP X Y SCALEFACTOR)                  (* ; "Edited 27-Jan-89 10:21 by rclarke.pa")
-    (PROG (IPS SCANFACTOR SCALE)
-          [if (EQP (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
-                              'PRINTERTYPE)
-                       8044)
-              then (if [NOT (SETQ SCANFACTOR
-                                     (LISTGET '(0 0.24 5 0.252 10 0.266 15 0.282 20 0.3 25 0.32 33 
-                                                  0.36 35 0.369 40 0.4 45 0.439 50 0.48 55 0.533 60 
-                                                  0.6 67 0.7200001 70 0.8 75 0.96)
-                                            (GETPROP (MKATOM (LISTGET (FM.GETSTATE 
-                                                                             MT.DISPLAY.MENUWINDOW)
-                                                                    'BITMAPNAME))
-                                                   'RESOLUTION]
-                           then (MT.PRINT.STATUS "")
-                                 (FLASHWINDOW MT.STATUSWINDOW 3)
-                                 (if [NOT (NUMBERP (SETQ SCANFACTOR
-                                                        (MKATOM (PROMPTFORWORD 
-                                                        "Resolution not on Bitmap proplist. Enter #:"
-                                                                       "1" NIL MT.STATUSWINDOW]
-                                     then (FLASHWINDOW MT.STATUSWINDOW 2)
-                                           (MT.PRINT.STATUS "This is not a number")
-                                           (RETURN NIL))
-                                 (MT.PRINT.STATUS ""))
-                    [SETQ SCALE (FQUOTIENT (CAR (UNPACK SCALEFACTOR))
-                                       (CADDR (UNPACK SCALEFACTOR]
-                    (SETQ IPS (OPENIMAGESTREAM '{LPT}.IP))
-                    (SCALEDBITBLT BITMAP 0 0 IPS X Y 21590 27940 'INPUT 'REPLACE NIL
-                           '(0 0 21590 27940)
-                           (FTIMES SCALE SCANFACTOR))
-            else (if [NOT (SETQ SCANFACTOR
-                                   (LISTGET '(0 1 5 1 10 1 15 1 20 1 25 1 33 1 35 1 40 2 45 2 50 2 55
-                                                2 60 2 67 4 70 4 75 4)
-                                          (GETPROP (MKATOM (LISTGET (FM.GETSTATE 
-                                                                           MT.DISPLAY.MENUWINDOW)
-                                                                  'BITMAPNAME))
-                                                 'RESOLUTION]
-                         then (MT.PRINT.STATUS "")
-                               (FLASHWINDOW MT.STATUSWINDOW 3)
-                               (if [NOT (NUMBERP (SETQ SCANFACTOR
-                                                      (MKATOM (PROMPTFORWORD 
-                                                        "Resolution not on Bitmap proplist. Enter #:"
-                                                                     "1" NIL MT.STATUSWINDOW]
-                                   then (FLASHWINDOW MT.STATUSWINDOW 2)
-                                         (MT.PRINT.STATUS "This is not a number")
-                                         (RETURN NIL))
-                               (MT.PRINT.STATUS ""))
-                  [SETQ SCALE (FQUOTIENT (CAR (UNPACK SCALEFACTOR))
-                                     (CADDR (UNPACK SCALEFACTOR]
-                  (SETQ IPS (OPENIMAGESTREAM '{LPT}.4045XLP))
-                  (if (GREATERP (FTIMES SCALE SCANFACTOR)
-                                 4)
-                      then (FLASHWINDOW MT.STATUSWINDOW 2)
-                            (MT.PRINT.STATUS "Not a valid scale for reduction used on this bitmap")
-                            (RETURN NIL))
-                  (SCALEDBITBLT BITMAP 0 0 IPS X Y 2550 3300 'INPUT 'REPLACE NIL
-                         '(0 0 2550 3300)
-                         (FIXR (FTIMES SCALE SCANFACTOR]
-          (CLOSEF IPS)
-          (MT.PRINT.STATUS "Bitmap sent to printer"])
-
-(MT.SELECT.SCALEFACTOR
-  [LAMBDA NIL                                     (* ; 
-                                                 "Edited 21-May-87 09:26 by ronald clarke:xsis:xerox")
-
-    (PROG [(PRINTERTYPE (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
-                               'PRINTERTYPE]
-          [if (EQP PRINTERTYPE 8044)
-              then (SETQ FACTORS
-                    '(8%:1 7%:1 6%:1 5%:1 4%:1 3%:1 2%:1 1%:1 1%:2 1%:3 1%:4 1%:5 1%:6 1%:7 1%:8))
-            else (SETQ FACTORS '(4%:1 2%:1 1%:1 1%:2 1%:4]
-          (FM.CHANGESTATE (FM.GETITEM 'SCALEFACTOR NIL MT.PRINT.MENUWINDOW)
-                 (MENU (create MENU
-                              ITEMS _ FACTORS))
-                 MT.PRINT.MENUWINDOW])
-)
-
-(IF (AND (BOUNDP 'MT.DISPLAY.MENUWINDOW)
-             (OPENWP MT.DISPLAY.MENUWINDOW))
-    THEN (MT.PRINT.MENU))
-(PUTPROPS MICROTEKPRINT COPYRIGHT ("XEROX Corporation" 1986 1987 1988 1989))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (794 9954 (MT.PRINT.MENU 804 . 2630) (MT.GETXPOS 2632 . 2912) (MT.GETYPOS 2914 . 3194) (
-MT.CREATEPRINT 3196 . 5070) (MT.CREATEPRINTMASTER 5072 . 9197) (MT.SELECT.SCALEFACTOR 9199 . 9952))))
-)
-STOP
diff --git a/obsolete/lispusers/MICROTEKPRINT.LCOM b/obsolete/lispusers/MICROTEKPRINT.LCOM
deleted file mode 100644
index b08965b9..00000000
Binary files a/obsolete/lispusers/MICROTEKPRINT.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/MTP b/obsolete/lispusers/MTP
deleted file mode 100644
index 620f6552..00000000
--- a/obsolete/lispusers/MTP
+++ /dev/null
@@ -1,737 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
-(FILECREATED " 1-Feb-2022 17:06:07" {DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>MTP.;2 31571  
-
-      :CHANGES-TO (VARS MTPCOMS)
-                  (FNS MTP.MAKEANSWERFORM)
-
-      :PREVIOUS-DATE "19-May-86 16:54:58" 
-{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>MTP.;1)
-
-
-(* ; "
-Copyright (c) 1983-1984, 1986 by Xerox Corporation.
-")
-
-(PRETTYCOMPRINT MTPCOMS)
-
-(RPAQQ MTPCOMS
-       ((COMS (* Lafite mode MTP)
-              (FNS MTP.GET.USERDATA MTP.DELIVERMESSAGE MTP.PREPARE.SEND MTP.MAKEANSWERFORM)
-              (ADDVARS (LAFITEMODELST (MTP MTP.PREPARE.SEND MTP.DELIVERMESSAGE MTP.MAKEANSWERFORM 
-                                           MTP.GET.USERDATA)))
-              (FNS \MTP.AUTHENTICATE \MTP.COERCE.MSG \MTP.FILL \MTP.INDENT \MTP.CLRBUF 
-                   \MTP.PRINTADDRESSES)
-              (INITVARS (MTP.SERVER)
-                     (MTP.LINELENGTH 70)
-                     (MTP.RIGHTMARGINWIDTH 10)
-                     (MTP.FILLMSGFLG %'ASK)
-                     (MTP.INSERTANSWERFLG T)
-                     (MTP.INSERTANSWERNSPACES 3)))
-        [COMS (* MTP mail server)
-              (FNS MTP.OPENMAILBOX MTP.POLLNEWMAIL MTP.NEXTMESSAGE MTP.RETRIEVEMESSAGE 
-                   MTP.CLOSEMAILBOX)
-              (FNS \MTP.ENDOFMESSAGESTATE \MTP.POLLNEWMAIL)
-              (ADDVARS (MAILSERVERTYPES (MTP MTP.POLLNEWMAIL MTP.OPENMAILBOX MTP.NEXTMESSAGE 
-                                             MTP.RETRIEVEMESSAGE MTP.CLOSEMAILBOX ETHERPORT]
-        (FILES LAFITE)
-        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MTPMAILBOX MTPPARSE)
-               (CONSTANTS \PUPSOCKET.MTP \PUPSOCKET.MISCSERVICES)
-               (CONSTANTS * PUPTYPES)
-               (GLOBALVARS MTP.SERVER MTP.LINELENGTH MTP.RIGHTMARGINWIDTH MTP.FILLMSGFLG 
-                      MTP.INSERTANSWERFLG MTP.INSERTANSWERNSPACES \LAPARSE.FULL LAFITEEDITORFONT 
-                      UNSUPPLIEDFIELDSTR MESSAGESTR \LAFITEUSERDATA MAILSERVERTYPES 
-                      \LAFITE.AUTHENTICATION.FAILURE)
-               (FILES (LOADCOMP)
-                      LAFITE DPUPFTP))))
-
-
-
-(* Lafite mode MTP)
-
-(DEFINEQ
-
-(MTP.GET.USERDATA
-  [LAMBDA NIL                                                (* drc%: "29-Apr-86 23:31")
-    (LET ((PORT (ETHERPORT MTP.SERVER))
-          USER/PWD)
-         (SETQ \LAFITEUSERDATA
-          (if (NULL PORT)
-              then (PRINTOUT PROMPTWINDOW T "MTP.SERVER not found -- " MTP.SERVER T)
-                   (SETQ \LAFITE.AUTHENTICATION.FAILURE "No Server")
-                   NIL
-            else (SETQ USER/PWD (\INTERNAL/GETPASSWORD MTP.SERVER))
-                 (AND (\MTP.AUTHENTICATE MTP.SERVER USER/PWD)
-                      (create LAFITEUSERDATA
-                             FULLUSERNAME _ (CAR USER/PWD)
-                             ENCRYPTEDPASSWORD _ (CDR USER/PWD)
-                             SHORTUSERNAME _ (CAR USER/PWD)
-                             MAILSERVERS _ (LIST (create MAILSERVER
-                                                        MAILPORT _ PORT
-                                                        MAILSERVERNAME _ MTP.SERVER
-                                                        MAILSERVEROPS _ (CDR (ASSOC %'MTP 
-                                                                                    MAILSERVERTYPES])
-
-(MTP.DELIVERMESSAGE
-  [LAMBDA (MSG PARSE W ABORTW)                               (* drc%: "29-Apr-86 23:38")
-    (DECLARE (GLOBALVARS FTPDEBUGFLG FTPDEBUGLOG))
-    (RESETLST
-        (LET* ((USERDATA (\LAFITE.GET.USER.DATA))
-               (USER (fetch (LAFITEUSERDATA FULLUSERNAME) of USERDATA))
-               (MAILSERVER (CAR (fetch (LAFITEUSERDATA MAILSERVERS) of USERDATA)))
-               [PLIST (LIST (LIST %'MAILBOX (fetch (MTPPARSE MAILBOX) of PARSE))
-                            (LIST %'SENDER (CONCAT USER "@" (fetch MAILSERVERNAME of MAILSERVER]
-               (PW (GETPROMPTWINDOW W))
-               (TEXT (\MTP.COERCE.MSG MSG (fetch (MTPPARSE EOH) of PARSE)
-                            PW))
-               INS OUTS)
-              (AND (WINDOWPROP ABORTW %'ABORT)
-                   (ERROR!))
-              (PRINTOUT PW "delivering...")
-              (SETQ INS (OPENBSPSTREAM (CONS (CAR (fetch (MAILSERVER MAILPORT) of MAILSERVER))
-                                             \PUPSOCKET.MTP)
-                               NIL %'\FTP.ERRORHANDLER))
-              (if INS
-                  then (RESETSAVE NIL (LIST %'CLOSEBSPSTREAM INS 5000))
-                else (PRINTOUT PW (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER)
-                            " not responding. ")
-                     (ERROR!))
-              (SETQ OUTS (BSPOUTPUTSTREAM INS))
-              (FTPPUTMARK OUTS (MARK# STORE-MAIL))
-              (\FTP.PRINTPLIST OUTS PLIST)
-              (FTPPUTMARK OUTS (MARK# EOC))
-              (SELECTC (FTPGETMARK INS)
-                  ((MARK# YES) 
-                       (FTPGETCODE INS)
-                       (\FTP.FLUSH.TO.EOC INS (AND FTPDEBUGFLG FTPDEBUGLOG)))
-                  ((MARK# NO) 
-                       (FTPGETCODE INS)
-                       (\FTP.FLUSH.TO.EOC INS PW)
-                       (ERROR!))
-                  (\FTPERROR INS))
-              (FTPPUTMARK OUTS (MARK# HERE-IS-FILE))
-              (PRINTOUT OUTS (fetch (MTPPARSE FROMLINE) of PARSE)
-                     T)
-              (PRINTOUT OUTS (fetch (MTPPARSE DATELINE) of PARSE)
-                     T)
-              (COPYBYTES TEXT OUTS)
-              (if (WINDOWPROP ABORTW %'ABORT)
-                  then (FTPPUTMARK OUTS (MARK# NO))
-                       (ERROR!)
-                else (FTPPUTMARK OUTS (MARK# YES)))
-              (FTPPUTMARK OUTS (MARK# EOC))
-              (SELECTC (FTPGETMARK INS)
-                  ((MARK# YES) 
-                       (FTPGETCODE INS)
-                       (\FTP.FLUSH.TO.EOC INS (AND FTPDEBUGFLG FTPDEBUGLOG)))
-                  (PROGN (FTPGETCODE INS)
-                         (\FTP.FLUSH.TO.EOC INS PROMPTWINDOW)
-                         (ERROR!)))
-              T))])
-
-(MTP.PREPARE.SEND
-  [LAMBDA (MSG W)                                            (* drc%: "17-May-86 17:34")
-    (LET* [(PARSE (\LAFITE.PREPARE.SEND MSG W))
-           (RECIPIENTS (APPEND (CDR (FASSOC %'To PARSE))
-                              (CDR (FASSOC %'cc PARSE]
-          (OR PARSE (\SENDMESSAGEFAIL W "Bad message format."))
-          (AND (FASSOC %'Sender PARSE)
-               (\SENDMESSAGEFAIL W "Can't specify Sender!"))
-          (AND (FASSOC %''Date PARSE)
-               (\SENDMESSAGEFAIL W "Can't specify Date!"))
-          (OR RECIPIENTS (\SENDMESSAGEFAIL W "No recipients?"))
-          (create MTPPARSE
-                 FROMLINE _ (CONCAT (if (ASSOC %'From PARSE)
-                                        then "Sender: "
-                                      else "From: ")
-                                   (FULLUSERNAME))
-                 MAILBOX _ [CONCATLIST (for TAIL on RECIPIENTS
-                                          collect (if (CDR TAIL)
-                                                      then (CONCAT (CAR TAIL)
-                                                                  ", ")
-                                                    else (CAR TAIL]
-                 EOH _ (CADR (FASSOC %'EOF PARSE))
-                 DATELINE _ (CONCAT "Date: " (DATE (DATEFORMAT DAY.OF.WEEK SPACES TIME.ZONE 
-                                                          NO.SECONDS])
-
-(MTP.MAKEANSWERFORM
-  [LAMBDA (MSGS FOLDER)                                      (* ; "Edited  1-Feb-2022 17:05 by rmk")
-                                                             (* drc%: "19-May-86 15:39")
-    (PROG ((OLD.MSG (OR (CAR (LISTP MSGS))
-                        MSGS))
-           [INSERT? (AND MTP.INSERTANSWERFLG (MENU (\LAFITE.CREATE.MENU %' (("Yes" T 
-                                                      "Insert the text of the message being answered"
-                                                                                   )
-                                                                            ("No" NIL 
-                                                                                 "Normal answer form"
-                                                                                  )
-                                                                            ("Abort" %'ABORT 
-                                                                               "Abort Answer command"
-                                                                                   ))
-                                                          "Insert Message?"]
-           (OLD.TEXT (\LAFITE.OPEN.FOLDER FOLDER %'INPUT))
-           START END OLD.FIELDS SUBJECT FROM TO CC DATE REPLY-TO SENDER NEW.MSG NEW.TO NEW.CC)
-          (if (EQ INSERT? %'ABORT)
-              then (RETURN))
-          (SETQ START (fetch (LAFITEMSG START) of OLD.MSG))
-          (SETQ END (fetch (LAFITEMSG END) of OLD.MSG))
-          (SETQ OLD.FIELDS (LAFITE.PARSE.HEADER OLD.TEXT \LAPARSE.FULL START END))
-          (for PAIR in OLD.FIELDS do (SELECTQ (CAR PAIR)
-                                         (Subject (SETQ SUBJECT (CADR PAIR)))
-                                         (From (SETQ FROM (CDR PAIR)))
-                                         (To (SETQ TO (CDR PAIR)))
-                                         (cc (SETQ CC (CDR PAIR)))
-                                         (Date (SETQ DATE (CADR PAIR)))
-                                         (Reply-to (SETQ REPLY-TO (CDR PAIR)))
-                                         (Sender (SETQ SENDER (CDR PAIR)))
-                                         NIL))
-          (SETQ NEW.TO (OR REPLY-TO FROM SENDER))
-          (OR NEW.TO (RETURN (LAB.PROMPTPRINT FOLDER "Can't reply -- no From or Sender")))
-          (SETQ NEW.MSG (OPENTEXTSTREAM NIL NIL NIL NIL (LIST %'FONT LAFITEEDITORFONT)))
-          (LINELENGTH MAX.SMALLP NEW.MSG)
-          (PRINTOUT NEW.MSG "Subject: ")
-          (if (NOT (STRING-EQUAL (SUBSTRING SUBJECT 1 3)
-                          "Re:"))
-              then (printout NEW.MSG "Re: "))
-          (PRINTOUT NEW.MSG (OR SUBJECT UNSUPPLIEDFIELDSTR)
-                 T)
-          (AND FROM (PRINTOUT NEW.MSG "In-reply-to: " (CAR FROM)
-                           "'s message of " DATE T))
-          (PRINTOUT NEW.MSG "To: ")
-          (\MTP.PRINTADDRESSES NEW.TO NEW.MSG)
-          (SETQ NEW.CC (LA.SETDIFFERENCE (if REPLY-TO
-                                             then (LIST (FULLUSERNAME))
-                                           else (LA.REMOVEDUPLICATES (APPEND TO CC)))
-                              NEW.TO))
-          (if NEW.CC
-              then (PRINTOUT NEW.MSG "cc: ")
-                   (\MTP.PRINTADDRESSES NEW.CC NEW.MSG))
-          (TERPRI NEW.MSG)
-          (if INSERT?
-              then (\MTP.FILL OLD.TEXT NEW.MSG MTP.INSERTANSWERNSPACES MTP.LINELENGTH START END)
-                   (PRINTOUT NEW.MSG MESSAGESTR T)
-            else (LET [(SELECTPOSITION (ADD1 (GETFILEPTR NEW.MSG]
-                      (PRINTOUT NEW.MSG MESSAGESTR T)
-                      (TEDIT.SETSEL NEW.MSG SELECTPOSITION (NCHARS MESSAGESTR)
-                             %'RIGHT T)))
-          (RETURN NEW.MSG])
-)
-
-(ADDTOVAR LAFITEMODELST (MTP MTP.PREPARE.SEND MTP.DELIVERMESSAGE MTP.MAKEANSWERFORM MTP.GET.USERDATA))
-(DEFINEQ
-
-(\MTP.AUTHENTICATE
-  [LAMBDA (HOST USER/PWD)                                    (* drc%: "25-Apr-86 13:06")
-
-         (* I couldn't get PUP authentication to work w/ our Misc server, so we just check 
-         for mailbox existence. Password checking is done when retrieving mail.)
-
-    (LET* ((RESPONSE (\MTP.POLLNEWMAIL HOST (CAR USER/PWD)))
-           (TYPE (CAR RESPONSE))
-           (MESSAGE (CDR RESPONSE)))
-          (SELECTC TYPE
-              ((LIST \PT.NEWMAIL \PT.NONEWMAIL) 
-                   T)
-              ((LIST \PT.NOMAILBOX \PT.ERROR) 
-                   (SETQ \LAFITE.AUTHENTICATION.FAILURE MESSAGE)
-                   NIL)
-              (NIL (PRINTOUT PROMPTWINDOW T HOST " not responding to authentication request." T)
-                   (SETQ \LAFITE.AUTHENTICATION.FAILURE "No Server")
-                   NIL)
-              NIL])
-
-(\MTP.COERCE.MSG
-  [LAMBDA (MSG EOH ECHOSTREAM)                               (* drc%: "19-May-86 16:08")
-    (DECLARE (GLOBALVARS MTP.LINELENGTH))
-    (LET [(STREAM (COERCETEXTOBJ MSG %'STREAM))
-          (FILL? (SELECTQ MTP.FILLMSGFLG
-                     (ALWAYS T)
-                     (ASK (MENU (\LAFITE.CREATE.MENU %' (("Yes" T 
-                                                      "Break long lines in message to MTP.LINELENGTH"
-                                                                )
-                                                         ("No" NIL "Deliver message as is")
-                                                         ("Abort" %'ABORT "Abort deliver command"))
-                                       "Fill Text?")))
-                     (NEVER NIL)
-                     (SHOULDNT]
-         (if (EQ FILL? %'ABORT)
-             then (ERROR!))
-         (if FILL?
-             then (PRINTOUT ECHOSTREAM "filling...")
-                  (LET ((OUTS (OPENSTREAM %'{NODIRCORE} %'BOTH)))
-                       (COPYBYTES STREAM OUTS 0 EOH)
-                       (\MTP.FILL STREAM OUTS 0 MTP.LINELENGTH)
-                       (SETFILEPTR OUTS 0)
-                       OUTS)
-           else STREAM])
-
-(\MTP.FILL
-  [LAMBDA (INS OUTS LMARGIN RMARGIN START END)               (* drc%: "19-May-86 16:46")
-
-         (* * Copy bytes from INS to OUTS, indenting to LMARGIN.
-         New lines started at last space before RMARGIN --
-         unless the line ends before RMARGIN + MTP.RIGHTMARGINWIDTH anyway.
-         Copy from START (default is current pos) to END
-         (default is EOF)%.)
-
-    (until (GEQ (GETFILEPTR INS)
-                END) as COLUMN from (ADD1 LMARGIN) bind (LINEBUF _ (OPENSTREAM %'{NODIRCORE} %'BOTH))
-                                                        (CARRY _ LMARGIN)
-                                                        (END _ (OR END (GETEOFPTR INS)))
-                                                        (LIMIT _ (IPLUS RMARGIN MTP.RIGHTMARGINWIDTH)
-                                                               )
-                                                        (EDGE _ (ADD1 RMARGIN))
-                                                        BYTE SPACE SPACES
-       first (AND START (SETFILEPTR INS START))
-             (\MTP.INDENT INS OUTS END LMARGIN) eachtime (SETQ BYTE (BIN INS))
-                                                      (SELCHARQ BYTE
-                                                           ((SPACE TAB) 
-                                                                (BOUT LINEBUF BYTE)
-                                                                (push SPACES COLUMN))
-                                                           (EOL (SETFILEPTR LINEBUF 0)
-                                                                (\MTP.CLRBUF LINEBUF OUTS)
-                                                                (BOUT OUTS (CHARCODE EOL))
-                                                                (\MTP.INDENT INS OUTS END LMARGIN)
-                                                                (SETQ CARRY (SETQ COLUMN LMARGIN)))
-                                                           (BOUT LINEBUF BYTE))
-       when (IGREATERP COLUMN LIMIT) do [if (SETQ SPACE (for SPACE in SPACES
-                                                           thereis (LEQ SPACE EDGE)))
-                                            then             (* dump line up to space)
-                                                 (COPYBYTES LINEBUF OUTS 0 (SUB1 (IDIFFERENCE SPACE 
-                                                                                        CARRY)))
-                                                 (BIN LINEBUF) 
-                                                             (* eat up space)
-                                                 (SETQ COLUMN (IPLUS LMARGIN (IDIFFERENCE COLUMN 
-                                                                                    SPACE)))
-                                          else               (* punt)
-                                               (COPYBYTES LINEBUF OUTS 0 (IDIFFERENCE RMARGIN CARRY))
-                                               (SETQ COLUMN (ADD1 (IPLUS LMARGIN MTP.RIGHTMARGINWIDTH
-                                                                         ]
-                                        (BOUT OUTS (CHARCODE EOL))
-                                        (\MTP.INDENT INS OUTS END LMARGIN)
-                                        (\MTP.CLRBUF LINEBUF OUTS)
-                                        (SETQ SPACES)
-                                        (SETQ CARRY COLUMN) finally (SETFILEPTR LINEBUF 0)
-                                                                  (COPYBYTES LINEBUF OUTS])
-
-(\MTP.INDENT
-  [LAMBDA (INS OUTS END LMARGIN)                             (* drc%: "18-May-86 18:31")
-
-         (* * indent OUTS to LMARGIN, unless at end of INS or on an empty line)
-
-    (if (AND (ILESSP (GETFILEPTR INS)
-                    END)
-             (NEQ (PEEKCCODE INS)
-                  (CHARCODE EOL)))
-        then (to LMARGIN do (BOUT OUTS (CHARCODE SPACE])
-
-(\MTP.CLRBUF
-  [LAMBDA (INS OUTS)                                         (* drc%: "30-Apr-86 00:14")
-
-         (* * Flush INS to OUTS, and then clear INS)
-
-    (COPYBYTES INS OUTS)
-    (\SETEOFPTR INS 0)
-    (SETFILEPTR INS 0])
-
-(\MTP.PRINTADDRESSES
-  [LAMBDA (ADDRESSLIST STREAM)                               (* bvm%: "20-Dec-83 18:20")
-    (for ADDR in ADDRESSLIST bind NTHTIME when ADDR do (COND
-                                                          (NTHTIME (PRIN1 ", " STREAM))
-                                                          (T (SETQ NTHTIME T)))
-                                                       (PRIN1 ADDR STREAM))
-    (TERPRI STREAM])
-)
-
-(RPAQ? MTP.SERVER )
-
-(RPAQ? MTP.LINELENGTH 70)
-
-(RPAQ? MTP.RIGHTMARGINWIDTH 10)
-
-(RPAQ? MTP.FILLMSGFLG %'ASK)
-
-(RPAQ? MTP.INSERTANSWERFLG T)
-
-(RPAQ? MTP.INSERTANSWERNSPACES 3)
-
-
-
-(* MTP mail server)
-
-(DEFINEQ
-
-(MTP.OPENMAILBOX
-  [LAMBDA (PORT USER PWD MAILSERVER)                         (* drc%: "20-Apr-86 17:49")
-    (PROG ((MTP.PORT (CONS (CAR PORT)
-                           \PUPSOCKET.MTP))
-           (HOST (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER))
-           (LOGINFO (CONS USER PWD))
-           INS OUTS)
-          (SELECTQ (MTP.POLLNEWMAIL PORT USER)
-              (NIL (RETURN %'EMPTY))
-              (? (RETURN))
-              NIL)
-      NEWCONNECTION
-          (OR (SETQ INS (OPENBSPSTREAM MTP.PORT NIL (FUNCTION \FTP.ERRORHANDLER)))
-              (RETURN))
-          (SETQ OUTS (BSPOUTPUTSTREAM INS))
-      RETRY
-          (FTPPUTMARK OUTS (MARK# RETRIEVE-MAIL))
-          [\FTP.PRINTPLIST OUTS (LIST (LIST %'USER-NAME (CAR LOGINFO))
-                                      (LIST %'USER-PASSWORD (CDR LOGINFO]
-          (.EOC. OUTS)
-          (SELECTC (FTPGETMARK INS)
-              ((MARK# NO) 
-                   (SELECTQ (FTPGETCODE INS)
-                       ((16 17)                              (* bad user/pwd)
-                            (PRINTOUT PROMPTWINDOW T HOST " : ")
-                            (\FTP.FLUSH.TO.EOC INS PROMPTWINDOW)
-                            (TERPRI PROMPTWINDOW)
-                            (SETQ LOGINFO (\INTERNAL/GETPASSWORD HOST T NIL NIL NIL %'UNIX))
-                            (MTP.GET.USERDATA)
-                            (if (BSPOPENP INS %'INPUT)
-                                then (GO RETRY)
-                              else (GO NEWCONNECTION)))
-                       (RETURN (\FTPERROR INS "MTP error"))))
-              ((MARK# HERE-IS-PLIST) 
-                   (RETURN (CONS (create MTPMAILBOX
-                                        MTPIN _ INS
-                                        MTPOUT _ OUTS
-                                        MTPSTATE _ %'OPEN))))
-              (RETURN (\FTPERROR NIL "MTP error"])
-
-(MTP.POLLNEWMAIL
-  [LAMBDA (HOSTPORT USER)                                    (* drc%: "25-Apr-86 12:44")
-    (LET* ((RESPONSE (\MTP.POLLNEWMAIL HOSTPORT USER))
-           (TYPE (CAR RESPONSE))
-           (MESSAGE (CDR RESPONSE)))
-          (SELECTC TYPE
-              (\PT.NEWMAIL T)
-              (\PT.NONEWMAIL NIL)
-              ((LIST \PT.NOMAILBOX \PT.ERROR) 
-                   (printout PROMPTWINDOW T HOSTPORT " : " MESSAGE T)
-                   %'?)
-              (NIL %'?)
-              NIL])
-
-(MTP.NEXTMESSAGE
-  [LAMBDA (MAILBOX)                                          (* bvm%: " 6-JUL-83 14:27")
-    (SELECTQ (fetch MTPSTATE of MAILBOX)
-        (EMPTY NIL)
-        (OPEN [PROG ((PLIST (READPLIST (fetch MTPIN of MAILBOX)))
-                     (NEXTSTATE 'MESSAGE))
-                    (RETURN (PROG1 (OR (for PAIR in PLIST
-                                          do (SELECTQ (CAR PAIR)
-                                                 (LENGTH (push $$VAL 'LENGTH (CADR PAIR)))
-                                                 (OPENED (SELECTQ (CADR PAIR)
-                                                             ((YES Yes yes) 
-                                                                  (push $$VAL 'EXAMINED T))
-                                                             NIL))
-                                                 (DELETED (SELECTQ (CADR PAIR)
-                                                              ((YES Yes yes) 
-                                                                   (push $$VAL 'DELETEDFLG T)
-                                                                   (FTPGETMARK (fetch MTPIN
-                                                                                  of MAILBOX))
-                                                                   (\FTP.FLUSH.TO.MARK (fetch MTPIN
-                                                                                          of MAILBOX)
-                                                                          )
-                                                                   (SETQ NEXTSTATE
-                                                                    (\MTP.ENDOFMESSAGESTATE
-                                                                     (fetch MTPIN of MAILBOX))))
-                                                              NIL))
-                                                 NIL))
-                                       T)
-                                   (replace MTPSTATE of MAILBOX with NEXTSTATE])
-        (ERROR "Mailbox not in good state for NEXTMESSAGE" MAILBOX])
-
-(MTP.RETRIEVEMESSAGE
-  [LAMBDA (MAILBOX OUTSTREAM)                                (* bvm%: " 6-JUL-83 14:27")
-    (SELECTQ (fetch MTPSTATE of MAILBOX)
-        (MESSAGE [COND
-                    ((EQ (FTPGETMARK (fetch MTPIN of MAILBOX))
-                         (MARK# HERE-IS-FILE))
-                     (\FTP.FLUSH.TO.MARK (fetch MTPIN of MAILBOX)
-                            OUTSTREAM)
-                     (replace MTPSTATE of MAILBOX with (\MTP.ENDOFMESSAGESTATE (fetch MTPIN
-                                                                                  of MAILBOX])
-        (\FTPERROR])
-
-(MTP.CLOSEMAILBOX
-  [LAMBDA (MAILBOX FLUSHP)                                   (* bvm%: " 9-May-84 15:35")
-    (COND
-       ((BSPOPENP (fetch MTPIN of MAILBOX))
-        (PROG1 [COND
-                  ((AND FLUSHP (EQ (fetch MTPSTATE of MAILBOX)
-                                   'EMPTY))
-                   (FTPPUTMARK (fetch MTPOUT of MAILBOX)
-                          (MARK# FLUSH-MAILBOX))
-                   (.EOC. (fetch MTPOUT of MAILBOX))
-                   (SELECTC (FTPGETMARK (fetch MTPIN of MAILBOX))
-                       ((MARK# YES) 
-                            (FTPGETCODE (fetch MTPIN of MAILBOX))
-                            (\FTP.FLUSH.TO.EOC (fetch MTPIN of MAILBOX)
-                                   (.FTPDEBUGLOG.))
-                            T)
-                       ((MARK# NO) 
-                            (FTPGETCODE (fetch MTPIN of MAILBOX))
-                            (\FTP.FLUSH.TO.EOC (fetch MTPIN of MAILBOX)
-                                   PROMPTWINDOW)
-                            '?)
-                       (PROGN (\FTPERROR)
-                              '?]
-            (CLOSEBSPSTREAM (fetch MTPIN of MAILBOX)
-                   5000))])
-)
-(DEFINEQ
-
-(\MTP.ENDOFMESSAGESTATE
-  [LAMBDA (INSTREAM)                                         (* bvm%: " 5-SEP-83 18:08")
-    (SELECTC (FTPGETMARK INSTREAM)
-        ((MARK# HERE-IS-PLIST) 
-             'OPEN)
-        ((MARK# YES) 
-             (FTPGETCODE INSTREAM)
-             (\FTP.FLUSH.TO.EOC INSTREAM (.FTPDEBUGLOG.))
-             'EMPTY)
-        ((MARK# NO) 
-             (FTPGETCODE INSTREAM)
-             (\FTP.FLUSH.TO.EOC INSTREAM PROMPTWINDOW)
-             'ERROR)
-        (\FTPERROR])
-
-(\MTP.POLLNEWMAIL
-  [LAMBDA (HOSTPORT USER)                                    (* drc%: "25-Apr-86 12:28")
-
-         (* * Does a Laurel-style mail check for USER on machine HOSTPORT, returning NIL
-         (timeout) or a cons of the PUP type of the response and the contents of the 
-         response)
-
-    (LET ((SOC (\GETMISCSOCKET))
-          (OUTPUP (ALLOCATE.PUP))
-          INPUP RESPONSE)
-         (SETUPPUP OUTPUP HOSTPORT \PUPSOCKET.MISCSERVICES \PT.LAURELCHECK NIL SOC T)
-         (PUTPUPSTRING OUTPUP USER)
-         [SETQ RESPONSE (to \MAXETHERTRIES when (SETQ INPUP (EXCHANGEPUPS SOC OUTPUP NIL T))
-                           do (RETURN (CONS (fetch PUPTYPE of INPUP)
-                                            (GETPUPSTRING INPUP)))
-                           finally (AND PUPTRACEFLG (printout PUPTRACEFILE "Mail check timed out" T]
-         (AND INPUP (RELEASE.PUP INPUP))
-         (RELEASE.PUP OUTPUP)
-         RESPONSE])
-)
-
-(ADDTOVAR MAILSERVERTYPES (MTP MTP.POLLNEWMAIL MTP.OPENMAILBOX MTP.NEXTMESSAGE MTP.RETRIEVEMESSAGE 
-                               MTP.CLOSEMAILBOX ETHERPORT))
-
-(FILESLOAD LAFITE)
-(DECLARE%: EVAL@COMPILE DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(RECORD MTPMAILBOX (MTPIN MTPOUT MTPSTATE))
-
-(RECORD MTPPARSE (FROMLINE MAILBOX EOH DATELINE))
-)
-
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \PUPSOCKET.MTP 7)
-
-(RPAQQ \PUPSOCKET.MISCSERVICES 4)
-
-
-(CONSTANTS \PUPSOCKET.MTP \PUPSOCKET.MISCSERVICES)
-)
-
-
-(RPAQQ PUPTYPES
-       ((\PT.ECHOME 1)
-        (\PT.IAMECHO 2)
-        (\PT.IAMBADECHO 3)
-        (\PT.ERROR 4)
-        (\PT.RFC 8)
-        (\PT.ABORT 9)
-        (\PT.END 10)
-        (\PT.ENDREPLY 11)
-        (\PT.DATA 16)
-        (\PT.ADATA 17)
-        (\PT.ACK 18)
-        (\PT.MARK 19)
-        (\PT.INTERRUPT 20)
-        (\PT.INTERRUPTREPLY 21)
-        (\PT.AMARK 22)
-        (\PT.GATEWAYREQUEST 128)
-        (\PT.GATEWAYRESPONSE 129)
-        (\PT.ALTOTIMEREQUEST 134)
-        (\PT.ALTOTIMERESPONSE 135)
-        (\PT.MSGCHECK 136)
-        (\PT.NEWMAIL 137)
-        (\PT.NONEWMAIL 138)
-        (\PT.NOMAILBOX 139)
-        (\PT.LAURELCHECK 140)
-        (\PT.NAMELOOKUP 144)
-        (\PT.NAMERESPONSE 145)
-        (\PT.NAME/ADDRERROR 146)
-        (\PT.ADDRLOOKUP 147)
-        (\PT.ADDRRESPONSE 148)
-        (\PT.PRINTERSTATUS 128)
-        (\PT.STATUSRESPONSE 129)
-        (\PT.PRINTERCAPABILITY 130)
-        (\PT.CAPABILITYRESPONSE 131)
-        (\PT.PRINTJOBSTATUS 132)
-        (\PT.PRINTJOBRESPONSE 133)
-        (\PT.WHEREUSERREQUEST 152)
-        (\PT.WHEREUSERRESPONSE 153)
-        (\PT.WHEREUSERERROR 154)
-        (\PT.AUTHREQ 168)
-        (\PT.AUTHPOSRESP 169)
-        (\PT.AUTHNEGRESP 170)))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \PT.ECHOME 1)
-
-(RPAQQ \PT.IAMECHO 2)
-
-(RPAQQ \PT.IAMBADECHO 3)
-
-(RPAQQ \PT.ERROR 4)
-
-(RPAQQ \PT.RFC 8)
-
-(RPAQQ \PT.ABORT 9)
-
-(RPAQQ \PT.END 10)
-
-(RPAQQ \PT.ENDREPLY 11)
-
-(RPAQQ \PT.DATA 16)
-
-(RPAQQ \PT.ADATA 17)
-
-(RPAQQ \PT.ACK 18)
-
-(RPAQQ \PT.MARK 19)
-
-(RPAQQ \PT.INTERRUPT 20)
-
-(RPAQQ \PT.INTERRUPTREPLY 21)
-
-(RPAQQ \PT.AMARK 22)
-
-(RPAQQ \PT.GATEWAYREQUEST 128)
-
-(RPAQQ \PT.GATEWAYRESPONSE 129)
-
-(RPAQQ \PT.ALTOTIMEREQUEST 134)
-
-(RPAQQ \PT.ALTOTIMERESPONSE 135)
-
-(RPAQQ \PT.MSGCHECK 136)
-
-(RPAQQ \PT.NEWMAIL 137)
-
-(RPAQQ \PT.NONEWMAIL 138)
-
-(RPAQQ \PT.NOMAILBOX 139)
-
-(RPAQQ \PT.LAURELCHECK 140)
-
-(RPAQQ \PT.NAMELOOKUP 144)
-
-(RPAQQ \PT.NAMERESPONSE 145)
-
-(RPAQQ \PT.NAME/ADDRERROR 146)
-
-(RPAQQ \PT.ADDRLOOKUP 147)
-
-(RPAQQ \PT.ADDRRESPONSE 148)
-
-(RPAQQ \PT.PRINTERSTATUS 128)
-
-(RPAQQ \PT.STATUSRESPONSE 129)
-
-(RPAQQ \PT.PRINTERCAPABILITY 130)
-
-(RPAQQ \PT.CAPABILITYRESPONSE 131)
-
-(RPAQQ \PT.PRINTJOBSTATUS 132)
-
-(RPAQQ \PT.PRINTJOBRESPONSE 133)
-
-(RPAQQ \PT.WHEREUSERREQUEST 152)
-
-(RPAQQ \PT.WHEREUSERRESPONSE 153)
-
-(RPAQQ \PT.WHEREUSERERROR 154)
-
-(RPAQQ \PT.AUTHREQ 168)
-
-(RPAQQ \PT.AUTHPOSRESP 169)
-
-(RPAQQ \PT.AUTHNEGRESP 170)
-
-
-(CONSTANTS (\PT.ECHOME 1)
-       (\PT.IAMECHO 2)
-       (\PT.IAMBADECHO 3)
-       (\PT.ERROR 4)
-       (\PT.RFC 8)
-       (\PT.ABORT 9)
-       (\PT.END 10)
-       (\PT.ENDREPLY 11)
-       (\PT.DATA 16)
-       (\PT.ADATA 17)
-       (\PT.ACK 18)
-       (\PT.MARK 19)
-       (\PT.INTERRUPT 20)
-       (\PT.INTERRUPTREPLY 21)
-       (\PT.AMARK 22)
-       (\PT.GATEWAYREQUEST 128)
-       (\PT.GATEWAYRESPONSE 129)
-       (\PT.ALTOTIMEREQUEST 134)
-       (\PT.ALTOTIMERESPONSE 135)
-       (\PT.MSGCHECK 136)
-       (\PT.NEWMAIL 137)
-       (\PT.NONEWMAIL 138)
-       (\PT.NOMAILBOX 139)
-       (\PT.LAURELCHECK 140)
-       (\PT.NAMELOOKUP 144)
-       (\PT.NAMERESPONSE 145)
-       (\PT.NAME/ADDRERROR 146)
-       (\PT.ADDRLOOKUP 147)
-       (\PT.ADDRRESPONSE 148)
-       (\PT.PRINTERSTATUS 128)
-       (\PT.STATUSRESPONSE 129)
-       (\PT.PRINTERCAPABILITY 130)
-       (\PT.CAPABILITYRESPONSE 131)
-       (\PT.PRINTJOBSTATUS 132)
-       (\PT.PRINTJOBRESPONSE 133)
-       (\PT.WHEREUSERREQUEST 152)
-       (\PT.WHEREUSERRESPONSE 153)
-       (\PT.WHEREUSERERROR 154)
-       (\PT.AUTHREQ 168)
-       (\PT.AUTHPOSRESP 169)
-       (\PT.AUTHNEGRESP 170))
-)
-
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS MTP.SERVER MTP.LINELENGTH MTP.RIGHTMARGINWIDTH MTP.FILLMSGFLG MTP.INSERTANSWERFLG 
-       MTP.INSERTANSWERNSPACES \LAPARSE.FULL LAFITEEDITORFONT UNSUPPLIEDFIELDSTR MESSAGESTR 
-       \LAFITEUSERDATA MAILSERVERTYPES \LAFITE.AUTHENTICATION.FAILURE)
-)
-
-
-(FILESLOAD (LOADCOMP)
-       LAFITE DPUPFTP)
-)
-(PUTPROPS MTP COPYRIGHT ("Xerox Corporation" 1983 1984 1986))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (2193 11600 (MTP.GET.USERDATA 2203 . 3410) (MTP.DELIVERMESSAGE 3412 . 6253) (
-MTP.PREPARE.SEND 6255 . 7703) (MTP.MAKEANSWERFORM 7705 . 11598)) (11709 18664 (\MTP.AUTHENTICATE 11719
- . 12593) (\MTP.COERCE.MSG 12595 . 13858) (\MTP.FILL 13860 . 17553) (\MTP.INDENT 17555 . 17955) (
-\MTP.CLRBUF 17957 . 18197) (\MTP.PRINTADDRESSES 18199 . 18662)) (18894 25470 (MTP.OPENMAILBOX 18904 . 
-20828) (MTP.POLLNEWMAIL 20830 . 21345) (MTP.NEXTMESSAGE 21347 . 23541) (MTP.RETRIEVEMESSAGE 23543 . 
-24195) (MTP.CLOSEMAILBOX 24197 . 25468)) (25471 26963 (\MTP.ENDOFMESSAGESTATE 25481 . 25977) (
-\MTP.POLLNEWMAIL 25979 . 26961)))))
-STOP
diff --git a/obsolete/lispusers/NGROUP b/obsolete/lispusers/NGROUP
deleted file mode 100644
index 6430c691..00000000
--- a/obsolete/lispusers/NGROUP
+++ /dev/null
@@ -1,1102 +0,0 @@
-(FILECREATED "18-Feb-87 15:45:59" {SUMEX-AIM}PS:<TMAX.SOURCES>NGROUP.;3 43703  
-
-      changes to:  (FNS NGROUP.BUTTONEVENTINFN)
-
-      previous date: "17-Feb-87 14:25:08" {SUMEX-AIM}PS:<GILMURRAY.LISP>NGROUP.;3)
-
-
-(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.)
-
-(PRETTYCOMPRINT NGROUPCOMS)
-
-(RPAQQ NGROUPCOMS ((* Developed under support from NIH grant RR-00785.)
-	(* Written by Frank Gilmurray and Sami Shaio.)
-	(* * NUMBER ImageObject functions)
-	(FNS NUMBEROBJ NUMBEROBJP NGROUP.NUMBEROBJP NUMBER.DISPLAYFN NUMBER.IMAGEBOXFN NUMBER.PUTFN 
-	     NUMBER.GETFN NUMBER.BUTTONEVENTINFN)
-	(FNS NGROUP.BUTTONEVENTINFN NGROUP.WHENSELECTEDFN)
-	(* * Number Group GRAPH functions)
-	(FNS GRAPHMENU TSP.NGROUP.GRAPHP INITIAL.NGROUP.GRAPH TSPGRAPHREGION 
-	     ADD.NGROUP.TO.MOTHER.NODE ADD.NODE.TO.GRAPH COLLECT.HASHARRAY CREATE.NGROUP.NODE 
-	     GET.FROMNODES GET.MOTHER.GROUP MAKE.MOTHER.NODE MAKE.NGROUP.NODELST GET.TONODES 
-	     FIND.NODE)
-	(* * Other unsorted functions)
-	(FNS INSERT.NGROUP VERIFY.NGROUP.ORDER ADD.NUMBER.GROUP ADD.NGROUP.TO.DBASE COLLECT.NGROUPS 
-	     LIST.FONT.PROPS MAP.NGROUP.LOOKS NGROUP.GETFONT CHANGE.NGROUP CHANGE.NGROUP.FONT 
-	     CHANGE.NGROUP.FORMAT CHANGE.NGROUP.CHARTYPE CHANGE.NGROUP.DELIMIT CHANGE.NGROUP.START 
-	     CHANGE.NGROUP.ADDTOTOC TSP.GET.NGROUP.ARRAY TSP.LEGALID)
-	(* * Number counting functions)
-	(FNS UPDATE.NUMBEROBJS RESET.DEPENDENT.CLASSES RESET.NCOUNTER GET.NCOUNTER NCOUNTER? 
-	     LIST.ANCESTORS FLATTEN.TREE.TO.STRING NGROUP.CHARTYPE NUMBER.TO.LETTER 
-	     REMOVE.ALL.COUNTERS)
-	(* * Table-of-Contents functions)
-	(FNS TOC.ENABLED? GET.TOC.TEXTSTRING CREATE.TOC.FILE VIEW.TOC.FILE GET.TOC.FILE 
-	     WRITE.TOC.FILE)
-	(RECORDS NGCOUNTER NGTEMPLATE NUMBEROBJ)))
-
-
-
-(* Developed under support from NIH grant RR-00785.)
-
-
-
-
-(* Written by Frank Gilmurray and Sami Shaio.)
-
-(* * NUMBER ImageObject functions)
-
-(DEFINEQ
-
-(NUMBEROBJ
-  (LAMBDA (USE TEMPLATE NUMSTRING LINK.TO REF.TYPE FONT)     (* fsg " 4-Feb-87 13:26")
-    (LET ((NEWOBJ (IMAGEOBJCREATE (create NUMBEROBJ
-					      REF.TYPE _ REF.TYPE
-					      NUMSTRING _(OR NUMSTRING "^n")
-					      USE _ USE
-					      TEMPLATE _ TEMPLATE
-					      LINK.TO _ LINK.TO
-					      NUMBER.TEXT _ NIL
-					      PAGE.NUMBER _ NIL
-					      FONT _ FONT)
-				    (IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN)
-						      (FUNCTION NUMBER.IMAGEBOXFN)
-						      (FUNCTION NUMBER.PUTFN)
-						      (FUNCTION NUMBER.GETFN)
-						      (FUNCTION NILL)
-						      (FUNCTION NUMBER.BUTTONEVENTINFN)
-						      (FUNCTION NILL)
-						      (FUNCTION NILL)
-						      (FUNCTION NILL)
-						      (FUNCTION XREF.WHENDELETEDFN)
-						      (FUNCTION NILL)
-						      (FUNCTION NILL)
-						      (FUNCTION NILL)))))
-         (IMAGEOBJPROP NEWOBJ 'TYPE
-			 'NUMBEROBJ)
-     NEWOBJ)))
-
-(NUMBEROBJP
-  (LAMBDA (IMOBJ)                                            (* ss: "25-Jun-85 12:11")
-
-          (* Tests an imageobj to see if it is a number imageobject. By convention, testing functions for an imageobject will
-	  be named (CONCAT <type of imageobj> "P"))
-
-
-    (AND IMOBJ (EQ (IMAGEOBJPROP IMOBJ 'TYPE)
-		       'NUMBEROBJ))))
-
-(NGROUP.NUMBEROBJP
-  (LAMBDA (IMOBJ)                                            (* fsg "15-Dec-86 09:57")
-
-          (* * Like NUMBEROBJP but also checks for NGroup ImageObject.)
-
-
-    (AND (NUMBEROBJP IMOBJ)
-	   (EQ (fetch (NUMBEROBJ USE) of (fetch OBJECTDATUM of IMOBJ))
-		 'NGROUP))))
-
-(NUMBER.DISPLAYFN
-  (LAMBDA (OBJ STREAM)                                       (* fsg "17-Feb-87 14:20")
-
-          (* Display function for numberobjs. Allows different formats for display according to the use to which the 
-	  numberobj is being put. If no specific action is specified, displaying defaults to printing out as a plain 
-	  number.*)
-
-
-    (LET* ((DATUM (fetch OBJECTDATUM of OBJ))
-	   (NUMSTRING (MKSTRING (fetch NUMSTRING of DATUM)))
-	   (NUMBER.TEXT (fetch NUMBER.TEXT of DATUM))
-	   (TEMPLATE (MKSTRING (fetch TEMPLATE of DATUM)))
-	   (USE (fetch USE of DATUM))
-	   (REF.TYPE (fetch REF.TYPE of DATUM))
-	   (MAIN.WINDOW (CAR (fetch \WINDOW of TEXTOBJ)))
-	   (FONT (SELECTQ USE
-			    (NOTE (fetch NUMBER.FONT of (GET.ENDNOTE.FONTS MAIN.WINDOW)))
-			    (NGROUP (NGROUP.GETFONT REF.TYPE MAIN.WINDOW))
-			    (SHOULDNT "Undefined USE field, neither NOTE nor NGroup"))))
-          (AND (STRINGP NUMBER.TEXT)
-		 (EQ USE 'NGROUP)
-		 (SETQ NUMSTRING (CONCAT NUMSTRING NUMBER.TEXT)))
-          (AND (FONTP FONT)
-		 (DSPFONT (FONTCREATE (FONTPROP FONT 'FAMILY)
-					  (FONTPROP FONT 'SIZE)
-					  (FONTPROP FONT 'FACE))
-			    STREAM))
-          (SELECTQ USE
-		     (NGROUP (PRIN3 NUMSTRING STREAM)
-			     (SELECTQ (IMAGESTREAMTYPE STREAM)
-					(DISPLAY NIL)
-					(replace PAGE.NUMBER of DATUM
-					   with (CAR FORMATTINGSTATE))))
-		     (NOTE (LET ((CURRENT.YPOS (DSPYPOSITION NIL STREAM))
-				   (IMAGEBOX (LISTGET (fetch IMAGEOBJPLIST of OBJ)
-							  'BOUNDBOX)))
-			          (DSPYPOSITION (IPLUS CURRENT.YPOS
-							   (IDIFFERENCE (fetch YSIZE
-									     of IMAGEBOX)
-									  (FONTPROP STREAM
-										      'HEIGHT)))
-						  STREAM)
-			          (PRIN1 NUMSTRING STREAM)
-			          (DSPYPOSITION CURRENT.YPOS STREAM)))
-		     NIL))))
-
-(NUMBER.IMAGEBOXFN
-  (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN)                  (* fsg "17-Feb-87 11:21")
-
-          (* * The YSize is computed as the current font height plus half of the NOTE or NGroup font.
-	  The reason is weird. Ask Sami for more details.)
-
-
-    (LET* ((MAIN.WINDOW (CAR (fetch \WINDOW of TEXTOBJ)))
-	   (DATUM (fetch OBJECTDATUM of OBJ))
-	   (USE (fetch USE of DATUM))
-	   (REF.TYPE (fetch REF.TYPE of DATUM))
-	   (DEFAULTSTRING (MKSTRING (fetch NUMSTRING of DATUM)))
-	   (NUMBER.TEXT (fetch NUMBER.TEXT of DATUM))
-	   (FONT (SELECTQ USE
-			    (NOTE (fetch NUMBER.FONT of (GET.ENDNOTE.FONTS MAIN.WINDOW)))
-			    (NGROUP (NGROUP.GETFONT REF.TYPE MAIN.WINDOW))
-			    (SHOULDNT "Undefined USE field, neither NOTE nor NGroup"))))
-          (AND (STRINGP NUMBER.TEXT)
-		 (EQ USE 'NGROUP)
-		 (SETQ DEFAULTSTRING (CONCAT DEFAULTSTRING NUMBER.TEXT)))
-          (AND (FONTP FONT)
-		 (DSPFONT (FONTCREATE (FONTPROP FONT 'FAMILY)
-					  (FONTPROP FONT 'SIZE)
-					  (FONTPROP FONT 'FACE))
-			    STREAM))
-          (create IMAGEBOX
-		    XSIZE _(STRINGWIDTH DEFAULTSTRING STREAM)
-		    YSIZE _(IPLUS (FONTPROP (CURRENT.DISPLAY.FONT STREAM)
-						'HEIGHT)
-				    (FIX (TIMES .5 (FONTPROP STREAM 'HEIGHT))))
-		    YDESC _(FONTPROP STREAM 'DESCENT)
-		    XKERN _ 0))))
-
-(NUMBER.PUTFN
-  (LAMBDA (OBJ STREAM)                                       (* fsg " 4-Feb-87 13:29")
-    (LET ((USE (fetch USE of (fetch OBJECTDATUM of OBJ)))
-	  (MAIN.WINDOW (PROCESSPROP (THIS.PROCESS)
-				      'WINDOW)))
-         (SELECTQ USE
-		    (NOTE (NOTE.PUTFN OBJ STREAM MAIN.WINDOW))
-		    (NGROUP (replace (NUMBEROBJ FONT) of (fetch OBJECTDATUM of OBJ)
-			       with (LIST.FONT.PROPS (NGROUP.GETFONT (fetch REF.TYPE
-									      of (fetch 
-										      OBJECTDATUM
-										      of OBJ))
-									   MAIN.WINDOW)))
-			    (replace NGROUP.MOTHER of (fetch OBJECTDATUM of OBJ)
-			       with (GET.FROMNODES (fetch REF.TYPE
-							  of (fetch OBJECTDATUM of OBJ))
-						       MAIN.WINDOW))
-			    (PRIN4 (LIST 'NGroup
-					     (IMAGEOBJPROP OBJ 'TAG)
-					     (fetch OBJECTDATUM of OBJ))
-				     STREAM))
-		    (PRIN4 (LIST 'Unknown% Number% Type
-				     (IMAGEOBJPROP OBJ 'TAG)
-				     (fetch OBJECTDATUM of OBJ))
-			     STREAM)))))
-
-(NUMBER.GETFN
-  (LAMBDA (STREAM)                                           (* edited: "29-Jan-87 16:27")
-    (LET* ((USE/TEXT (CDR (READ STREAM)))
-	   (NEWOBJ (NUMBEROBJ))
-	   (USE (MKATOM (fetch USE of (CADR USE/TEXT))))
-	   (WINDOW (PROCESSPROP (THIS.PROCESS)
-				  'WINDOW)))
-          (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW)
-		(TSP.FMMENU (TEXTSTREAM WINDOW)))
-          (IMAGEOBJPROP NEWOBJ 'TAG
-			  (CAR USE/TEXT))
-          (SETQ USE/TEXT (CADR USE/TEXT))
-          (replace USE of (fetch OBJECTDATUM of NEWOBJ) with USE)
-          (SELECTQ USE
-		     (NOTE (NOTE.GETFN NEWOBJ USE/TEXT WINDOW))
-		     (NGROUP (ADD.NGROUP.TO.DBASE (fetch REF.TYPE of USE/TEXT)
-						    (fetch TEMPLATE of USE/TEXT)
-						    (fetch NGROUP.MOTHER of USE/TEXT)
-						    (AND (fetch (NUMBEROBJ FONT) of USE/TEXT)
-							   (replace (NUMBEROBJ FONT)
-							      of USE/TEXT
-							      with (APPLY*
-								       'FONTCREATE
-								       (fetch (NUMBEROBJ FONT)
-									  of USE/TEXT))))
-						    (CREATE.NGROUP.NODE (fetch REF.TYPE
-									     of USE/TEXT)
-									  (fetch NGROUP.MOTHER
-									     of USE/TEXT)
-									  USE/TEXT WINDOW)
-						    WINDOW)
-			     (CREATE.NGROUP.NODE (fetch NGROUP.MOTHER of USE/TEXT)
-						   NIL NIL WINDOW)
-			     (ADD.NGROUP.TO.MOTHER.NODE (fetch REF.TYPE of USE/TEXT)
-							  (fetch NGROUP.MOTHER of USE/TEXT)
-							  WINDOW)
-			     (WINDOWPROP WINDOW 'REBUILD.GRAPHFLG
-					   T)
-			     (replace OBJECTDATUM of NEWOBJ with USE/TEXT))
-		     (replace OBJECTDATUM of NEWOBJ with USE/TEXT))
-      NEWOBJ)))
-
-(NUMBER.BUTTONEVENTINFN
-  (LAMBDA (NUMBEROBJ STREAM)                               (* fsg " 4-Feb-87 13:31")
-    (LET ((USE (fetch USE of (fetch OBJECTDATUM of NUMBEROBJ)))
-	  (REF.TYPE (fetch REF.TYPE of (fetch OBJECTDATUM of NUMBEROBJ)))
-	  (CHANGED NIL))
-         (AND (MOUSESTATE MIDDLE)
-		(SELECTQ USE
-			   (NOTE (NOTE.BUTTONEVENTINFN NUMBEROBJ STREAM))
-			   (NGROUP.BUTTONEVENTINFN REF.TYPE NUMBEROBJ STREAM)))
-     CHANGED)))
-)
-(DEFINEQ
-
-(NGROUP.BUTTONEVENTINFN
-  (LAMBDA (USE NUMBEROBJ STREAM)                             (* fsg "18-Feb-87 11:19")
-    (LET* ((TAG (IMAGEOBJPROP NUMBEROBJ 'TAG))
-	   (NMENU (create MENU
-			    TITLE _(COND
-			      (TAG (CONCAT USE " Tag:" TAG))
-			      (T USE))
-			    ITEMS _(COND
-			      (TAG '(Change% Tag))
-			      (T '(Tag)))
-			    WHENSELECTEDFN _ 'NGROUP.WHENSELECTEDFN)))
-          (PUTMENUPROP NMENU 'OBJ
-			 NUMBEROBJ)
-          (MENU NMENU))))
-
-(NGROUP.WHENSELECTEDFN
-  (LAMBDA (ITEM MENU MB)                                     (* fsg " 4-Feb-87 13:41")
-    (LET ((TSTREAM (TEXTSTREAM WINDOW))
-	  (OBJ (GETMENUPROP MENU 'OBJ))
-	  PREV.CODE CODE)
-         (SETQ CODE (TSP.GET.INCODE TSTREAM))
-         (AND (SETQ PREV.CODE (IMAGEOBJPROP OBJ 'TAG))
-		(TSP.PUTCODE PREV.CODE NIL WINDOW))
-         (IMAGEOBJPROP OBJ 'TAG
-			 CODE)
-         (COND
-	   (CODE (TSP.PUTCODE CODE OBJ WINDOW)
-		 (TSP.PUTCODE PREV.CODE NIL WINDOW))))))
-)
-(* * Number Group GRAPH functions)
-
-(DEFINEQ
-
-(GRAPHMENU
-  (LAMBDA (TSTREAM TWINDOW)                                  (* fsg " 2-Dec-86 08:54")
-    (LET* ((RESHAPEFLG NIL)
-	   (GRAPH (OR (AND (NOT (WINDOWPROP TWINDOW 'REBUILD.GRAPHFLG))
-			       (WINDOWPROP TWINDOW 'NGROUP.GRAPH))
-			(INITIAL.NGROUP.GRAPH TWINDOW)))
-	   (REGION (TSPGRAPHREGION GRAPH TWINDOW T))
-	   (GRAPHW (OR (WINDOWPROP TWINDOW 'NGROUPW)
-			 (CREATEW REGION "Number Group Graph" NIL T))))
-          (WINDOWPROP GRAPHW 'REPAINTFN
-			NIL)
-          (ATTACHWINDOW (SHAPEW GRAPHW REGION)
-			  TWINDOW
-			  'TOP
-			  'JUSTIFY
-			  'LOCALCLOSE)
-          (SHOWGRAPH GRAPH GRAPHW (FUNCTION INSERT.NGROUP)
-		       (FUNCTION CHANGE.NGROUP))
-          (WINDOWPROP TWINDOW 'REBUILD.GRAPHFLG
-			NIL)
-          (WINDOWPROP TWINDOW 'NGROUPW
-			GRAPHW)
-          (WINDOWPROP TWINDOW 'NGROUP.GRAPH
-			GRAPH)
-          (WINDOWPROP GRAPHW 'CLOSEFN
-			'DETACHWINDOW)
-          (WINDOWPROP GRAPHW 'TWINDOW
-			TWINDOW)
-          (WINDOWPROP GRAPHW 'TSTREAM
-			TSTREAM))))
-
-(TSP.NGROUP.GRAPHP
-  (LAMBDA (TWINDOW)                                          (* fsg "15-Dec-86 15:27")
-    (LET* ((MENUW (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW))
-	   (ITEM (FM.ITEMFROMID MENUW 'NGroup% Menu)))
-          (FM.ITEMPROP ITEM 'STATE))))
-
-(INITIAL.NGROUP.GRAPH
-  (LAMBDA (WINDOW)                                           (* ss: "24-Apr-86 14:31")
-    (LET* ((ROOTNODE (NODECREATE 'NEW.NGROUP
-				   'NEW.NGROUP
-				   NIL NIL NIL NIL 1))
-	   (NODELST (for NODE in (COLLECT.HASHARRAY (TSP.GET.NGROUP.ARRAY WINDOW))
-		       collect (CADR NODE))))
-          (OR (FIND.NODE 'NEW.NGROUP
-			     WINDOW)
-		(PROGN (SETQ NODELST (CONS ROOTNODE NODELST))
-			 (ADD.NGROUP.TO.DBASE 'NEW.NGROUP
-						NIL NIL NIL ROOTNODE WINDOW)))
-          (LAYOUTGRAPH NODELST '(NEW.NGROUP)))))
-
-(TSPGRAPHREGION
-  (LAMBDA (GRAPH MAIN.WINDOW TITLEFLG BORDER)                (* ss: " 2-Apr-86 16:28")
-    (LET ((R (GRAPHREGION GRAPH))
-	  (MAIN.R (WINDOWREGION MAIN.WINDOW)))
-         (replace (REGION WIDTH) of R with (WIDTHIFWINDOW (fetch (REGION WIDTH) of R)))
-         (replace (REGION HEIGHT) of R with (HEIGHTIFWINDOW (fetch (REGION HEIGHT)
-								       of R)
-								    TITLEFLG BORDER))
-     R)))
-
-(ADD.NGROUP.TO.MOTHER.NODE
-  (LAMBDA (ID MOTHERID W)                                    (* ss: " 3-Apr-86 17:50")
-    (LET* ((MOTHER.NODE (FIND.NODE MOTHERID W))
-	   (TONODES (fetch (GRAPHNODE TONODES) of MOTHER.NODE)))
-          (OR (MEMBER ID TONODES)
-		(replace (GRAPHNODE TONODES) of MOTHER.NODE with (CONS ID TONODES))))))
-
-(ADD.NODE.TO.GRAPH
-  (LAMBDA (NODE GRAPH WINDOW)                                (* ss: "24-Apr-86 14:26")
-    (LET* ((PARENT.NODE (FIND.NODE (CAR (fetch (GRAPHNODE FROMNODES) of NODE))
-				     WINDOW))
-	   (TONODES (fetch (GRAPHNODE TONODES) of NODE)))
-          (OR (MEMBER (fetch (GRAPHNODE NODEID) of NODE)
-			  TONODES)
-		(PROGN (replace (GRAPHNODE TONODES) of PARENT.NODE
-			    with (CONS (fetch (GRAPHNODE NODEID) of NODE)
-					   (fetch (GRAPHNODE TONODES) of PARENT.NODE)))
-			 (replace (GRAPH GRAPHNODES) of GRAPH
-			    with (CONS NODE (fetch (GRAPH GRAPHNODES) of GRAPH)))))
-          (LAYOUTGRAPH (fetch (GRAPH GRAPHNODES) of GRAPH)
-			 '(NEW.NGROUP)))))
-
-(COLLECT.HASHARRAY
-  (LAMBDA (HARRAY)                                         (* ss: " 3-Apr-86 16:46")
-    (LET ((RESULT NIL))
-         (MAPHASH HARRAY '(LAMBDA (VAL KY)
-				    (SETQ RESULT (CONS VAL RESULT))))
-     RESULT)))
-
-(CREATE.NGROUP.NODE
-  (LAMBDA (ID MOTHER USERDATA W)                             (* ss: " 4-Apr-86 13:13")
-    (LET* ((NGROUP.HARRAY (TSP.GET.NGROUP.ARRAY W))
-	   (NODE (GETHASH ID NGROUP.HARRAY)))
-          (OR NODE (LET ((NEW.NODE (NODECREATE ID ID NIL NIL (LIST MOTHER))))
-		          (PUTHASH ID (LIST USERDATA NEW.NODE)
-				     (LIST NGROUP.HARRAY))
-		      NEW.NODE))
-          (OR (AND NODE (CAR NODE))
-		(AND USERDATA NODE (RPLACA NODE USERDATA))))))
-
-(GET.FROMNODES
-  (LAMBDA (NGID WINDOW)                                      (* ss: " 3-Apr-86 16:00")
-    (CAR (fetch (GRAPHNODE FROMNODES) of (FIND.NODE NGID WINDOW)))))
-
-(GET.MOTHER.GROUP
-  (LAMBDA (DEPENDENT WINDOW)                                 (* ss: " 2-Apr-86 16:30")
-    (CAR (fetch (GRAPHNODE FROMNODES) of (FIND.NODE DEPENDENT WINDOW)))))
-
-(MAKE.MOTHER.NODE
-  (LAMBDA NIL                                                (* ss: " 8-Feb-86 16:01")
-    (LET ((TONODES NIL))
-         (NODECREATE 'NEW.NGROUP
-		       'NEW.NGROUP
-		       NIL
-		       (for NGROUP in (TSP.GET 'NGROUPS)
-			  do (COND
-				 ((NOT (GET.FROMNODES (fetch REF.TYPE of NGROUP)))
-				   (SETQ TONODES (CONS (fetch REF.TYPE of NGROUP)
-							   TONODES))))
-			  finally (RETURN TONODES))
-		       NIL NIL 1))))
-
-(MAKE.NGROUP.NODELST
-  (LAMBDA NIL                                                (* ss: " 8-Feb-86 16:04")
-    (LET* ((NODELST (for NGROUP in (TSP.GET 'NGROUPS)
-		       collect (NODECREATE (fetch REF.TYPE of NGROUP)
-					       (fetch REF.TYPE of NGROUP)
-					       NIL
-					       (GET.TONODES (fetch REF.TYPE of NGROUP))
-					       (GET.FROMNODES (fetch REF.TYPE of NGROUP))))))
-          (SETQ NODELST (CONS (MAKE.MOTHER.NODE)
-				  NODELST)))))
-
-(GET.TONODES
-  (LAMBDA (MOTHER-GROUP WINDOW)                              (* ss: " 2-Apr-86 16:31")
-    (fetch (GRAPHNODE TONODES) of (FIND.NODE MOTHER-GROUP WINDOW))))
-
-(FIND.NODE
-  (LAMBDA (NID WINDOW)                                       (* ss: " 3-Apr-86 18:26")
-    (CADR (GETHASH NID (TSP.GET.NGROUP.ARRAY WINDOW)))))
-)
-(* * Other unsorted functions)
-
-(DEFINEQ
-
-(INSERT.NGROUP
-  (LAMBDA (NODE GRAPHW)                                      (* fsg "13-Jan-87 16:21")
-    (AND NODE (LET* ((TWINDOW (WINDOWPROP GRAPHW 'TWINDOW))
-		       (TSTREAM (WINDOWPROP GRAPHW 'TSTREAM))
-		       (LABEL (fetch (GRAPHNODE NODELABEL) of NODE))
-		       (TEMPLATE (fetch (NUMBEROBJ TEMPLATE)
-				    of (CAR (GETHASH LABEL (TSP.GET.NGROUP.ARRAY TWINDOW)))))
-		       (OLDLOOKS (fetch CARETLOOKS of (TEXTOBJ TSTREAM)))
-		       (NEWLOOKS (NGROUP.GETFONT LABEL TWINDOW)))
-		      (SELECTQ LABEL
-				 (NEW.NGROUP (COND
-					       ((ADD.NUMBER.GROUP TWINDOW TSTREAM)
-						 (CLOSEW GRAPHW)
-						 (GRAPHMENU TSTREAM TWINDOW))
-					       (T NIL)))
-				 (AND (VERIFY.NGROUP.ORDER TWINDOW TSTREAM LABEL)
-					(PROGN (TEDIT.CARETLOOKS TSTREAM NEWLOOKS)
-						 (LET ((NEWOBJ (NUMBEROBJ 'NGROUP
-									    TEMPLATE
-									    (CONCAT "[" LABEL "]")
-									    NIL LABEL NEWLOOKS)))
-						      (AND (TOC.ENABLED? TWINDOW)
-							     (GET.TOC.TEXTSTRING NEWOBJ TSTREAM 
-										   LABEL))
-						      (IMAGEOBJPROP NEWOBJ 'TWINDOW
-								      TWINDOW)
-						      (TEDIT.INSERT.OBJECT NEWOBJ TSTREAM))
-						 (TEDIT.CARETLOOKS TSTREAM OLDLOOKS)
-						 (AND (UPDATE? TWINDOW)
-							(UPDATE.NUMBEROBJS TWINDOW
-									     'NUMBEROBJP)))))))))
-
-(VERIFY.NGROUP.ORDER
-  (LAMBDA (WINDOW STREAM LABEL)                              (* fsg "15-Dec-86 15:46")
-
-          (* * Verify the NGroup order before inserting a new NGroup. The order is valid if the new NGroup is a top level 
-	  node or the previous NGroup is the same as or the mother of this new NGroup. Note that the "previous NGroup" must 
-	  be a member of this NGroup`s tree branch.)
-
-
-    (OR (EQ (GET.FROMNODES LABEL WINDOW)
-		'NEW.NGROUP)
-	  (LET* ((ANCESTORS (LIST.ANCESTORS LABEL NIL WINDOW))
-		 (MOTHER (CAR (LAST ANCESTORS)))
-		 (SELECTION (TEDIT.GETSEL STREAM))
-		 (CH# (SELECTQ (fetch POINT of SELECTION)
-				 (LEFT (fetch CH# of SELECTION))
-				 (ADD1 (fetch CH# of SELECTION))))
-		 PREV.NGROUP)
-	        (NCONC1 ANCESTORS LABEL)
-	        (SETQ PREV.NGROUP (for OBJ in (REVERSE (TSP.LIST.OF.OBJECTS (TEXTOBJ
-											WINDOW)
-										      '
-										NGROUP.NUMBEROBJP))
-				       bind REF.TYPE
-				       do (COND
-					      ((AND (IGREATERP CH# (CADR OBJ))
-						      (MEMB (SETQ REF.TYPE
-								(fetch (NUMBEROBJ REF.TYPE)
-								   of (fetch OBJECTDATUM
-									   of (CAR OBJ))))
-							      ANCESTORS))
-						(RETURN REF.TYPE))
-					      (T NIL))))
-	        (COND
-		  ((OR (EQ PREV.NGROUP LABEL)
-			 (EQ PREV.NGROUP MOTHER))
-		    T)
-		  (T (TEDIT.PROMPTPRINT STREAM (CONCAT "%"" LABEL 
-							   "%" not inserted, no preceding %""
-							   MOTHER "%" NGroup.")
-					  T)
-		     NIL))))))
-
-(ADD.NUMBER.GROUP
-  (LAMBDA (TWINDOW STREAM)                                   (* fsg "14-Jan-87 11:30")
-    (OR (TSP.NGROUP.GRAPHP TWINDOW)
-	  (PROGN (FM.CHANGESTATE (FM.ITEMFROMID (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW)
-						      'NGroup% Menu)
-				     (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW))
-		   (GRAPHMENU STREAM TWINDOW)))
-    (LET* ((PREV.ITEMS (COLLECT.NGROUPS TWINDOW))
-	   (NEW.GROUPID (MKATOM (TSP.LEGALID NIL (CONS 'NEW.NGROUP
-							     PREV.ITEMS)
-						 STREAM)))
-	   TEMPLATE DEPENDENT.CLASS NEW.NODE)
-          (COND
-	    (NEW.GROUPID (SETQ DEPENDENT.CLASS
-			   (MKATOM (AND PREV.ITEMS (MENU (create MENU
-									 TITLE _ 
-								    "Select Parent Group OR none"
-									 ITEMS _(SORT PREV.ITEMS
-											'UALPHORDER)))
-					    )))
-			 (SETQ TEMPLATE (OR TEMPLATE (create NGTEMPLATE
-								   NG.CHARTYPE _ 'Number
-								   NG.DELIMIT _ "."
-								   NG.START _ 1
-								   NG.ADDTOTOC _ T)))
-			 (SETQ NEW.NODE (NODECREATE NEW.GROUPID NEW.GROUPID NIL NIL
-							(LIST (OR DEPENDENT.CLASS
-								      'NEW.NGROUP))))
-			 (ADD.NGROUP.TO.DBASE NEW.GROUPID TEMPLATE DEPENDENT.CLASS GP.DefaultFont 
-						NEW.NODE TWINDOW)
-			 (ADD.NODE.TO.GRAPH NEW.NODE (WINDOWPROP TWINDOW 'NGROUP.GRAPH)
-					      TWINDOW))
-	    (T NIL)))))
-
-(ADD.NGROUP.TO.DBASE
-  (LAMBDA (NEW.GROUPID TEMPLATE DEPENDENT.CLASS FONT NGROUP.NODE TWINDOW)
-                                                             (* ss: "24-Apr-86 14:19")
-    (LET ((NGROUP.ARRAY (TSP.GET.NGROUP.ARRAY TWINDOW)))
-         (OR (GETHASH NEW.GROUPID NGROUP.ARRAY)
-	       (PROGN (WINDOWPROP TWINDOW 'REBUILD.GRAPHFLG
-				      T)
-			(PUTHASH NEW.GROUPID
-				   (LIST (create NUMBEROBJ
-						     NGROUP.MOTHER _ DEPENDENT.CLASS
-						     FONT _ FONT
-						     REF.TYPE _ NEW.GROUPID
-						     TEMPLATE _ TEMPLATE)
-					   NGROUP.NODE)
-				   (LIST NGROUP.ARRAY)))))))
-
-(COLLECT.NGROUPS
-  (LAMBDA (TWINDOW)                                          (* ss: "31-Mar-86 13:53")
-    (LET ((GRAPH (WINDOWPROP TWINDOW 'NGROUP.GRAPH)))
-         (for NODE in (fetch (GRAPH GRAPHNODES) of GRAPH) collect (fetch
-									      (GRAPHNODE NODEID)
-									       of NODE)
-	    unless (EQ (fetch (GRAPHNODE NODEID) of NODE)
-			   'NEW.NGROUP)))))
-
-(LIST.FONT.PROPS
-  (LAMBDA (FONTDES)                                          (* ss: " 6-Feb-86 16:12")
-    (AND FONTDES (LIST (FONTPROP FONTDES 'FAMILY)
-			   (FONTPROP FONTDES 'SIZE)
-			   (FONTPROP FONTDES 'FACE)))))
-
-(MAP.NGROUP.LOOKS
-  (LAMBDA (LABEL NEWFDESC TWINDOW)                           (* ss: " 2-Apr-86 18:04")
-    (TEDIT.PROMPTPRINT (TEXTSTREAM TWINDOW)
-			 (CONCAT "Updating looks for " LABEL " numbers...")
-			 T)
-    (for NOTE/CH# in (TSP.LIST.OF.OBJECTS (TEXTOBJ TWINDOW)
-						(BQUOTE (LAMBDA (OBJ)
-							    (AND (IMAGEOBJP OBJ)
-								   (EQ (FETCH REF.TYPE
-									    OF OBJ:OBJECTDATUM)
-									 ,
-									 (KWOTE LABEL))))))
-       do (TEDIT.LOOKS (TEXTSTREAM TWINDOW)
-			   NEWFDESC
-			   (CADR NOTE/CH#)
-			   1))
-    (TEDIT.PROMPTPRINT (TEXTSTREAM TWINDOW)
-			 "done.")))
-
-(NGROUP.GETFONT
-  (LAMBDA (NGROUP.NAME WINDOW)                               (* ss: " 3-Apr-86 18:26")
-    (fetch (NUMBEROBJ FONT) of (CAR (GETHASH NGROUP.NAME (TSP.GET.NGROUP.ARRAY WINDOW)))))
-)
-
-(CHANGE.NGROUP
-  (LAMBDA (NODE GRAPHW)                                      (* fsg "13-Jan-87 15:11")
-
-          (* * Here when number group node is middle buttoned. Allow user to change the font and/or format of the ngroup.)
-
-
-    (AND NODE (OR (EQ 'NEW.NGROUP
-			    (fetch (GRAPHNODE NODELABEL) of NODE))
-		      (LET ((LABEL (fetch NODELABEL of NODE))
-			    (ITEM.TO.CHANGE (MENU (create MENU
-							      TITLE _ "Item to change"
-							      CENTERFLG _ T
-							      ITEMS _ '(Font Format)))))
-		           (SELECTQ ITEM.TO.CHANGE
-				      (Font (CHANGE.NGROUP.FONT LABEL GRAPHW))
-				      (Format (CHANGE.NGROUP.FORMAT LABEL GRAPHW))
-				      NIL))))))
-
-(CHANGE.NGROUP.FONT
-  (LAMBDA (LABEL GRAPHW)                                     (* fsg "13-Jan-87 15:13")
-
-          (* * Change the font of a number group.)
-
-
-    (LET* ((TSTREAM (WINDOWPROP GRAPHW 'TSTREAM))
-	   (TWINDOW (WINDOWPROP GRAPHW 'TWINDOW))
-	   (NBROBJ (CAR (GETHASH LABEL (TSP.GET.NGROUP.ARRAY TWINDOW))))
-	   (OLD.FONT (fetch (NUMBEROBJ FONT) of NBROBJ))
-	   NEW.FONT)
-          (TEDIT.PROMPTPRINT TSTREAM (CONCAT "%"" LABEL "%" font is " (LIST (ABBREVIATE.FONT
-										    OLD.FONT))
-						 ", change to...")
-			       T)
-          (SETQ NEW.FONT (FONTCREATE (GET.TSP.FONT TWINDOW OLD.FONT)))
-          (COND
-	    ((NEQ OLD.FONT NEW.FONT)
-	      (replace (NUMBEROBJ FONT) of NBROBJ with NEW.FONT)
-	      (MAP.NGROUP.LOOKS LABEL NEW.FONT TWINDOW))
-	    (T NIL))
-          (TEDIT.PROMPTPRINT TSTREAM "" T))))
-
-(CHANGE.NGROUP.FORMAT
-  (LAMBDA (LABEL GRAPHW)                                     (* fsg "14-Jan-87 11:40")
-
-          (* * Change the format of a number group. The format is three element record; the character type, the delimiter, 
-	  and starting value.)
-
-
-    (LET* ((TSTREAM (WINDOWPROP GRAPHW 'TSTREAM))
-	   (TWINDOW (WINDOWPROP GRAPHW 'TWINDOW))
-	   (NBROBJ (CAR (GETHASH LABEL (TSP.GET.NGROUP.ARRAY TWINDOW))))
-	   (OLD.TEMPLATE (fetch (NUMBEROBJ TEMPLATE) of NBROBJ))
-	   NEW.CHARTYPE NEW.DELIMIT NEW.START NEW.ADDTOTOC)
-          (AND (SETQ NEW.CHARTYPE (CHANGE.NGROUP.CHARTYPE OLD.TEMPLATE LABEL TSTREAM))
-		 (replace (NGTEMPLATE NG.CHARTYPE) of OLD.TEMPLATE with NEW.CHARTYPE))
-          (AND (SETQ NEW.DELIMIT (CHANGE.NGROUP.DELIMIT OLD.TEMPLATE LABEL TSTREAM))
-		 (replace (NGTEMPLATE NG.DELIMIT) of OLD.TEMPLATE with NEW.DELIMIT))
-          (AND (SETQ NEW.START (CHANGE.NGROUP.START OLD.TEMPLATE LABEL TSTREAM))
-		 (replace (NGTEMPLATE NG.START) of OLD.TEMPLATE with NEW.START))
-          (AND (SETQ NEW.ADDTOTOC (CHANGE.NGROUP.ADDTOTOC OLD.TEMPLATE LABEL TSTREAM))
-		 (replace (NGTEMPLATE NG.ADDTOTOC) of OLD.TEMPLATE with (CDR NEW.ADDTOTOC)))
-          (COND
-	    ((OR NEW.CHARTYPE NEW.DELIMIT NEW.START)
-	      (MAP.NGROUP.LOOKS LABEL (fetch (NUMBEROBJ FONT) of NBROBJ)
-				  TWINDOW))
-	    (T (TEDIT.PROMPTPRINT TSTREAM "" T))))))
-
-(CHANGE.NGROUP.CHARTYPE
-  (LAMBDA (TEMPLATE LABEL STREAM)                            (* fsg "13-Jan-87 14:52")
-
-          (* * Show this NGroup's display type and return a possibly new display type.)
-
-
-    (TEDIT.PROMPTPRINT STREAM (CONCAT "%"" LABEL "%" displayed as " (fetch (NGTEMPLATE 
-										      NG.CHARTYPE)
-									   of TEMPLATE)
-					  ", change to...")
-			 T)
-    (MENU (create MENU
-		      TITLE _ "NGroup Types"
-		      CENTERFLG _ T
-		      ITEMS _ '(Number Null% String Uppercase% Letter Lowercase% Letter 
-				       Uppercase% Roman Lowercase% Roman)))))
-
-(CHANGE.NGROUP.DELIMIT
-  (LAMBDA (TEMPLATE LABEL STREAM)                            (* fsg "13-Jan-87 14:38")
-
-          (* * Show the delimiter following this NGroup and return a possibly new delimiter.)
-
-
-    (TEDIT.PROMPTPRINT STREAM (CONCAT "Delimiter following %"" LABEL "%" is %""
-					  (fetch (NGTEMPLATE NG.DELIMIT) of TEMPLATE)
-					  "%", change to...")
-			 T)
-    (LET ((NEW.DELIMIT (MENU (create MENU
-					 TITLE _ "NGroup Delimiters"
-					 CENTERFLG _ T
-					 ITEMS _ '((Dot ".")
-						   (Dash "-")
-						   (Null% String "")
-						   Other)))))
-         (COND
-	   ((EQ NEW.DELIMIT 'Other)
-	     (MKSTRING (TEDIT.GETINPUT STREAM (CONCAT "Specify delimiter following " LABEL ":"))
-			 ))
-	   (T NEW.DELIMIT)))))
-
-(CHANGE.NGROUP.START
-  (LAMBDA (TEMPLATE LABEL STREAM)                            (* fsg "13-Jan-87 15:09")
-
-          (* * Show this NGroup's starting value and return a possibly new starting value.)
-
-
-    (TEDIT.PROMPTPRINT STREAM (CONCAT "Starting value of %"" LABEL "%" is "
-					  (fetch (NGTEMPLATE NG.START) of TEMPLATE)
-					  ", change it?")
-			 T)
-    (MENU (create MENU
-		      TITLE _ "Change start?"
-		      CENTERFLG _ T
-		      ITEMS _ '(YES NO)
-		      WHENSELECTEDFN _(FUNCTION (LAMBDA (ITEM)
-			  (COND
-			    ((EQ ITEM 'YES)
-			      (NUMBERPAD.READ (CREATE.NUMBERPAD.READER "Starting NGroup Value" 
-									   NIL NIL NIL T)))
-			    (T NIL))))))))
-
-(CHANGE.NGROUP.ADDTOTOC
-  (LAMBDA (TEMPLATE LABEL STREAM)                            (* fsg "14-Jan-87 13:17")
-
-          (* * Say if this NGroup will/won't be included in the TOC, if any and retrun a possibly new ADD-TO-TOC flag.)
-
-
-    (TEDIT.PROMPTPRINT STREAM (CONCAT "%"" LABEL "%" is " (COND
-					    ((fetch (NGTEMPLATE NG.ADDTOTOC) of TEMPLATE)
-					      "")
-					    (T "NOT "))
-					  "included in TOC. Do you want it included?")
-			 T)
-    (MENU (create MENU
-		      TITLE _ "Include in TOC?"
-		      CENTERFLG _ T
-		      ITEMS _ '(YES NO)
-		      WHENSELECTEDFN _(FUNCTION (LAMBDA (ITEM)
-			  (CONS ITEM (COND
-				    ((EQ ITEM 'YES)
-				      T)
-				    (T NIL)))))))))
-
-(TSP.GET.NGROUP.ARRAY
-  (LAMBDA (W)                                                (* ss: " 3-Apr-86 18:25")
-    (WINDOWPROP W 'TSP.NGROUP.ARRAY)))
-
-(TSP.LEGALID
-  (LAMBDA (NAME NGROUPS STREAM)                              (* ss: "31-Mar-86 14:23")
-    (LET ((LEGAL T)
-	  (ID (OR NAME (MKATOM (TEDIT.GETINPUT STREAM "Group name>")))))
-         (COND
-	   ((MEMBER ID NGROUPS)
-	     (TSP.LEGALID (MKATOM (TEDIT.GETINPUT STREAM "Illegal name... Group name>"))
-			    NGROUPS STREAM))
-	   (T ID)))))
-)
-(* * Number counting functions)
-
-(DEFINEQ
-
-(UPDATE.NUMBEROBJS
-  (LAMBDA (WINDOW TESTFN TESTFNARG)                          (* fsg " 3-Feb-87 10:30")
-    (LET* ((TEXTOBJ (TEXTOBJ WINDOW))
-	   (STREAM (TEXTSTREAM WINDOW))
-	   (NBROBJ.LIST (TSP.LIST.OF.OBJECTS TEXTOBJ TESTFN TESTFNARG)))
-          (TEDIT.PROMPTPRINT STREAM "Updating Number Group ImageObjects..." T)
-          (for NUMBEROBJ in NBROBJ.LIST
-	     do (LET* ((OBJECTDATUM (fetch OBJECTDATUM of (CAR NUMBEROBJ)))
-			 (REF.TYPE (fetch REF.TYPE of OBJECTDATUM))
-			 (NUMSTRING (MKATOM (fetch NUMSTRING of OBJECTDATUM)))
-			 (USE (fetch USE of OBJECTDATUM))
-			 (TEMPLATE (SELECTQ USE
-					      (NGROUP (fetch TEMPLATE of OBJECTDATUM))
-					      NIL))
-			 (DEPENDENT.CLASS (GET.MOTHER.GROUP REF.TYPE WINDOW))
-			 NEW.COUNT)
-		        (RESET.DEPENDENT.CLASSES WINDOW USE REF.TYPE)
-		        (SETQ NEW.COUNT (GET.NCOUNTER WINDOW USE REF.TYPE DEPENDENT.CLASS 
-							  TEMPLATE))
-		        (COND
-			  ((EQ NEW.COUNT NUMSTRING))
-			  (T (replace NUMSTRING of OBJECTDATUM with NEW.COUNT)
-			     (TEDIT.OBJECT.CHANGED STREAM (CAR NUMBEROBJ)))))
-	     finally (REMOVE.ALL.COUNTERS WINDOW))
-          (TEDIT.PROMPTPRINT STREAM "done"))))
-
-(RESET.DEPENDENT.CLASSES
-  (LAMBDA (WINDOW USE REF.TYPE)                              (* fsg "12-Dec-86 10:50")
-    (for DEPENDENT in (fetch (GRAPHNODE TONODES) of (FIND.NODE REF.TYPE WINDOW))
-       do (PROGN (RESET.NCOUNTER WINDOW USE DEPENDENT)
-		     (RESET.DEPENDENT.CLASSES WINDOW USE DEPENDENT)))))
-
-(RESET.NCOUNTER
-  (LAMBDA (WINDOW USE REF.TYPE)                              (* fsg "12-Dec-86 11:07")
-    (LET* ((TEMPLATE (SELECTQ USE
-				(NGROUP (fetch (NUMBEROBJ TEMPLATE)
-					   of (CAR (GETHASH REF.TYPE (TSP.GET.NGROUP.ARRAY
-								    WINDOW)))))
-				NIL))
-	   (COUNTER (NCOUNTER? WINDOW USE REF.TYPE TEMPLATE)))
-          (replace NCOUNT of COUNTER with (COND
-						  (TEMPLATE (SUB1 (fetch NG.START of TEMPLATE)))
-						  (T 0))))))
-
-(GET.NCOUNTER
-  (LAMBDA (WINDOW USE REF.TYPE MOTHER.CLASS TEMPLATE)        (* fsg "17-Dec-86 16:33")
-    (LET ((COUNTER (NCOUNTER? WINDOW USE REF.TYPE TEMPLATE)))
-         (COND
-	   (COUNTER (PROGN (replace NCOUNT of COUNTER with (ADD1 (fetch NCOUNT
-									      of COUNTER)))
-			     (COND
-			       (MOTHER.CLASS (FLATTEN.TREE.TO.STRING WINDOW USE REF.TYPE))
-			       (T (fetch NCOUNT of COUNTER)))))
-	   (T NIL)))))
-
-(NCOUNTER?
-  (LAMBDA (WINDOW USE REF.TYPE TEMPLATE)                     (* fsg "23-Dec-86 09:13")
-
-          (* * Return the record for this number counter. If the record doesn't exist, we create one based on the USE value.)
-
-
-    (LET ((COUNTER.ID (MKATOM (CONCAT (SELECTQ USE
-						     (NGROUP REF.TYPE)
-						     USE)
-					  "COUNTER"))))
-         (OR (WINDOWPROP WINDOW COUNTER.ID)
-	       (PROGN (WINDOWPROP WINDOW COUNTER.ID
-				      (create NGCOUNTER
-						NCOUNT _(COND
-						  ((AND (EQ USE 'NGROUP)
-							  TEMPLATE)
-						    (SUB1 (fetch NG.START of TEMPLATE)))
-						  (T 0))
-						ANCESTRY _(SELECTQ USE
-								     (NGROUP (LIST.ANCESTORS 
-											 REF.TYPE NIL 
-											   WINDOW))
-								     NIL)))
-			(WINDOWADDPROP WINDOW 'COUNTERS
-					 COUNTER.ID)
-			(WINDOWPROP WINDOW COUNTER.ID))))))
-
-(LIST.ANCESTORS
-  (LAMBDA (NID ANCESTORS WINDOW)                             (* ss: " 2-Apr-86 16:32")
-    (LET* ((NODE (FIND.NODE NID WINDOW))
-	   (MOTHER (AND NODE (CAR (fetch (GRAPHNODE FROMNODES) of NODE)))))
-          (COND
-	    ((AND MOTHER (NEQ MOTHER 'NEW.NGROUP))
-	      (LIST.ANCESTORS MOTHER (CONS MOTHER ANCESTORS)
-				WINDOW))
-	    (T ANCESTORS)))))
-
-(FLATTEN.TREE.TO.STRING
-  (LAMBDA (WINDOW USE REF.TYPE)                              (* fsg "17-Dec-86 16:45")
-    (LET ((NCOUNTER (NCOUNTER? WINDOW USE REF.TYPE))
-	  (FLAT.TREE ""))
-         (COND
-	   ((fetch ANCESTRY of NCOUNTER)
-	     (for (ANCESTOR ANCESTOR.NCOUNT) in (REVERSE (fetch ANCESTRY of NCOUNTER))
-		do (SETQ ANCESTOR.NCOUNT (fetch NCOUNT of (NCOUNTER? WINDOW USE ANCESTOR)))
-		     (SETQ FLAT.TREE (CONCAT (SELECTQ USE
-							    (NGROUP (NGROUP.CHARTYPE WINDOW 
-										       ANCESTOR 
-										  ANCESTOR.NCOUNT T))
-							    (CONCAT ANCESTOR.NCOUNT '-))
-						 FLAT.TREE))
-		finally (SETQ FLAT.TREE
-			    (MKATOM (CONCAT FLAT.TREE
-						(SELECTQ USE
-							   (NGROUP (NGROUP.CHARTYPE WINDOW REF.TYPE
-										      (fetch NCOUNT
-											 of 
-											 NCOUNTER)
-										      NIL))
-							   (fetch NCOUNT of NCOUNTER)))))))
-	   (T (SETQ FLAT.TREE (SELECTQ USE
-					   (NGROUP (NGROUP.CHARTYPE WINDOW REF.TYPE
-								      (fetch NCOUNT of NCOUNTER)
-								      NIL))
-					   (fetch NCOUNT of NCOUNTER)))))
-     FLAT.TREE)))
-
-(NGROUP.CHARTYPE
-  (LAMBDA (WINDOW REF.TYPE NCOUNT MORE.FIELDS?)              (* fsg "13-Jan-87 15:26")
-
-          (* * Convert the number NCOUNT to the format specified in TEMPLATE.)
-
-
-    (LET* ((NBROBJ (CAR (GETHASH REF.TYPE (TSP.GET.NGROUP.ARRAY WINDOW))))
-	   (TEMPLATE (fetch (NUMBEROBJ TEMPLATE) of NBROBJ))
-	   (CHARTYPE (fetch (NGTEMPLATE NG.CHARTYPE) of TEMPLATE)))
-          (CONCAT (COND
-		      ((OR (NOT (NUMBERP NCOUNT))
-			     (ILEQ NCOUNT 0))
-			"?")
-		      (T (SELECTQ CHARTYPE
-				    (Number (MKSTRING NCOUNT))
-				    (Uppercase% Letter (NUMBER.TO.LETTER NCOUNT T))
-				    (Lowercase% Letter (NUMBER.TO.LETTER NCOUNT))
-				    (Uppercase% Roman (ROMANNUMERALS NCOUNT T))
-				    (Lowercase% Roman (ROMANNUMERALS NCOUNT))
-				    (Null% String "")
-				    NIL)))
-		    (COND
-		      ((OR MORE.FIELDS? (EQ (GET.FROMNODES REF.TYPE WINDOW)
-						'NEW.NGROUP))
-			(fetch (NGTEMPLATE NG.DELIMIT) of TEMPLATE))
-		      (T ""))))))
-
-(NUMBER.TO.LETTER
-  (LAMBDA (NUMBER UCFLG)                                     (* fsg " 5-Dec-86 10:18")
-
-          (* * Convert NUMBER to equivalent letter code.)
-
-
-    (LET ((LTRLST (MKSTRING (CHARACTER (IPLUS (CHARCODE A)
-						    (IREMAINDER (SUB1 NUMBER)
-								  26)))))
-	  (LTRNBR (IQUOTIENT (SUB1 NUMBER)
-			       26)))
-         (until (ZEROP LTRNBR)
-	    do (SETQ LTRLST (CONCAT (CHARACTER (SUB1 (IPLUS (CHARCODE A)
-									(IREMAINDER LTRNBR 26))))
-					  LTRLST))
-		 (SETQ LTRNBR (IQUOTIENT LTRNBR 26)))
-         (COND
-	   (UCFLG (U-CASE LTRLST))
-	   (T (L-CASE LTRLST))))))
-
-(REMOVE.ALL.COUNTERS
-  (LAMBDA (WINDOW)                                           (* ss: "30-Sep-85 09:38")
-    (for COUNTER in (WINDOWPROP WINDOW 'COUNTERS) do (WINDOWPROP WINDOW COUNTER NIL)
-       finally (WINDOWPROP WINDOW 'COUNTERS
-			       NIL))))
-)
-(* * Table-of-Contents functions)
-
-(DEFINEQ
-
-(TOC.ENABLED?
-  (LAMBDA (WINDOW)                                           (* fsg "10-Dec-86 15:40")
-    (WINDOWPROP WINDOW 'ENABLETOC)))
-
-(GET.TOC.TEXTSTRING
-  (LAMBDA (NBROBJ STREAM LABEL)                              (* fsg "14-Jan-87 09:35")
-
-          (* * Here if TOC is enabled to get the Table-Of-Contents text string for this NGroup. Because the WRITE.TOC.FILE 
-	  function uses a tab to align the page numbers, any tabs in the TOC string are converted to spaces.)
-
-
-    (LET ((TOC.STRING (TEDIT.GETINPUT STREAM (CONCAT "Text for " LABEL ":  "))))
-         (AND TOC.STRING (replace (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM of NBROBJ)
-			      with (CONCAT "  "
-					       (MKSTRING
-						 (PACK (for TOC.CHAR in (UNPACK TOC.STRING)
-							    collect
-							     (COND
-							       ((EQ TOC.CHAR
-								      (CHARACTER (CHARCODE TAB)))
-								 (CHARACTER (CHARCODE SPACE)))
-							       (T TOC.CHAR)))))))))))
-
-(CREATE.TOC.FILE
-  (LAMBDA (STREAM WINDOW)                                    (* fsg "27-Jan-87 09:32")
-
-          (* * Here to print the Table Of Contents. Each Line of the TOC consists of the NGroup, the corresponding text, 
-	  followed by the current listing page number.)
-
-
-    (LET* ((TOC.LIST (TSP.LIST.OF.OBJECTS (TEXTOBJ WINDOW)
-					    'NGROUP.NUMBEROBJP))
-	   (TOC.FILE (GET.TOC.FILE (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW)))
-	   (TOC.TABSTOP (LIST 'PARALOOKS
-				(LIST 'TABS
-					(LIST NIL (CONS (FIXR (ITIMES 72.27 5.5))
-							    'DOTTEDLEFT)))))
-	   (TOC.STREAM (AND TOC.FILE (OPENTEXTSTREAM NIL NIL NIL NIL TOC.TABSTOP))))
-          (COND
-	    ((AND TOC.LIST TOC.FILE)
-	      (TEDIT.PROMPTPRINT STREAM (CONCAT "Putting Table-Of-Contents in " TOC.FILE "...")
-				   T)
-	      (WRITE.TOC.FILE TOC.STREAM TOC.LIST WINDOW)
-	      (TEDIT.PROMPTPRINT STREAM "done")
-	      (TEDIT.PUT TOC.STREAM TOC.FILE)
-	      TOC.FILE)
-	    (TOC.LIST (TEDIT.PROMPTPRINT STREAM 
-					   "Specify a file name for the Table-Of-Contents first."
-					   T)
-		      NIL)
-	    (T (TEDIT.PROMPTPRINT STREAM "There are no NGroups in this document." T)
-	       NIL)))))
-
-(VIEW.TOC.FILE
-  (LAMBDA (STREAM WINDOW)                                    (* fsg "15-Dec-86 13:48")
-
-          (* * Writes out the TOC file via CREATE.TOC.FILE and then opens another TEdit window where this new file is 
-	  displayed.)
-
-
-    (LET ((TOC.FILE (CREATE.TOC.FILE STREAM WINDOW))
-	  (TOC.FILEW (WINDOWPROP WINDOW 'TOC.WINDOW)))
-         (AND TOC.FILE (COND
-		  ((WINDOWP TOC.FILEW)
-		    (COND
-		      ((OPENWP TOC.FILEW)
-			(TEDIT.GET (TEXTOBJ TOC.FILEW)
-				     TOC.FILE))
-		      ((OPENW TOC.FILEW)
-			(TEDIT TOC.FILE TOC.FILEW))))
-		  (T (WINDOWPROP WINDOW 'TOC.WINDOW
-				   (SETQ TOC.FILEW (CREATEW NIL (CONCAT "Viewing TOC file: " 
-									      TOC.FILE))))
-		     (TEDIT TOC.FILE TOC.FILEW)))))))
-
-(GET.TOC.FILE
-  (LAMBDA (MENUW)                                            (* fsg "11-Dec-86 10:27")
-
-          (* * Return the user specified Table-Of-Contents file name.)
-
-
-    (LET* ((ITEM (FM.ITEMFROMID MENUW 'TOC.FILE))
-	   (TOC.FILENAME (FM.ITEMPROP ITEM 'LABEL)))
-          (COND
-	    ((NOT (STREQUAL TOC.FILENAME ""))
-	      (MKATOM TOC.FILENAME))
-	    (T NIL)))))
-
-(WRITE.TOC.FILE
-  (LAMBDA (TOC.STREAM TOC.LIST WINDOW)                       (* fsg "28-Jan-87 13:27")
-
-          (* * Here to do the actual output to the TOC file.)
-
-
-    (DSPFONT (FONTCREATE '(HELVETICA 14 BRR))
-	       TOC.STREAM)
-    (PRINTOUT TOC.STREAM "Table of Contents" T)
-    (for (TOC.ITEM OBJECTDATUM ITEM.LEVEL) in TOC.LIST
-       when (fetch (NGTEMPLATE NG.ADDTOTOC) of (fetch (NUMBEROBJ TEMPLATE)
-							of (fetch OBJECTDATUM
-								of (CAR TOC.ITEM))))
-       do (SETQ OBJECTDATUM (fetch OBJECTDATUM of (CAR TOC.ITEM)))
-	    (DSPFONT (fetch (NUMBEROBJ FONT) of OBJECTDATUM)
-		       TOC.STREAM)
-	    (SETQ ITEM.LEVEL (LENGTH (LIST.ANCESTORS (fetch (NUMBEROBJ REF.TYPE)
-							      of OBJECTDATUM)
-							   NIL WINDOW)))
-	    (COND
-	      ((ZEROP ITEM.LEVEL)
-		(PRINTOUT TOC.STREAM T T))
-	      (T (RPTQ ITEM.LEVEL (PRINTOUT TOC.STREAM "   "))))
-	    (PRINTOUT TOC.STREAM (CONCAT (fetch (NUMBEROBJ NUMSTRING) of OBJECTDATUM)
-					   (OR (fetch (NUMBEROBJ NUMBER.TEXT) of OBJECTDATUM)
-						 "")))
-	    (DSPFONT GP.DefaultFont TOC.STREAM)
-	    (PRINTOUT TOC.STREAM (CHARACTER (CHARCODE TAB))
-		      (fetch (NUMBEROBJ PAGE.NUMBER) of OBJECTDATUM)
-		      T)
-	    (AND (ZEROP ITEM.LEVEL)
-		   (PRINTOUT TOC.STREAM T)))))
-)
-[DECLARE: EVAL@COMPILE 
-
-(RECORD NGCOUNTER (NCOUNT . ANCESTRY))
-
-(RECORD NGTEMPLATE (NG.CHARTYPE NG.DELIMIT NG.START NG.ADDTOTOC))
-
-(RECORD NUMBEROBJ (REF.TYPE NUMSTRING USE NGROUP.MOTHER TEMPLATE LINK.TO NUMBER.TEXT PAGE.NUMBER 
-			      FONT))
-]
-(PUTPROPS NGROUP COPYRIGHT ("Leland Stanford Junior University" 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP ((10049) (1916 NIL (NUMBEROBJ 1926 . 2911) (NUMBEROBJP 2913 . 3283) (NGROUP.NUMBEROBJP 3285
- . 3616) (NUMBER.DISPLAYFN 3618 . 5633) (NUMBER.IMAGEBOXFN 5635 . 7099) (NUMBER.PUTFN 7101 . 8230) (
-NUMBER.GETFN 8232 . 10048)))))
-STOP
-TONEVENTINFN 10294 . 10801)) (10806 11877 (
-NGROUP.BUTTONEVENTINFN 10818 . 11322) (NGROUP.WHENSELECTEDFN 11326 . 11874)) (11922 18225 (GRAPHMENU 
-11934 . 13037) (TSP.NGROUP.GRAPHP 13041 . 13313) (INITIAL.NGROUP.GRAPH 13317 . 13924) (TSPGRAPHREGION 
-13928 . 14408) (ADD.NGROUP.TO.MOTHER.NODE 14412 . 14788) (ADD.NODE.TO.GRAPH 14792 . 15593) (
-COLLECT.HASHARRAY 15597 . 15845) (CREATE.NGROUP.NODE 15849 . 16377) (GET.FROMNODES 16381 . 16577) (
-GET.MOTHER.GROUP 16581 . 16785) (MAKE.MOTHER.NODE 16789 . 17307) (MAKE.NGROUP.NODELST 17311 . 17848) (
-GET.TONODES 17852 . 18042) (FIND.NODE 18046 . 18222)) (18266 31833 (INSERT.NGROUP 18278 . 19721) (
-VERIFY.NGROUP.ORDER 19725 . 21385) (ADD.NUMBER.GROUP 21389 . 22799) (ADD.NGROUP.TO.DBASE 22803 . 23454
-) (COLLECT.NGROUPS 23458 . 23884) (LIST.FONT.PROPS 23888 . 24139) (MAP.NGROUP.LOOKS 24143 . 24833) (
-NGROUP.GETFONT 24837 . 25067) (CHANGE.NGROUP 25071 . 25812) (CHANGE.NGROUP.FONT 25816 . 26765) (
-CHANGE.NGROUP.FORMAT 26769 . 28318) (CHANGE.NGROUP.CHARTYPE 28322 . 28949) (CHANGE.NGROUP.DELIMIT 
-28953 . 29755) (CHANGE.NGROUP.START 29759 . 30503) (CHANGE.NGROUP.ADDTOTOC 30507 . 31267) (
-TSP.GET.NGROUP.ARRAY 31271 . 31432) (TSP.LEGALID 31436 . 31830)) (31875 39290 (UPDATE.NUMBEROBJS 31887
- . 33206) (RESET.DEPENDENT.CLASSES 33210 . 33563) (RESET.NCOUNTER 33567 . 34089) (GET.NCOUNTER 34093
- . 34583) (NCOUNTER? 34587 . 35516) (LIST.ANCESTORS 35520 . 35938) (FLATTEN.TREE.TO.STRING 35942 . 
-37182) (NGROUP.CHARTYPE 37186 . 38274) (NUMBER.TO.LETTER 38278 . 38989) (REMOVE.ALL.COUNTERS 38993 . 
-39287)) (39334 44416 (TOC.ENABLED? 39346 . 39497) (GET.TOC.TEXTSTRING 39501 . 40412) (CREATE.TOC.FILE 
-40416 . 41696) (VIEW.TOC.FILE 41700 . 42519) (GET.TOC.FILE 42523 . 42942) (WRITE.TOC.FILE 42946 . 
-44413)))))
-STOP
diff --git a/obsolete/lispusers/NOTECARDS-4045XLPPATCH b/obsolete/lispusers/NOTECARDS-4045XLPPATCH
deleted file mode 100644
index 3e0b02b2..00000000
--- a/obsolete/lispusers/NOTECARDS-4045XLPPATCH
+++ /dev/null
@@ -1,47 +0,0 @@
-(FILECREATED "15-Dec-86 16:30:35" {DANTE}<SNOW>4045>V1.4>NOTECARDS-4045XLPPATCH.;2 1578   
-
-      changes to:  (FNS 4045XLP.NoteCardsAdvice)
-
-      previous date: "26-Sep-86 14:20:43" {DANTE}<SNOW>4045>V1.4>NOTECARDS-4045XLPPATCH.;1)
-
-
-(* Copyright (c) 1986 by Xerox Corporation and Will Snow. All rights reserved.)
-
-(PRETTYCOMPRINT NOTECARDS-4045XLPPATCHCOMS)
-
-(RPAQQ NOTECARDS-4045XLPPATCHCOMS ((FNS 4045XLP.NoteCardsAdvice)
-				     (P (4045XLP.NoteCardsAdvice))))
-(DEFINEQ
-
-(4045XLP.NoteCardsAdvice
-  [LAMBDA NIL                                                (* edited: "15-Dec-86 16:29")
-    [ADVISE (QUOTE NC.LinkIconDisplayFn)
-	      (QUOTE BEFORE)
-	      NIL
-	      (QUOTE (COND ((OR (NULL STREAMTYPE)
-				      (EQ STREAMTYPE (QUOTE 4045XLP)))
-				 (SETQ STREAMTYPE (QUOTE DISPLAY]
-    (ADVISE (QUOTE (STRINGWIDTH IN NC.LinkIconImageBoxFn))
-	      (QUOTE AFTER)
-	      NIL
-	      (QUOTE (AND (EQ (IMAGESTREAMTYPE ImageStream)
-				    (QUOTE 4045XLP))
-			      (RETURN (IQUOTIENT (STRINGWIDTH (CONCAT "nn"
-									      (if Label
-										  then
-										   (CONCAT "<" 
-											    Label ">")
-										else "")
-									      (if (AND Label 
-											   Title)
-										  then " "
-										else "")
-									      (OR Title ""))
-								    ImageStream)
-						     Scale])
-)
-(4045XLP.NoteCardsAdvice)
-(PUTPROPS NOTECARDS-4045XLPPATCH COPYRIGHT ("Xerox Corporation and Will Snow" 1986))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (478 1445 (4045XLP.NoteCardsAdvice 488 . 1443)))))
-STOP
diff --git a/obsolete/lispusers/NSALLOCATION b/obsolete/lispusers/NSALLOCATION
deleted file mode 100644
index a312c196..00000000
--- a/obsolete/lispusers/NSALLOCATION
+++ /dev/null
@@ -1,106 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-(FILECREATED "19-Feb-88 19:27:57" {QV}<BURWELL>LISP>NSALLOCATION.\;3 6361   
-
-      |changes| |to:|  (FNS NSALLOCATION.STATS NSALLOCATION)
-
-      |previous| |date:| "19-Feb-88 18:05:54" {QV}<BURWELL>LISP>NSALLOCATION.\;1)
-
-
-; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.
-
-(PRETTYCOMPRINT NSALLOCATIONCOMS)
-
-(RPAQQ NSALLOCATIONCOMS ((FNS NSALLOCATION NSALLOCATION.STATS)))
-(DEFINEQ
-
-(NSALLOCATION
-  (LAMBDA (|FileServers| |ReportFile| |Filter|)              (* \; "Edited 19-Feb-88 18:10 by bbb")
-
-    (LET ((|NSDiskSizeInPages| 433907)
-          |ReportFileStream|)
-         (CL:WITH-OPEN-FILE (|ReportFileStream| |ReportFile| :DIRECTION :OUTPUT)
-                (|if| |Filter|
-                    |then| (|printout| |ReportFileStream| "Using Filter " |Filter| T T))
-                (|printout| |ReportFileStream| .FONT '(TERMINAL 12) "File Service" .TAB 20 
-                       "# Pages Used" .TAB 35 "as %" .TAB 45 "# Pages Used" .TAB 60 "as %" .TAB 70 
-                       "# Pages" .TAB 80 "as %" .TAB 90 "Total % Used" T)
-                (|printout| |ReportFileStream| "Name" .TAB 20 "Unrestricted" .TAB 35 "of disk" .TAB 
-                       45 "Restricted" .TAB 60 "of alloc" .TAB 70 "alloc" .TAB 80 "of disk" .TAB 90 
-                       "of disk" T)
-                (|printout| |ReportFileStream| "----------------" .TAB 20 "------------" .TAB 35 
-                       "-------" .TAB 45 "------------" .TAB 60 "--------" .TAB 70 "-------" .TAB 80 
-                       "-------" .TAB 90 "------------" T)
-                (|printout| |ReportFileStream| T)
-                (|for| |Server| |in| |FileServers| |bind| |Result| |PagesUnrestricted| 
-                                                         |PagesRestricted| |PagesAllocated| 
-                                                         |PercentUnrestricted| 
-                                                         |PercentRestrictedofAllocated| 
-                                                         |PercentAllocated| |TotalPercentUsed|
-                   |when| (SETQ |Result| (NSALLOCATION.STATS |Server| |Filter|))
-                   |do| (SETQ |PagesUnrestricted| (CAR (NTH |Result| 1)))
-                        (SETQ |PagesRestricted| (CAR (NTH |Result| 2)))
-                        (SETQ |PagesAllocated| (CAR (NTH |Result| 3)))
-                        (SETQ |PercentUnrestricted| (TIMES (FQUOTIENT |PagesUnrestricted| 
-                                                                  |NSDiskSizeInPages|)
-                                                           100.0))
-                        (SETQ |PercentRestrictedofAllocated| (TIMES (FQUOTIENT |PagesRestricted| 
-                                                                           |PagesAllocated|)
-                                                                    100.0))
-                        (SETQ |PercentAllocated| (TIMES (FQUOTIENT |PagesAllocated| 
-                                                               |NSDiskSizeInPages|)
-                                                        100.0))
-                        (SETQ |TotalPercentUsed| (TIMES (FQUOTIENT (PLUS |PagesUnrestricted| 
-                                                                         |PagesRestricted|)
-                                                               |NSDiskSizeInPages|)
-                                                        100.0))
-                        (|printout| |ReportFileStream| |Server| .TAB 20 |.I12| |PagesUnrestricted| 
-                               .TAB 35 |.F7.1| |PercentUnrestricted| .TAB 45 |.I12| |PagesRestricted| 
-                               .TAB 60 |.F8.2| |PercentRestrictedofAllocated| .TAB 70 |.I7| 
-                               |PagesAllocated| .TAB 80 |.F7.1| |PercentAllocated| .TAB 90 |.F12.1| 
-                               |TotalPercentUsed| T))))))
-
-(NSALLOCATION.STATS
-  (LAMBDA (|FileServiceName| |Filter|)                       (* \; "Edited 19-Feb-88 19:20 by bbb")
-          
-          (* |;;| 
-          "Given a file service name the following three pieces of data are returned in a list: ")
-          
-          (* |;;| " 1) number of pages in use of unrestricted file drawers")
-          
-          (* |;;| " 2) number of pages in use in restricted file drawers")
-          
-          (* |;;| " 3) number of pages allocated to file drawers")
-          
-          (* |;;| "")
-          
-          (* |;;| " If Filter is NON-NIL then it is used as a file pattern for selecting directories")
-
-    (LET* ((|FileServiceDirectories| (DIRECTORY (CONCAT "{" |FileServiceName| "}")
-                                            'COLLECT))
-           (|FileServiceDevice| (\\GETDEVICEFROMNAME |FileServiceName|))
-           (|NumBytesUnrestricted| 0)
-           (|NumBytesRestricted| 0)
-           (|NumBytesAllocated| 0)
-           (|BytesPerPage| 512)
-           (|Filter| (|if| |Filter|
-                         |then| (DIRECTORY.MATCH.SETUP |Filter|))))
-          (|for| |Directory| |in| |FileServiceDirectories| |bind| |DirectoryAllocation| 
-                                                                 |DirectoryUsed|
-             |when| (OR (NULL |Filter|)
-                        (DIRECTORY.MATCH |Filter| |Directory|))
-             |do| (SETQ |DirectoryAllocation| (\\NSFILING.GETFILEINFO |Directory| 'SUBTREE.SIZE.LIMIT 
-                                                     |FileServiceDevice|))
-                  (SETQ |DirectoryUsed| (\\NSFILING.GETFILEINFO |Directory| 'SUBTREE.SIZE 
-                                               |FileServiceDevice|))
-                  (|if| (IGEQ |DirectoryAllocation| 0)
-                      |then| (|add| |NumBytesAllocated| |DirectoryAllocation|)
-                            (|add| |NumBytesRestricted| |DirectoryUsed|)
-                    |else| (|add| |NumBytesUnrestricted| |DirectoryUsed|)))
-          (LIST (FQUOTIENT |NumBytesUnrestricted| |BytesPerPage|)
-                (FQUOTIENT |NumBytesRestricted| |BytesPerPage|)
-                (FQUOTIENT |NumBytesAllocated| |BytesPerPage|)))))
-)
-(PUTPROPS NSALLOCATION COPYRIGHT ("Xerox Corporation" 1988))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL (457 6277 (NSALLOCATION 467 . 3985) (NSALLOCATION.STATS 3987 . 6275)))))
-STOP
diff --git a/obsolete/lispusers/NSCOPYFILE b/obsolete/lispusers/NSCOPYFILE
deleted file mode 100644
index 8c4f0ab1..00000000
--- a/obsolete/lispusers/NSCOPYFILE
+++ /dev/null
@@ -1,37 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED "10-Dec-87 11:40:53" {ERIS}<VANMELLE>LISP>NSCOPYFILE.;3 2187   
-
-      changes to%:  (FNS NSCOPYFILE)
-
-      previous date%: " 9-Oct-87 17:35:59" {ERIS}<VANMELLE>LISP>NSCOPYFILE.;2)
-
-
-(* "
-Copyright (c) 1987 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT NSCOPYFILECOMS)
-
-(RPAQQ NSCOPYFILECOMS ((FNS NSCOPYFILE) (PROP FILETYPE NSCOPYFILE) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE COPYFILE) (QUOTE \GENERIC.COPYFILE)) (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)) (AND (CCODEP (QUOTE \NSFILING.COPYFILE)) (CCODEP (QUOTE NSCOPYFILE)) (MOVD (QUOTE NSCOPYFILE) (QUOTE COPYFILE) NIL T)))))
-)
-(DEFINEQ
-
-(NSCOPYFILE
-(LAMBDA (FROMFILE TOFILE DESTPARAMETERS) (* ; "Edited 10-Dec-87 11:40 by bvm:") (* ;; "Special version of COPYFILE that lets NS servers do efficient or information-preserving copy.  Perhaps COPYFILE will be a device method some day.") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FROMDEV TODEV) (if (AND (NULL DESTPARAMETERS) (NOT (NULL TOFILE)) (NEQ TOFILE T) (SETQ FROMDEV (\GETDEVICEFROMNAME (SETQ FROMFILE (\ADD.CONNECTED.DIR (if (TYPEP FROMFILE (QUOTE PATHNAME)) then (\CONVERT-PATHNAME FROMFILE) else FROMFILE))))) (EQ (fetch (FDEV OPENFILE) of FROMDEV) (FUNCTION \NSFILING.OPENFILE)) (SETQ TODEV (\GETDEVICEFROMNAME (SETQ TOFILE (\ADD.CONNECTED.DIR (if (TYPEP TOFILE (QUOTE PATHNAME)) then (\CONVERT-PATHNAME TOFILE) else TOFILE))))) (EQ (fetch (FDEV OPENFILE) of TODEV) (FUNCTION \NSFILING.OPENFILE))) then (* ; "Both source and destination are NS servers.") (\NSFILING.COPYFILE FROMDEV FROMFILE TODEV TOFILE) else (\GENERIC.COPYFILE FROMFILE TOFILE DESTPARAMETERS))))
-)
-)
-
-(PUTPROPS NSCOPYFILE FILETYPE :COMPILE-FILE)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(LOCALVARS . T)
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-(MOVD? (QUOTE COPYFILE) (QUOTE \GENERIC.COPYFILE))
-(AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM))
-(AND (CCODEP (QUOTE \NSFILING.COPYFILE)) (CCODEP (QUOTE NSCOPYFILE)) (MOVD (QUOTE NSCOPYFILE) (QUOTE COPYFILE) NIL T))
-)
-(PUTPROPS NSCOPYFILE COPYRIGHT ("Xerox Corporation" 1987))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (738 1735 (NSCOPYFILE 748 . 1733)))))
-STOP
diff --git a/obsolete/lispusers/NSCOPYFILE.LCOM b/obsolete/lispusers/NSCOPYFILE.LCOM
deleted file mode 100644
index dd322f14..00000000
Binary files a/obsolete/lispusers/NSCOPYFILE.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/NSCOPYFILE.TEDIT b/obsolete/lispusers/NSCOPYFILE.TEDIT
deleted file mode 100644
index 95bc9dd9..00000000
Binary files a/obsolete/lispusers/NSCOPYFILE.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/NSREADERPATCH b/obsolete/lispusers/NSREADERPATCH
deleted file mode 100644
index 092afe8c..00000000
--- a/obsolete/lispusers/NSREADERPATCH
+++ /dev/null
@@ -1,19 +0,0 @@
-(FILECREATED "18-Jun-86 16:14:22" {ERIS}<LISPUSERS>LISPCORE>NSREADERPATCH.;1 577    
-
-      changes to:  (VARS NSREADERPATCHCOMS))
-
-
-(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT NSREADERPATCHCOMS)
-
-(RPAQQ NSREADERPATCHCOMS [(ADDVARS (FILEINFOTYPES (READER 11))
-                                 (\LISP.TO.NSFILING.ATTRIBUTES (READER READ.BY])
-
-(ADDTOVAR FILEINFOTYPES (READER 11))
-
-(ADDTOVAR \LISP.TO.NSFILING.ATTRIBUTES (READER READ.BY))
-(PUTPROPS NSREADERPATCH COPYRIGHT ("Xerox Corporation" 1986))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
diff --git a/obsolete/lispusers/NSROUTINGHASH b/obsolete/lispusers/NSROUTINGHASH
deleted file mode 100644
index fcbb9d36..00000000
--- a/obsolete/lispusers/NSROUTINGHASH
+++ /dev/null
@@ -1,206 +0,0 @@
-(FILECREATED " 7-Feb-89 23:16:44" {ERINYES}<LISPUSERS>KOTO>NSROUTINGHASH.;2 13641  
-
-      changes to:  (RECORDS NSROUTINGINFO) (VARS NSROUTINGHASHCOMS)
-
-      previous date: "11-Jan-88 21:27:31" {ERINYES}<LISPUSERS>KOTO>NSROUTINGHASH.;1)
-
-
-(* Copyright (c) 1987, 1988, 1989 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT NSROUTINGHASHCOMS)
-
-(RPAQQ NSROUTINGHASHCOMS ((FNS \AGE.ROUTING.TABLE.HASH \HANDLE.NS.ROUTING.INFO.NEW 
-\HANDLE.RAW.XIP.NEW \LOCATE.NSNET.NEW \FLUSHNDBS.NEW \MAP.ROUTING.TABLE.NEW \NSGATELISTENER.NEW 
-\NSROUTING.HASHBITSFN \NSROUTING.EQUIVFN PRINTROUTINGTABLE) (GLOBALVARS \NS.ROUTING.TABLE) (* * 
-LOADCOMP LLNS *before* loading this module so that this record declaration is in effect) (RECORDS 
-NSROUTINGINFO) (FNS INSTALL UNINSTALL) (* installation utilities) (COMS (* debugging tools) (FNS 
-ROUTINGPROBE)) (DECLARE: DONTEVAL@LOAD DOCOPY (P (UNINTERRUPTABLY (INSTALL (QUOTE \FLUSHNDBS)) (
-INSTALL (QUOTE \MAP.ROUTING.TABLE)) (INSTALL (QUOTE \HANDLE.NS.ROUTING.INFO)) (INSTALL (QUOTE 
-\LOCATE.NSNET)) (INSTALL (QUOTE \HANDLE.RAW.XIP)) (INSTALL (QUOTE \NSGATELISTENER)) (RESTART.ETHER) (
-\LOCATE.NSNET -1))))))
-(DEFINEQ
-
-(\AGE.ROUTING.TABLE.HASH
-(LAMBDA (TABLE) (* ; "Edited 21-Jun-87 23:23 by BRIGGS") (MAPHASH TABLE (FUNCTION (LAMBDA (ENTRY KEY) 
-(if (if (AND (NEQ (fetch RTHOPCOUNT of ENTRY) 0) (TIMEREXPIRED? (fetch RTTIMER of ENTRY))) then (COND 
-((fetch RTRECENT of ENTRY) (* New entry, make it old) (replace RTRECENT of ENTRY with NIL) (SETUPTIMER
- \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY)) NIL) (T \RT.PURGEFLG))) then (PUTHASH KEY NIL TABLE))))
-)))
-
-(\HANDLE.NS.ROUTING.INFO.NEW
-(LAMBDA (XIP) (* edited: "11-Jan-88 20:48") (* ; "Edited 21-Jun-87 23:11 by BRIGGS") (* Processes a 
-routing info XIP) (COND ((EQ (fetch XIPFIRSTDATAWORD of XIP) \XROUTINGINFO.OP.RESPONSE) (* Unless 
-we're a gateway, we only handle responses) (PROG ((HOST (fetch XIPSOURCEHOST of XIP)) (NDB (fetch 
-EPNETWORK of XIP)) (LENGTH (SUB1 (FOLDLO (IDIFFERENCE (fetch XIPLENGTH of XIP) \XIPOVLEN) BYTESPERWORD
-))) (BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) ENTRY NET HOPS NETHASH) (COND ((NEQ (fetch NETTYPE 
-of NDB) 10) (OR (SETQ HOST (\TRANSLATE.10TO3 HOST NDB)) (RETURN)))) (SETQ \NSROUTER.PROBECOUNT 0) (
-while (IGEQ LENGTH \NS.ROUTINGINFO.WORDS) do (SETQ HOPS (fetch (NSROUTINGINFO #HOPS) of BASE)) (COND (
-(OR (SETQ ENTRY (GETHASH BASE \NS.ROUTING.TABLE)) (COND ((ILEQ HOPS \NS.ROUTING.TABLE.RADIUS) (SETQ 
-NET (fetch (NSROUTINGINFO NET#) of BASE)) (PUTHASH NET (SETQ ENTRY (create ROUTING RTNET# _ NET 
-RTTIMER _ (SETUPTIMER 0))) \NS.ROUTING.TABLE) T))) (* Update the entry if this entry not for directly 
-connected net and - current entry timed out, or - new gateway same as old, or - new route has fewer 
-hops than old) (COND ((AND (NEQ (fetch RTHOPCOUNT of ENTRY) 0) (OR (NOT (fetch RTRECENT of ENTRY)) (
-AND (EQUAL HOST (fetch RTGATEWAY# of ENTRY)) (EQ NDB (fetch RTNDB of ENTRY))) (ILESSP HOPS (fetch 
-RTHOPCOUNT of ENTRY)))) (replace RTGATEWAY# of ENTRY with HOST) (replace RTNDB of ENTRY with NDB) (
-replace RTHOPCOUNT of ENTRY with HOPS) (COND ((ILESSP HOPS \RT.INFINITY) (replace RTRECENT of ENTRY 
-with T) (SETUPTIMER \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY)))))))) (SETQ LENGTH (IDIFFERENCE 
-LENGTH \NS.ROUTINGINFO.WORDS)) (SETQ BASE (\ADDBASE BASE \NS.ROUTINGINFO.WORDS)))))) (
-\RELEASE.ETHERPACKET XIP)))
-
-(\HANDLE.RAW.XIP.NEW
-(LAMBDA (XIP TYPE) (* edited: "11-Jan-88 20:47") (* N.H.Briggs "21-Jun-87 23:53") (* Handles the 
-arrival of a raw XIP. If it is destined for a local socket that has room for it, we queue it up, else 
-release it) (COND ((EQ TYPE \EPT.XIP) (PROG (NSOC CSUM NDB DESTNET MYNET) (COND ((NULL \NS.READY) (
-RETURN (RELEASE.XIP XIP)))) (COND ((AND (NOT (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) 
-\MY.NSHOSTNUMBER)) (NOT (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) BROADCASTNSHOSTNUMBER))) (* Not for
- us) (RETURN (\FORWARD.XIP XIP)))) (SETQ NDB (fetch EPNETWORK of XIP)) (COND ((AND (NOT (IEQP (SETQ 
-DESTNET (fetch XIPDESTNET of XIP)) (SETQ MYNET (fetch NDBNSNET# of NDB)))) (NEQ MYNET 0) (NEQ DESTNET 
-0)) (* explicitly for a net other than us) (RETURN (\FORWARD.XIP XIP)))) (COND ((NULL (SETQ NSOC (
-\NSOCKET.FROM# (fetch XIPDESTSOCKET of XIP)))) (* Packets addressed to non-active sockets are just 
-ignored.) (COND (XIPTRACEFLG (PRIN1 (QUOTE '&) XIPTRACEFILE))) (PROG (XIPBASE) (COND ((AND (EQ (fetch 
-XIPTYPE of XIP) \XIPT.ECHO) (EQ (fetch XIPDESTSOCKET of XIP) \NS.WKS.Echo) (EQ (\GETBASE (SETQ XIPBASE
- (fetch XIPCONTENTS of XIP)) 0) \XECHO.OP.REQUEST)) (* Play echo server) (COND ((AND (NEQ (SETQ CSUM (
-fetch XIPCHECKSUM of XIP)) MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 (
-FOLDHI (fetch XIPLENGTH of XIP) BYTESPERWORD))))) (\XIPERROR XIP \XIPE.CHECKSUM)) (T (\PUTBASE XIPBASE
- 0 \XECHO.OP.REPLY) (SWAPXIPADDRESSES XIP) (replace EPREQUEUE of XIP with (QUOTE FREE)) (SENDXIP NIL 
-XIP)))) (T (\XIPERROR XIP \XIPE.NOSOCKET))))) ((IGEQ (fetch (NSOCKET INQUEUELENGTH) of NSOC) (fetch (
-NSOCKET NSOC#ALLOCATION) of NSOC)) (* Note that packets are just "dropped" when the queue overflows.) 
-(\XIPERROR XIP \XIPE.SOCKETFULL)) ((AND \NS.CHECKSUMFLG (NEQ (SETQ CSUM (fetch XIPCHECKSUM of XIP)) 
-MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 (FOLDHI (fetch XIPLENGTH of XIP
-) BYTESPERWORD))))) (\XIPERROR XIP \XIPE.CHECKSUM)) (T (COND ((EQ DESTNET 0) (* Fill in unspecified 
-destination net (possibly redundantly with zero)) (replace XIPDESTNET of XIP with MYNET)) ((EQ MYNET 0
-) (* Packet of specific destination net has arrived on a socket that we listen to. If we don't know 
-our own net number, assume sender is telling the truth) (replace NDBNSNET# of NDB with DESTNET) (
-replace NSNET of \MY.NSADDRESS with (SETQ \MY.NSNETNUMBER DESTNET)) (PROG ((ENTRY (\LOCATE.NSNET 
-DESTNET T))) (OR ENTRY (PUTHASH DESTNET (SETQ ENTRY (create ROUTING RTNET# _ DESTNET)) 
-\NS.ROUTING.TABLE)) (replace RTHOPCOUNT of ENTRY with 0) (replace RTGATEWAY# of ENTRY with NIL) (
-replace RTNDB of ENTRY with NDB) (replace RTRECENT of ENTRY with T)))) (UNINTERRUPTABLY (\ENQUEUE (
-fetch (NSOCKET INQUEUE) of NSOC) XIP) (add (fetch (NSOCKET INQUEUELENGTH) of NSOC) 1) (NOTIFY.EVENT (
-fetch NSOCEVENT of NSOC)))))) T))))
-
-(\LOCATE.NSNET.NEW
-(LAMBDA (NET DONTPROBE) (* edited: "11-Jan-88 20:49") (* N.H.Briggs "21-Jun-87 23:54") (LET ((DATA (
-GETHASH NET \NS.ROUTING.TABLE))) (if DATA then (AND (ILESSP (fetch RTHOPCOUNT of DATA) \RT.INFINITY) 
-DATA) elseif (NOT DONTPROBE) then (PUTHASH NET (create ROUTING RTNET# _ NET RTHOPCOUNT _ \RT.INFINITY 
-RTTIMER _ (SETUPTIMER 30000)) \NS.ROUTING.TABLE) (* Insert an entry for the net, to be purged in 30 
-sec if router process hasn't filled it by then) (SETQ \NSROUTER.PROBECOUNT 5) (SETQ 
-\NSROUTER.PROBETIMER (SETUPTIMER 0 \NSROUTER.PROBETIMER)) (WAKE.PROCESS (QUOTE \NSGATELISTENER)) (
-BLOCK) (* ;; "return NIL in this case to indicate we didn't find it yet.") NIL))))
-
-(\FLUSHNDBS.NEW
-(LAMBDA (EVENT) (* edited: "11-Jan-88 21:20") (* bvm: " 4-AUG-83 22:51") (bind NDB QUEUE while (SETQ 
-NDB \LOCALNDBS) do (SETQ \LOCALNDBS (fetch NDBNEXT of NDB)) (replace NDBNEXT of NDB with NIL) (COND ((
-EQ EVENT (QUOTE RESTART)) (APPLY* (fetch NDBETHERFLUSHER of NDB) NDB))) (DEL.PROCESS (fetch NDBWATCHER
- of NDB)) (replace NDBWATCHER of NDB with (replace NDBTRANSLATIONS of NDB with NIL)) (COND ((SETQ 
-QUEUE (fetch NDBTQ of NDB)) (\FLUSH.NDB.QUEUE QUEUE EVENT (QUOTE OUTPUT)) (* Don't do this just yet, 
-because of possible race in \PUPGATELISTENER - (replace NDBTQ of NDB with NIL)))) (COND ((SETQ QUEUE (
-fetch NDBIQ of NDB)) (\FLUSH.NDB.QUEUE QUEUE EVENT (QUOTE INPUT)) (replace NDBIQ of NDB with NIL)))) (
-SETQ \PUP.ROUTING.TABLE (CONS)) (SETQ \NS.ROUTING.TABLE (HASHARRAY 100 50 (FUNCTION 
-\NSROUTING.HASHBITSFN) (FUNCTION \NSROUTING.EQUIVFN)))))
-
-(\MAP.ROUTING.TABLE.NEW
-(LAMBDA (TABLE MAPFN) (* edited: "11-Jan-88 20:53") (* bvm: "22-SEP-83 14:21") (if (HARRAYP TABLE) 
-then (MAPHASH TABLE MAPFN) else (for ENTRY in (APPEND (CDR (OR TABLE \PUP.ROUTING.TABLE))) do (APPLY* 
-MAPFN ENTRY)))))
-
-(\NSGATELISTENER.NEW
-(LAMBDA NIL (* edited: "11-Jan-88 20:47") (* ; "Edited 16-Jun-87 15:32 by BRIGGS") (PROG ((NSOC (
-OPENNSOCKET \NS.WKS.RoutingInformation T)) (TIMER (SETUPTIMER 0)) EVENT XIP BASE) (SETQ EVENT (fetch 
-NSOCEVENT of NSOC)) LP (COND ((SETQ XIP (GETXIP NSOC)) (\HANDLE.NS.ROUTING.INFO XIP) (BLOCK)) ((EQ (
-AWAIT.EVENT EVENT (COND ((IGREATERP \NSROUTER.PROBECOUNT 0) \NSROUTER.PROBETIMER) (T TIMER)) T) EVENT)
- (GO LP))) (COND ((TIMEREXPIRED? TIMER) (\AGE.ROUTING.TABLE.HASH \NS.ROUTING.TABLE) (SETUPTIMER 
-\RT.AGEINTERVAL TIMER))) (COND ((AND (IGREATERP \NSROUTER.PROBECOUNT 0) (TIMEREXPIRED? 
-\NSROUTER.PROBETIMER)) (* Routing info desired. Broadcast a routing request on each directly-connected
- net) (SETQ XIP (\FILLINXIP \XIPT.ROUTINGINFO NSOC BROADCASTNSHOSTNUMBER \NS.WKS.RoutingInformation 0 
-(IPLUS \XIPOVLEN BYTESPERWORD (UNFOLD \NS.ROUTINGINFO.WORDS BYTESPERWORD)))) (replace XIPFIRSTDATAWORD
- of XIP with \XROUTINGINFO.OP.REQUEST) (SETQ BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) (replace (
-NSROUTINGINFO NET#) of BASE with -1) (replace (NSROUTINGINFO #HOPS) of BASE with \RT.INFINITY) (
-SENDXIP NSOC XIP) (SETUPTIMER \NSROUTER.PROBEINTERVAL \NSROUTER.PROBETIMER) (SETQ \NSROUTER.PROBECOUNT
- (SUB1 \NSROUTER.PROBECOUNT)))) (GO LP))))
-
-(\NSROUTING.HASHBITSFN
-(LAMBDA (OBJECT) (* ; "Edited 21-Jun-87 23:08 by BRIGGS") (SELECTQ (TYPENAME OBJECT) (ETHERPACKET (* ;
- "a piece of a routing table packet") (LOGXOR (fetch (NSROUTINGINFO NET#-HI) of OBJECT) (fetch (
-NSROUTINGINFO NET#-LO) of OBJECT))) (SMALLP (* ; "a net as a small number") OBJECT) (FIXP (* ; 
-"a net as a number") (LOGXOR (\GETBASE OBJECT 0) (\GETBASE OBJECT 1))) (ERROR 
-"Illegal arg (neither FIXP, SMALLP, nor ETHERPACKET)" OBJECT))))
-
-(\NSROUTING.EQUIVFN
-(LAMBDA (X Y) (* N.H.Briggs "22-Jun-87 14:34") (SELECTQ (TYPENAME X) (ETHERPACKET (SELECTQ (TYPENAME Y
-) (SMALLP (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) 0) (EQ (fetch (NSROUTINGINFO NET#-LO) of X) Y)
-)) (FIXP (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) (\GETBASE Y 0)) (EQ (fetch (NSROUTINGINFO 
-NET#-LO) of X) (\GETBASE Y 1)))) (ETHERPACKET (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) (fetch (
-NSROUTINGINFO NET#-HI) of Y)) (EQ (fetch (NSROUTINGINFO NET#-LO) of X) (fetch (NSROUTINGINFO NET#-LO) 
-of Y)))) NIL)) (SMALLP (SELECTQ (TYPENAME Y) (SMALLP (EQ X Y)) (FIXP (EQUAL X Y)) (ETHERPACKET (AND (
-EQ (fetch (NSROUTINGINFO NET#-HI) of Y) 0) (EQ (fetch (NSROUTINGINFO NET#-LO) of Y) X))) NIL)) (FIXP (
-SELECTQ (TYPENAME Y) ((SMALLP FIXP) (EQUAL X Y)) (ETHERPACKET (AND (EQ (fetch (NSROUTINGINFO NET#-HI) 
-of Y) (\GETBASE X 0)) (EQ (fetch (NSROUTINGINFO NET#-LO) of Y) (\GETBASE X 1)))) NIL)) NIL)))
-
-(PRINTROUTINGTABLE
-(LAMBDA (TABLE SORT? FILE) (* edited: "11-Jan-88 21:25") (* N.H.Briggs "14-Dec-87 12:17") (PROG (
-HASHENTRIES) (SELECTQ TABLE (NS (MAPHASH \NS.ROUTING.TABLE (FUNCTION (LAMBDA (X) (push HASHENTRIES X))
-)) (SETQ TABLE (CONS NIL HASHENTRIES))) ((NIL PUP) (SETQ TABLE \PUP.ROUTING.TABLE)) NIL) (RESETFORM (
-RADIX 8) (printout FILE "   Net#   Gateway           #Hops   Recent?" T) (for ENTRY in (COND (SORT? (
-SORT (APPEND (CDR TABLE)) (if (EQ SORT? (QUOTE HOPS)) then (FUNCTION (LAMBDA (X Y) (ILESSP (fetch 
-RTHOPCOUNT of X) (fetch RTHOPCOUNT of Y)))) else T))) (T (CDR TABLE))) bind GATE do (printout FILE 
-.I6.8 (fetch RTNET# of ENTRY)) (COND ((NOT (SETQ GATE (fetch RTGATEWAY# of ENTRY))) (PRIN1 
-"      ---  " FILE)) ((FIXP GATE) (printout FILE .I9.8 GATE)) (T (SPACES 2 FILE) (PRINTNSHOSTNUMBER 
-GATE FILE))) (printout FILE 30 .I2 (fetch RTHOPCOUNT of ENTRY) (COND ((fetch RTRECENT of ENTRY) 
-"     Yes") ((TIMEREXPIRED? (fetch RTTIMER of ENTRY)) "  timed out") (T "     No")) T)) (TERPRI FILE))
-)))
-)
-(DECLARE: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \NS.ROUTING.TABLE)
-)
-(* * LOADCOMP LLNS *before* loading this module so that this record declaration is in effect)
-
-[DECLARE: EVAL@COMPILE 
-
-(BLOCKRECORD NSROUTINGINFO ((* Format of each entry in a routing info packet, the hashing code relys
- on the fact that the net number comes first.) (NET#-HI WORD) (NET#-LO WORD) (#HOPS WORD)) (ACCESSFNS 
-((NET# (\GETBASEFIXP DATUM 0) (\PUTBASEFIXP DATUM 0 NEWVALUE)))))
-]
-(DEFINEQ
-
-(INSTALL
-(LAMBDA (FN) (* ; "Edited 21-Jun-87 22:08 by BRIGGS") (if (NOT (GETD (MKATOM (CONCAT FN ".OLD")))) 
-then (MOVD FN (MKATOM (CONCAT FN ".OLD")) NIL T)) (MOVD (MKATOM (CONCAT FN ".NEW")) FN NIL T)))
-
-(UNINSTALL
-(LAMBDA (FN) (* ; "Edited 21-Jun-87 22:08 by BRIGGS") (if (GETD (MKATOM (CONCAT FN ".OLD"))) then (
-MOVD (MKATOM (CONCAT FN ".OLD")) FN NIL T))))
-)
-
-
-
-(* installation utilities)
-
-
-
-
-(* debugging tools)
-
-(DEFINEQ
-
-(ROUTINGPROBE
-(LAMBDA NIL (* ; "Edited 17-Jun-87 18:16 by BRIGGS") (LET ((NSOC (OPENNSOCKET 
-\NS.WKS.RoutingInformation T)) XIP BASE) (SETQ XIP (\FILLINXIP \XIPT.ROUTINGINFO NSOC 
-BROADCASTNSHOSTNUMBER \NS.WKS.RoutingInformation 0 (IPLUS \XIPOVLEN BYTESPERWORD (UNFOLD 
-\NS.ROUTINGINFO.WORDS BYTESPERWORD)))) (replace XIPFIRSTDATAWORD of XIP with \XROUTINGINFO.OP.REQUEST)
- (SETQ BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) (replace (NSROUTINGINFO NET#) of BASE with -1) (
-replace (NSROUTINGINFO #HOPS) of BASE with \RT.INFINITY) (SENDXIP NSOC XIP))))
-)
-(DECLARE: DONTEVAL@LOAD DOCOPY 
-(UNINTERRUPTABLY (INSTALL (QUOTE \FLUSHNDBS)) (INSTALL (QUOTE \MAP.ROUTING.TABLE)) (INSTALL (QUOTE 
-\HANDLE.NS.ROUTING.INFO)) (INSTALL (QUOTE \LOCATE.NSNET)) (INSTALL (QUOTE \HANDLE.RAW.XIP)) (INSTALL (
-QUOTE \NSGATELISTENER)) (RESTART.ETHER) (\LOCATE.NSNET -1))
-)
-(PUTPROPS NSROUTINGHASH COPYRIGHT ("Xerox Corporation" 1987 1988 1989))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (1158 11765 (\AGE.ROUTING.TABLE.HASH 1168 . 1612) (\HANDLE.NS.ROUTING.INFO.NEW 1614 . 
-3371) (\HANDLE.RAW.XIP.NEW 3373 . 6241) (\LOCATE.NSNET.NEW 6243 . 6939) (\FLUSHNDBS.NEW 6941 . 7817) (
-\MAP.ROUTING.TABLE.NEW 7819 . 8066) (\NSGATELISTENER.NEW 8068 . 9335) (\NSROUTING.HASHBITSFN 9337 . 
-9803) (\NSROUTING.EQUIVFN 9805 . 10738) (PRINTROUTINGTABLE 10740 . 11763)) (12235 12617 (INSTALL 12245
- . 12453) (UNINSTALL 12455 . 12615)) (12681 13250 (ROUTINGPROBE 12691 . 13248)))))
-STOP
diff --git a/obsolete/lispusers/NSTHASIZE b/obsolete/lispusers/NSTHASIZE
deleted file mode 100644
index d282cebf..00000000
--- a/obsolete/lispusers/NSTHASIZE
+++ /dev/null
@@ -1,256 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED " 3-Mar-89 18:17:39" {ERINYES}<LISPUSERS>MEDLEY>NSTHASIZE.;1 13450  
-
-      changes to%:  (FNS NSTHASIZE)
-                    (VARS NSTHASIZECOMS)
-
-      previous date%: " 8-Apr-86 09:09:30" {DSK}/usr/local/koto/lispusers/nsthasize.;1)
-
-
-(* "
-Copyright (c) 1986, 1989 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT NSTHASIZECOMS)
-
-(RPAQQ NSTHASIZECOMS ((INITVARS (GV.TO.NS.REG))
-                          (FNS CONVERT.GV.TO.NS GV.READFORWARDING READ-GV-NS-MAPPING NSTHASIZE 
-                               \GETSTRING \GV.COLLECT.ENTRY \GV.COLLECT.ENTRY.1 
-                               \GV.COLLECT.ENTRY.LIST)
-                          (FILES (LOADCOMP)
-                                 MAINTAIN)))
-
-(RPAQ? GV.TO.NS.REG )
-(DEFINEQ
-
-(CONVERT.GV.TO.NS
-  [LAMBDA (X)                                            (* lmm " 7-Apr-86 16:23")
-    (COND
-       ((SETQ X (\CHECKNAME X))
-        (PROG ([REG (MKATOM (U-CASE (CDR X]
-               NSREG)
-              (RETURN (if (EQ REG 'NS)
-                          then (OR (CH.LOOKUP.OBJECT (SUBSTRING (CAR X)
-                                                                2 -2))
-                                       (PROGN (PRINTOUT T "[Unable to check " X 
-                                                     " in clearinghouse, assuming correct]")
-                                              (SUBSTRING (CAR X)
-                                                     2 -2)))
-                        else (OR (SETQ NSREG (ASSOC REG GV.TO.NS.REG))
-                                     (RETURN))
-                              (LET (NAME)
-                                   (OR [CH.LOOKUP.OBJECT (SETQ NAME (CONCAT (CAR X)
-                                                                           ":"
-                                                                           (CDR NSREG]
-                                       (PROGN (PRINTOUT T "[Unable to check " NAME 
-                                                     " in clearinghouse, assuming correct]")
-                                              NAME])
-
-(GV.READFORWARDING
-  [LAMBDA (X)                                            (* lmm "19-Nov-85 11:20")
-    (CDR (ASSOC 'Forwarding (GV.READENTRY X NIL '\GV.COLLECT.ENTRY])
-
-(READ-GV-NS-MAPPING
-  [LAMBDA NIL                                            (* lmm " 4-Apr-86 16:56")
-    (SETQ GV.TO.NS.REG
-     (RESETLST
-         (PROG ((STREAM (OPENSTREAM '{INDIGO}<REGISTRAR>GV>GV-NS-MAPPING.TXT 'INPUT 'OLD))
-                (RT (COPYREADTABLE 'ORIG))
-                LINES)
-           RESTART
-               (RESETSAVE NIL (LIST 'CLOSEF? STREAM))
-               (SETSEPR NIL NIL RT)
-               (SETBRK (CHARCODE (CR))
-                      NIL RT)
-               (OR (FFILEPOS "GV-to-NS Mappings:" STREAM 0 NIL NIL T)
-                   (ERROR "Couldn't find string GV-to-NS Mappings in " (FULLNAME STREAM)))
-               (FILEPOS "	" STREAM)
-               [RETURN
-                (do (SELCHARQ (BIN STREAM)
-                             (TAB)
-                             (CR (RETURN LINES))
-                             (%. [LET ((LINE (RSTRING STREAM RT)))
-                                      (PRINTOUT T LINE T)
-                                      (push LINES (LET ((POS (STRPOS " -> " LINE)))
-                                                           (OR POS (GO BADFORMAT))
-                                                           (CONS [MKATOM (U-CASE (SUBSTRING
-                                                                                  LINE 1 (SUB1 POS]
-                                                                 (SUBSTRING LINE (PLUS POS 4)
-                                                                        -1]
-                                 (BIN STREAM))
-                             (GO BADFORMAT]
-           BADFORMAT
-               (ERROR "bad format on {INDIGO}<Registrar>GV>GV-NS-MAPPING.TXT")))])
-
-(NSTHASIZE
-  [LAMBDA (GVDL NSDL NODELETE)                        (* ; "Edited  3-Mar-89 18:16 by masinter")
-    (OR GV.TO.NS.REG (PROGN (PRIN1 "Reading gv to ns mapping ...")
-                            (READ-GV-NS-MAPPING)))   (* lmm " 8-Apr-86 09:03")
-    (SETQ GVDL (OR (\CHECKNAME GVDL)
-                   (ERROR "Invalid grapevine group" GVDL)))
-    (SETQ NSDL (OR (CH.LOOKUP.OBJECT NSDL)
-                   (ERROR "Invalid NS distribution list" NSDL)))
-    (LET
-     (FORWARDING NSADDRESS)
-     (for X in (CDR (GV.READMEMBERS GVDL))
-        do (if (OR (COND
-                              ((SETQ NSADDRESS (CONVERT.GV.TO.NS X))
-                               (PRINTOUT T X)
-                               T))
-                           (AND (SETQ FORWARDING (GV.READFORWARDING X))
-                                (PROGN (PRINTOUT T X " => " FORWARDING)
-                                       (if (CDR FORWARDING)
-                                           then (PRINTOUT T " -- more than one address." T)
-                                                 NIL
-                                         else T))
-                                (if [NOT (SETQ NSADDRESS (CONVERT.GV.TO.NS (CAR FORWARDING]
-                                    then (PRINTOUT T " not an NS equivalent address." T)
-                                          NIL
-                                  else T)))
-                   then (PRINTOUT T " => " NSADDRESS "...")
-                         (PROG (VALUE)
-                           LP  (if (OR (type? NSNAME (SETQ VALUE (CH.ADD.MEMBER NSDL
-                                                                                'MEMBERS NSADDRESS)))
-                                           (MATCH VALUE WITH (%'ERROR %'UPDATE.ERROR %'NoChange 
-                                                                        --)))
-                                   then (if (AND NODELETE (OR (NEQ NODELETE 'FIRST)
-                                                                      (NLISTP VALUE)))
-                                                then (PRINTOUT T "ok." T)
-                                              else (PRINTOUT T "ok, delete: " (GV.REMOVEMEMBER
-                                                                                   GVDL X)
-                                                              T))
-                                 elseif (COND
-                                               ((AND (EQ (CAR VALUE)
-                                                         'ERROR)
-                                                     (SELECTQ (CAR (CDR VALUE))
-                                                         (CALL.ERROR (SELECTQ (CADDR VALUE)
-                                                                         (TooBusy (PRINTOUT T 
-                                                                                         " error:" 
-                                                                                         VALUE 
-                                                                                      " ... retrying"
-                                                                                         " ..."))
-                                                                         (AccessRightsInsufficient 
-                                                                              (PRINTOUT T " error:" 
-                                                                                     VALUE 
-                                                                                  " will not move..."
-                                                                                     T)
-                                                                              (RETURN))
-                                                                         (HELP VALUE))
-                                                                     (GO LP))
-                                                         (HELP VALUE)))
-                                                T))
-                                   then (TERPRI T)
-                                         NIL
-                                 else (HELP VALUE])
-
-(\GETSTRING
-  [LAMBDA (STREAM LENGTH)                                (* lmm "19-Nov-85 10:21")
-    (COND
-       ((IGREATERP LENGTH \MAXGVSTRING)
-        (ERROR "stream must be confused - string too long" LENGTH))
-       (T (LET ((STRING (ALLOCSTRING LENGTH)))
-               (AIN STRING 1 LENGTH STREAM)
-               (COND
-                  ((ODDP LENGTH)
-                   (BIN STREAM)))
-               STRING])
-
-(\GV.COLLECT.ENTRY
-  [LAMBDA (INSTREAM)                                     (* lmm " 4-Apr-86 16:53")
-
-         (* * 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)
-
-    (LET (NAMETYPE (RESULTS))
-         (\RECEIVESTAMP INSTREAM T)                          (* Skip stamp)
-         (BIN16 INSTREAM)                                    (* Skip component count)
-
-         (* First component is the "prefix" %, which contains, among other things, the 
-       name's type and its "official" name)
-
-         (BIN16 INSTREAM)                                    (* Length of this component)
-         (\RECEIVESTAMP INSTREAM T)                          (* Skip stamp)
-         (SETQ NAMETYPE (BIN16 INSTREAM))
-         (\RECEIVERNAME INSTREAM)
-         (SELECTC NAMETYPE
-             (\NAMETYPE.INDIVIDUAL 
-                  (\SKIPCOMPONENT INSTREAM)                  (* Skip password)
-                  (SETQ RESULTS (\GV.COLLECT.ENTRY.1 INSTREAM 'ConnectSite RESULTS))
-                  (SETQ RESULTS (\GV.COLLECT.ENTRY.LIST INSTREAM 'Forwarding RESULTS))
-                  (SETQ RESULTS (\GV.COLLECT.ENTRY.LIST INSTREAM 'MailboxSites RESULTS)))
-             (\NAMETYPE.GROUP 
-                  (\GV.COLLECT.ENTRY.1 INSTREAM 'Remark RESULTS)
-                  (\MT.SKIPSTRINGLIST INSTREAM)
-                  (\SKIPCOMPONENT INSTREAM)                  (* Skip stamp list)
-                  (\SKIPCOMPONENT INSTREAM)                  (* Skip DelMembers)
-                  (\SKIPCOMPONENT INSTREAM)                  (* Skip stamp list)
-                  (PROGN                                     (* owners)
-                         (\MT.SKIPSTRINGLIST INSTREAM)
-                         (\SKIPCOMPONENT INSTREAM)
-                         (\SKIPCOMPONENT INSTREAM)
-                         (\SKIPCOMPONENT INSTREAM))
-                  (PROGN                                     (* friends)
-                         (\MT.SKIPSTRINGLIST INSTREAM)
-                         (\SKIPCOMPONENT INSTREAM)
-                         (\SKIPCOMPONENT INSTREAM)
-                         (\SKIPCOMPONENT INSTREAM))
-                  '((GROUP . T)))
-             (\NAMETYPE.DEAD 
-                  '((DEAD . T)))
-             NIL])
-
-(\GV.COLLECT.ENTRY.1
-  [LAMBDA (INSTREAM HEADING RESULTS)                     (* lmm " 2-Apr-86 12:51")
-    (COND
-       ((EQ (BIN16 INSTREAM)
-            0)
-        RESULTS)
-       (T (CONS (CONS HEADING (LET [(STRLEN (PROGN (\RECEIVESTAMP INSTREAM T)
-                                                             (* Skip stamp)
-                                                   (BIN16 INSTREAM]
-                                   (LET ((STRING (ALLOCSTRING STRLEN)))
-                                        (AIN STRING 1 STRLEN INSTREAM)
-                                        (COND
-                                           ((ODDP STRLEN)
-                                            (BIN INSTREAM)))
-                                        STRING)))
-                RESULTS])
-
-(\GV.COLLECT.ENTRY.LIST
-  [LAMBDA (INSTREAM HEADING RESULTS)                     (* lmm " 2-Apr-86 12:52")
-
-         (* * return a component consisting of an RList, a stamp list, a "removal" RList
-       (not interesting) and another stamp list)
-
-    (PROG1 (PROG ((CNT 0)
-                  (NWORDS (BIN16 INSTREAM))
-                  STRLEN RMAR VAL)
-                 (COND
-                    ((EQ NWORDS 0)
-                     (RETURN RESULTS)))
-                 [do (add CNT 1)
-                        (SETQ STRLEN (BIN16 INSTREAM))
-                        (BIN16 INSTREAM)                     (* ignore maxLength)
-                        (push VAL (\GETSTRING INSTREAM STRLEN))
-                        (SETQ NWORDS (IDIFFERENCE NWORDS (IPLUS (QUOTIENT (ADD1 STRLEN)
-                                                                       2)
-                                                                2)))
-                        (COND
-                           ((ILEQ NWORDS 0)
-                            (RETURN]
-                 (RETURN (CONS (CONS HEADING VAL)
-                               RESULTS)))
-        (\SKIPCOMPONENT INSTREAM)
-        (\SKIPCOMPONENT INSTREAM)
-        (\SKIPCOMPONENT INSTREAM))])
-)
-
-(FILESLOAD (LOADCOMP)
-       MAINTAIN)
-(PUTPROPS NSTHASIZE COPYRIGHT ("Xerox Corporation" 1986 1989))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (830 13324 (CONVERT.GV.TO.NS 840 . 2194) (GV.READFORWARDING 2196 . 2378) (
-READ-GV-NS-MAPPING 2380 . 4071) (NSTHASIZE 4073 . 8385) (\GETSTRING 8387 . 8814) (\GV.COLLECT.ENTRY 
-8816 . 11260) (\GV.COLLECT.ENTRY.1 11262 . 12058) (\GV.COLLECT.ENTRY.LIST 12060 . 13322)))))
-STOP
diff --git a/obsolete/lispusers/OSS-LYRIC-PATCHES b/obsolete/lispusers/OSS-LYRIC-PATCHES
deleted file mode 100644
index ad21906f..00000000
--- a/obsolete/lispusers/OSS-LYRIC-PATCHES
+++ /dev/null
@@ -1,31 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-(filecreated "24-Mar-88 18:01:18" {eris}<cutting>oss>lyric>oss-lyric-patches.\;1 2853   
-
-      |changes| |to:|  (vars oss-lyric-patchescoms)
-
-      |previous| |date:| "24-Mar-88 16:56:45" {eris}<cutting>oss>lyric>lyric-do-patch.\;1)
-
-
-; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.
-
-(prettycomprint oss-lyric-patchescoms)
-
-(rpaqq oss-lyric-patchescoms ((* |;;| "Patches for some Lyric Common LISP bugs fixed in Medley.") (fns (* |;;| "from CMLSPECIALFORMS") \\do.translate) (functions (* |;;| "from CMLLIST") cl::%mapcar-multiple cl::%fill-slice-from-lists))
-)
-
-
-
-(* |;;| "Patches for some Lyric Common LISP bugs fixed in Medley.")
-
-(defineq
-
-(\\do.translate
-(lambda (vars end-test body sequentialp env) (* \; "Edited 24-Mar-88 16:40 by drc:") (let ((vars-and-initial-values (mapcar vars (function (lambda (x) (cond ((nlistp x) (list x nil)) (t (list (car x) (cadr x)))))))) (subsequent-values (mapcar vars (function (lambda (x) (and (listp x) (cddr x) (list (car x) (caddr x))))))) (tag (gensym))) (and (setq subsequent-values (remove nil subsequent-values)) (setq subsequent-values (cons (cond (sequentialp (quote cl:setq)) (t (quote cl:psetq))) (apply (function append) subsequent-values)))) (cl:multiple-value-bind (body decls) (parse-body body env) (bquote ((\\\, (cond (sequentialp (quote prog*)) (t (quote prog)))) (\\\, vars-and-initial-values) (\\\,@ decls) (\\\, tag) (cond ((\\\, (car end-test)) (return (progn (\\\,@ (cdr end-test)))))) (\\\,@ body) (\\\, subsequent-values) (go (\\\, tag)))))))
-)
-)
-(cl:defun cl::%mapcar-multiple (cl::fn cl::lists) (let ((cl::arg-slice (cl:make-list (length cl::lists)))) (cl:do ((cl::result nil) (cl::result-tail nil) (cl::current-slice cl::arg-slice) cl::element) ((null cl::current-slice) cl::result) (cl:setq cl::current-slice (cl::%fill-slice-from-lists cl::lists cl::arg-slice (car cl::arg-tail))) (cond (cl::current-slice (* \; "There is really more work to do.") (cl:setq cl::element (cl:apply cl::fn cl::current-slice)) (cl::%list-collect cl::result cl::result-tail (list cl::element)))))))
-(defmacro cl::%fill-slice-from-lists (cl::lists cl::arg-slice cl::arg-tail-form) (bquote (cl:do ((cl::subslice (\\\, cl::arg-slice) (cdr cl::subslice)) (cl::sublist (\\\, cl::lists) (cdr cl::sublist)) (cl::some-list-empty nil) list) ((null cl::sublist) (cond (cl::some-list-empty (* \; "Ran out of entries in a list.") nil) (t (* \; "still work to do; return it.") (\\\, cl::arg-slice)))) (cl:setq list (car cl::sublist)) (cl:setq cl::some-list-empty (or cl::some-list-empty (null list))) (rplaca cl::subslice (prog1 (\\\, (cl:subst (quote list) (quote cl::arg-tail) cl::arg-tail-form)) (rplaca cl::sublist (cdr list)))))))
-(putprops oss-lyric-patches copyright ("Xerox Corporation" 1988))
-(declare\: dontcopy
-  (filemap (nil (723 1605 (\\do.translate 733 . 1603)))))
-stop
diff --git a/obsolete/lispusers/PACKED-STRUCTURE b/obsolete/lispusers/PACKED-STRUCTURE
deleted file mode 100644
index fc2753bd..00000000
--- a/obsolete/lispusers/PACKED-STRUCTURE
+++ /dev/null
@@ -1,24 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER")
-(il:filecreated "19-Oct-87 14:53:33" il:{erinyes}<lispusers>lyric>packed-structure.\;1 4305   
-
-      il:|changes| il:|to:|  (il:setfs logbitp) (il:functions def-packed-structure signed-ldb)
-
-      il:|previous| il:|date:| "29-Sep-87 18:13:33" 
-il:|{IE:PARC:XEROX}<LISP>LYRIC>LISPUSERS>PACKED-STRUCTURE.;1|)
-
-
-; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.
-
-(il:prettycomprint il:packed-structurecoms)
-
-(il:rpaqq il:packed-structurecoms ((il:functions def-packed-structure signed-ldb) (il:setfs logbitp) (il:prop il:makefile-environment il:packed-structure))
-)
-(defdefiner def-packed-structure il:structures (name &rest slots) (let* ((*package* (symbol-package name)) (count 0) (max-count 0) (locations)) (labels ((slot-name (slot) (car slot)) (slot-type (slot) (let ((type (getf (cddr slot) (quote :type) t))) (cond ((subtypep type (quote (member nil t))) (quote :boolean)) (t (il:* il:\; " punt for now, this should really coerce other things into stuff that looks like signed or unsigned byte ") type)))) (infix (x y) (intern (format nil "~A-~A" (string x) (string y)))) (slot-location (slot) (cdr (assoc (slot-name slot) locations))) (slot-supplied-p (slot) (infix (slot-name slot) "SUPPLIED-P")) (slot-signed (slot) (and (listp (slot-type slot)) (eq (car (slot-type slot)) (quote signed-byte)))) (slot-size (slot) (let ((type (slot-type slot))) (case type (:boolean 1) (t (ecase (car type) ((unsigned-byte signed-byte) (second type)))))))) (mapc (function (lambda (slot) (when (getf (cddr slot) (quote :overlay)) (setq count 0)) (push (cons (slot-name slot) count) locations) (incf count (slot-size slot)) (setq max-count (max max-count count)))) slots) (il:bquote (progn (deftype (il:\\\, name) nil (quote (unsigned-byte (il:\\\, count)))) (il:\\\,@ (mapcar (function (lambda (s) (il:bquote (defmacro (il:\\\, (infix name (slot-name s))) (x) (il:\\\, (cond ((eq (slot-type s) (quote :boolean)) (il:bquote (il:bquote (logbitp (il:\\\, (quote (il:\\\, (slot-location s)))) (il:\\\, x))))) (t (il:bquote (il:bquote ((il:\\\, (quote (il:\\\, (if (slot-signed s) (quote signed-ldb) (quote ldb))))) (il:\\\, (quote (il:\\\, (byte (slot-size s) (slot-location s))))) (il:\\\, x))))))))))) slots)) (defmacro (il:\\\, (infix "MAKE" name)) (&key (il:\\\,@ (mapcar (function (lambda (s) (list (slot-name s) (second s) (slot-supplied-p s)))) slots)) &aux (value 0)) (il:\\\,@ (mapcar (function (lambda (s) (il:bquote (when (il:\\\, (slot-supplied-p s)) (setq value (il:\\\, (cond ((eq (slot-type s) (quote :boolean)) (il:bquote (il:bquote (logior (if (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (ash 1 (slot-location s))))) 0) (il:\\\, value))))) ((slot-signed s) (il:bquote (il:bquote (dpb (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (byte (slot-size s) (slot-location s))))) (il:\\\, value))))) (t (il:bquote (il:bquote (logior (ash (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (slot-location s))))) (il:\\\, value)))))))))))) slots)) value))))))
-(defun signed-ldb (bytespec integer) (flet ((sign-extend (number position) (if (logbitp (1- position) number) (dpb number (byte position 0) -1) number))) (sign-extend (ldb bytespec integer) (byte-size bytespec))))
-(define-setf-method logbitp (index integer) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method integer) (il:* il:\; "get SETF method for integer.") (let ((btemp (il:gensym)) (il:* il:\; "Temp var for index") (store (il:gensym)) (il:* il:\; "Temp var for new value") (stemp (first stores)) (il:* il:\; "Temp var for int to store.")) (values (cons btemp temps) (il:* il:\; "Temporary variables.") (cons index vals) (il:* il:\; "Value forms.") (list store) (il:* il:\; "Store variables.") (il:bquote (let (((il:\\\, stemp) (if (il:\\\, store) (logior (il:\\\, access-form) (ash 1 (il:\\\, btemp))) (logandc2 (il:\\\, access-form) (ash 1 (il:\\\, btemp)))))) (il:\\\, store-form) (il:\\\, store))) (il:* il:\; "Storing form") (il:bquote (logbitp (il:\\\, btemp) (il:\\\, access-form)))))))
-
-(il:putprops il:packed-structure il:makefile-environment (:readtable "XCL" :package "XCL-USER"))
-(il:putprops il:packed-structure il:copyright ("Xerox Corporation" 1987))
-(il:declare\: il:dontcopy
-  (il:filemap (nil)))
-il:stop
diff --git a/obsolete/lispusers/PACKED-STRUCTURE.LCOM b/obsolete/lispusers/PACKED-STRUCTURE.LCOM
deleted file mode 100644
index 2acdf075..00000000
--- a/obsolete/lispusers/PACKED-STRUCTURE.LCOM
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER")
(IL:FILECREATED " 9-Sep-94 14:12:09" ("compiled on " IL:|{DSK}<lispcore>lispusers>PACKED-STRUCTURE.;1|
) "28-Jul-94 17:28:46" IL:|bcompl'd| IL:|in| "Medley 25-Aug-94 ..." IL:|dated| "25-Aug-94 10:02:49")
(IL:FILECREATED "19-Oct-87 14:53:33" IL:{ERINYES}<LISPUSERS>LYRIC>PACKED-STRUCTURE.\;1 4305 IL:|changes|
 IL:|to:| (IL:SETFS LOGBITP) (IL:FUNCTIONS DEF-PACKED-STRUCTURE SIGNED-LDB) IL:|previous| IL:|date:| 
"29-Sep-87 18:13:33" IL:|{IE:PARC:XEROX}<LISP>LYRIC>LISPUSERS>PACKED-STRUCTURE.;1|)
(IL:PRETTYCOMPRINT IL:PACKED-STRUCTURECOMS)
(IL:RPAQQ IL:PACKED-STRUCTURECOMS ((IL:FUNCTIONS DEF-PACKED-STRUCTURE SIGNED-LDB) (IL:SETFS LOGBITP) (
IL:PROP IL:MAKEFILE-ENVIRONMENT IL:PACKED-STRUCTURE)))
(DEFDEFINER DEF-PACKED-STRUCTURE IL:STRUCTURES (NAME &REST SLOTS) (LET* ((*PACKAGE* (SYMBOL-PACKAGE 
NAME)) (COUNT 0) (MAX-COUNT 0) (LOCATIONS)) (LABELS ((SLOT-NAME (SLOT) (CAR SLOT)) (SLOT-TYPE (SLOT) (
LET ((TYPE (GETF (CDDR SLOT) (QUOTE :TYPE) T))) (COND ((SUBTYPEP TYPE (QUOTE (MEMBER NIL T))) (QUOTE 
:BOOLEAN)) (T (IL:* IL:\; 
" punt for now, this should really coerce other things into stuff that looks like signed or unsigned byte "
) TYPE)))) (INFIX (X Y) (INTERN (FORMAT NIL "~A-~A" (STRING X) (STRING Y)))) (SLOT-LOCATION (SLOT) (
CDR (ASSOC (SLOT-NAME SLOT) LOCATIONS))) (SLOT-SUPPLIED-P (SLOT) (INFIX (SLOT-NAME SLOT) "SUPPLIED-P")
) (SLOT-SIGNED (SLOT) (AND (LISTP (SLOT-TYPE SLOT)) (EQ (CAR (SLOT-TYPE SLOT)) (QUOTE SIGNED-BYTE)))) 
(SLOT-SIZE (SLOT) (LET ((TYPE (SLOT-TYPE SLOT))) (CASE TYPE (:BOOLEAN 1) (T (ECASE (CAR TYPE) ((
UNSIGNED-BYTE SIGNED-BYTE) (SECOND TYPE)))))))) (MAPC (FUNCTION (LAMBDA (SLOT) (WHEN (GETF (CDDR SLOT)
 (QUOTE :OVERLAY)) (SETQ COUNT 0)) (PUSH (CONS (SLOT-NAME SLOT) COUNT) LOCATIONS) (INCF COUNT (
SLOT-SIZE SLOT)) (SETQ MAX-COUNT (MAX MAX-COUNT COUNT)))) SLOTS) (IL:BQUOTE (PROGN (DEFTYPE (IL:\\\, 
NAME) NIL (QUOTE (UNSIGNED-BYTE (IL:\\\, COUNT)))) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (S) (IL:BQUOTE 
(DEFMACRO (IL:\\\, (INFIX NAME (SLOT-NAME S))) (X) (IL:\\\, (COND ((EQ (SLOT-TYPE S) (QUOTE :BOOLEAN))
 (IL:BQUOTE (IL:BQUOTE (LOGBITP (IL:\\\, (QUOTE (IL:\\\, (SLOT-LOCATION S)))) (IL:\\\, X))))) (T (
IL:BQUOTE (IL:BQUOTE ((IL:\\\, (QUOTE (IL:\\\, (IF (SLOT-SIGNED S) (QUOTE SIGNED-LDB) (QUOTE LDB))))) 
(IL:\\\, (QUOTE (IL:\\\, (BYTE (SLOT-SIZE S) (SLOT-LOCATION S))))) (IL:\\\, X))))))))))) SLOTS)) (
DEFMACRO (IL:\\\, (INFIX "MAKE" NAME)) (&KEY (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (S) (LIST (SLOT-NAME 
S) (SECOND S) (SLOT-SUPPLIED-P S)))) SLOTS)) &AUX (VALUE 0)) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (S) (
IL:BQUOTE (WHEN (IL:\\\, (SLOT-SUPPLIED-P S)) (SETQ VALUE (IL:\\\, (COND ((EQ (SLOT-TYPE S) (QUOTE 
:BOOLEAN)) (IL:BQUOTE (IL:BQUOTE (LOGIOR (IF (IL:\\\, (IL:\\\, (SLOT-NAME S))) (IL:\\\, (QUOTE (IL:\\\,
 (ASH 1 (SLOT-LOCATION S))))) 0) (IL:\\\, VALUE))))) ((SLOT-SIGNED S) (IL:BQUOTE (IL:BQUOTE (DPB (
IL:\\\, (IL:\\\, (SLOT-NAME S))) (IL:\\\, (QUOTE (IL:\\\, (BYTE (SLOT-SIZE S) (SLOT-LOCATION S))))) (
IL:\\\, VALUE))))) (T (IL:BQUOTE (IL:BQUOTE (LOGIOR (ASH (IL:\\\, (IL:\\\, (SLOT-NAME S))) (IL:\\\, (
QUOTE (IL:\\\, (SLOT-LOCATION S))))) (IL:\\\, VALUE)))))))))))) SLOTS)) VALUE))))))
(DEFUN SIGNED-LDB (BYTESPEC INTEGER) (FLET ((SIGN-EXTEND (NUMBER POSITION) (IF (LOGBITP (1- POSITION) 
NUMBER) (DPB NUMBER (BYTE POSITION 0) -1) NUMBER))) (SIGN-EXTEND (LDB BYTESPEC INTEGER) (BYTE-SIZE 
BYTESPEC))))
(DEFINE-SETF-METHOD LOGBITP (INDEX INTEGER) (MULTIPLE-VALUE-BIND (TEMPS VALS STORES STORE-FORM 
ACCESS-FORM) (GET-SETF-METHOD INTEGER) (IL:* IL:\; "get SETF method for integer.") (LET ((BTEMP (
IL:GENSYM)) (IL:* IL:\; "Temp var for index") (STORE (IL:GENSYM)) (IL:* IL:\; "Temp var for new value"
) (STEMP (FIRST STORES)) (IL:* IL:\; "Temp var for int to store.")) (VALUES (CONS BTEMP TEMPS) (IL:* 
IL:\; "Temporary variables.") (CONS INDEX VALS) (IL:* IL:\; "Value forms.") (LIST STORE) (IL:* IL:\; 
"Store variables.") (IL:BQUOTE (LET (((IL:\\\, STEMP) (IF (IL:\\\, STORE) (LOGIOR (IL:\\\, ACCESS-FORM
) (ASH 1 (IL:\\\, BTEMP))) (LOGANDC2 (IL:\\\, ACCESS-FORM) (ASH 1 (IL:\\\, BTEMP)))))) (IL:\\\, 
STORE-FORM) (IL:\\\, STORE))) (IL:* IL:\; "Storing form") (IL:BQUOTE (LOGBITP (IL:\\\, BTEMP) (IL:\\\,
 ACCESS-FORM)))))))
(IL:PUTPROPS IL:PACKED-STRUCTURE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL-USER"))
(IL:PUTPROPS IL:PACKED-STRUCTURE IL:COPYRIGHT ("Xerox Corporation" 1987))
NIL
\ No newline at end of file
diff --git a/obsolete/lispusers/PATCH-LARGEIPBITMAP b/obsolete/lispusers/PATCH-LARGEIPBITMAP
deleted file mode 100644
index 498042aa..00000000
--- a/obsolete/lispusers/PATCH-LARGEIPBITMAP
+++ /dev/null
@@ -1,111 +0,0 @@
-(FILECREATED "25-Aug-87 14:23:20" {ERINYES}<LISPUSERS>KOTO>PATCH-LARGEIPBITMAP.;1 5638   
-
-      changes to:  (VARS PATCH-LARGEIPBITMAPCOMS)
-		   (FNS SHOWBITMAP1.IP))
-
-
-(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT PATCH-LARGEIPBITMAPCOMS)
-
-(RPAQQ PATCH-LARGEIPBITMAPCOMS ((* * Fix problem of SHOWBITMAP1.IP in Koto placing the parts of a 
-				     large bitmap in the wrong order)
-				  (FNS SHOWBITMAP1.IP)))
-(* * Fix problem of SHOWBITMAP1.IP in Koto placing the parts of a large bitmap in the wrong 
-order)
-
-(DEFINEQ
-
-(SHOWBITMAP1.IP
-  [LAMBDA (IPSTREAM BITMAP LEFT FIRSTROW XPIXELS YPIXELS SCALEFACTOR ROTATION HEIGHT XBYTES 
-		    REGIONBOTTOM)                            (* N.H.Briggs "25-Aug-87 14:06")
-                                                             (* jds "13-Jan-86 18:13")
-                                                             (* ;; 
-"Move a segment of bitmap to an INTERPRESS file.")          (* ;; 
-							     
-"FIRSTROW is the row count -- STARTING FROM THE TOP OF THE BITMAP AS ZERO -- for the first row to be displayed.")
-                                                             (* ;; 
-							     
-"By the time we get here, XBYTES should have been raised to the next multiple of 32-bits-worth, since that's the required width of packed pixel vectors."
-)
-    (PROG [(TOTALBYTES (ITIMES XBYTES YPIXELS))
-	     (SCRATCHBM (BITMAPCREATE (CEIL XPIXELS BITSPERCELL)
-					1))
-	     (BMBASE (\ADDBASE (fetch (BITMAP BITMAPBASE) of BITMAP)
-				 (ITIMES (IDIFFERENCE (IPLUS HEIGHT (OR REGIONBOTTOM 0))
-							  (IPLUS FIRSTROW YPIXELS))
-					   (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP]
-	    (APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY)
-	    (APPENDOP.IP IPSTREAM {)                       (* ; 
-							     
-"Start the SIMPLEBODY for displaying this part of the bitmap.")
-	    (TRANS.IP IPSTREAM)                            (* ; "Translate to the current position")
-	    (APPENDNUMBER.IP IPSTREAM YPIXELS)             (* ; 
-							     
-"For the master, this is the number of pixels in the slow direction")
-	    (APPENDNUMBER.IP IPSTREAM (CEIL XPIXELS BITSPERCELL))
-                                                             (* ; "Number of pixels in the master's fast direction"
-)
-	    (APPENDINTEGER.IP IPSTREAM 1)                  (* ; "Reserved for future expansion")
-	    (APPENDINTEGER.IP IPSTREAM 1)
-	    (APPENDINTEGER.IP IPSTREAM 1)
-	    (SELECTQ (IMOD (OR ROTATION 0)
-			       360)
-		       (0                                    (* ; 
-							     
-"Bitmaps are really shown on their sides, hanging from the upper left corner (I think--JDS)")
-			  (ROTATE.IP IPSTREAM -90)
-			  (TRANSLATE.IP IPSTREAM 0 (IPLUS FIRSTROW YPIXELS))
-                                                             (* ;; 
-							     
-"Push this segment up to its 'true' height -- i.e., The first segment gets pushed up all the way (since it's the top of the bitmap), the next segment gets pushed up HEIGHT-#ofRowsIn1stSeg (to account for the first segment), and so on."
-)
-			  (CONCAT.IP IPSTREAM))
-		       (90                                   (* ; "need nop")
-			   (TRANSLATE.IP IPSTREAM (IDIFFERENCE HEIGHT (IPLUS FIRSTROW YPIXELS))
-					   0)                (* ;; 
-							     
-"Push this segment up to its 'true' bottom -- i.e., The first segment gets pushed up to bitmapHeight-HeightOfSegment (since it's the top of the bitmap), the next segment gets pushed up HEIGHT-RowsIn1stSeg-RowsThisSeg (to account for the first segment), and so on."
-)
-			   )
-		       (180                                  (* ;; 
-							     
-"The translation for this hasn't been tested yet.  It may well be the inverse of the rotation-0 correction")
-			    (ROTATE.IP IPSTREAM 90)
-			    (TRANSLATE.IP IPSTREAM 0 (IPLUS FIRSTROW YPIXELS))
-			    (CONCAT.IP IPSTREAM))
-		       (270                                  (* ;; 
-							     
-"The translation for this hasn't been tested yet.  It may well be the inverse of the rotation-90 correction")
-			    (ROTATE.IP IPSTREAM 180)
-			    (TRANSLATE.IP IPSTREAM (IDIFFERENCE HEIGHT (IPLUS FIRSTROW YPIXELS))
-					    0)
-			    (CONCAT.IP IPSTREAM))
-		       (ERROR ROTATION 
-				"rotation by other than multiples of 90 degrees not implemented"))
-	    (SCALE.IP IPSTREAM SCALEFACTOR)                (* ; "Scale the bitmap to its final size")
-	    (CONCAT.IP IPSTREAM)
-	    (APPENDSEQUENCEDESCRIPTOR.IP IPSTREAM SEQPACKEDPIXELVECTOR (IPLUS 4 TOTALBYTES))
-	    (APPENDINT.IP IPSTREAM 1 2)
-	    (APPENDINT.IP IPSTREAM (CEIL XPIXELS BITSPERCELL)
-			    2)                               (* ;; 
-							     
-"Now put put the bitmap -- each line must be a 32-bit multiple long")
-	    (for Y (XWORDS _ (FOLDHI XBYTES BYTESPERWORD)) from 1 to YPIXELS
-	       do (BITBLT BITMAP (OR LEFT 0)
-			      (IDIFFERENCE (IPLUS (OR REGIONBOTTOM 0)
-						      FIRSTROW YPIXELS)
-					     Y)
-			      SCRATCHBM 0 0 XPIXELS 1 (QUOTE INPUT)
-			      (QUOTE REPLACE))
-		    (\BOUTS IPSTREAM (fetch (BITMAP BITMAPBASE) of SCRATCHBM)
-			      0
-			      (CEIL XBYTES BYTESPERCELL)))
-	    (APPENDOP.IP IPSTREAM MAKEPIXELARRAY)
-	    (APPENDOP.IP IPSTREAM MASKPIXEL)
-	    (APPENDOP.IP IPSTREAM }])
-)
-(PUTPROPS PATCH-LARGEIPBITMAP COPYRIGHT ("Xerox Corporation" 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (565 5548 (SHOWBITMAP1.IP 575 . 5546)))))
-STOP
diff --git a/obsolete/lispusers/PATCH-TWOSIDED b/obsolete/lispusers/PATCH-TWOSIDED
deleted file mode 100644
index 265a7bc2..00000000
--- a/obsolete/lispusers/PATCH-TWOSIDED
+++ /dev/null
@@ -1,169 +0,0 @@
-(FILECREATED " 1-Sep-87 11:23:23" {ERINYES}<LISPUSERS>KOTO>PATCH-TWOSIDED.;1 6479   
-
-      previous date: "15-Oct-86 12:20:47" {QV}<BRIGGS>LISP>PATCH-TWOSIDED.;1)
-
-
-(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT PATCH-TWOSIDEDCOMS)
-
-(RPAQQ PATCH-TWOSIDEDCOMS ((FNS \NSPRINT.INTERNAL)
-			     (DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
-										  NSPRINT))))
-(DEFINEQ
-
-(\NSPRINT.INTERNAL
-  [LAMBDA (PRINTER OPTIONS TRANSFERFN)                       (* N.H.Briggs "27-Sep-86 16:31")
-
-          (* * Calls the PRINT program for PRINTER, interpreting OPTIONS as a plist of print options.
-	  TRANSFERFN is a function applied to the transfer stream to actually send the Interpress master)
-
-
-    (PROG ((MEDIUM (OR (LISTGET OPTIONS (QUOTE MEDIUM))
-			   NSPRINT.DEFAULT.MEDIUM))
-	     (STAPLE? (LISTGET OPTIONS (QUOTE STAPLE?)))
-	     (TWO.SIDED? (EQ 2 (OR (LISTGET OPTIONS (QUOTE #SIDES))
-				       EMPRESS#SIDES)))
-	     (SENDER.NAME (OR (LISTGET OPTIONS (QUOTE SENDER.NAME))
-				(USERNAME NIL NIL T)))
-	     (DOCNAME (OR (LISTGET OPTIONS (QUOTE DOCUMENT.NAME))
-			    "Document"))
-	     PROPERTIES ATTRIBUTES COURIERSTREAM VALUE PRINTOPTIONS STATUS)
-	    [SETQ ATTRIBUTES (BQUOTE ((PRINT.OBJECT.NAME , DOCNAME)
-					  (PRINT.OBJECT.CREATE.DATE , (OR (LISTGET OPTIONS
-										       (QUOTE
-											 
-									   DOCUMENT.CREATION.DATE))
-									    (IDATE)))
-					  (SENDER.NAME , SENDER.NAME]
-	    [SETQ PRINTOPTIONS (BQUOTE ((COPY.COUNT , (FIX (OR (LISTGET OPTIONS
-										  (QUOTE #COPIES))
-								       1]
-                                                             (* This "option" seems to be required)
-	    [COND
-	      ((SETQ VALUE (LISTGET OPTIONS (QUOTE RECIPIENT.NAME)))
-		(push PRINTOPTIONS (LIST (QUOTE RECIPIENT.NAME)
-					     (OR (STRINGP VALUE)
-						   (MKSTRING VALUE]
-	    [COND
-	      ((SETQ VALUE (LISTGET OPTIONS (QUOTE PRIORITY)))
-		(push PRINTOPTIONS (LIST (QUOTE PRIORITY.HINT)
-					     (SELECTQ VALUE
-							((HOLD LOW NORMAL HIGH)
-							  VALUE)
-							(\ILLEGAL.ARG VALUE]
-	    [COND
-	      ((SETQ VALUE (LISTGET OPTIONS (QUOTE MESSAGE)))
-		(push PRINTOPTIONS (LIST (QUOTE MESSAGE)
-					     (OR (STRINGP VALUE)
-						   (MKSTRING VALUE]
-	    [COND
-	      ((SETQ VALUE (LISTGET OPTIONS (QUOTE PAGES.TO.PRINT)))
-                                                             (* A page range to print, (first# last#))
-		(COND
-		  ((AND (LISTP VALUE)
-			  (LISTP (CDR VALUE))
-			  (NULL (CDDR VALUE))
-			  (SMALLPOSP (CAR VALUE))
-			  (SMALLPOSP (CADR VALUE)))
-		    (push PRINTOPTIONS (LIST (QUOTE PAGES.TO.PRINT)
-						 VALUE)))
-		  (T (\ILLEGAL.ARG VALUE]
-	RETRY
-	    (COND
-	      ((NOT (SETQ COURIERSTREAM (\NSPRINT.COURIER.OPEN PRINTER)))
-		(printout PROMPTWINDOW .TAB0 0 "No response from printer " (fetch NSPRINTERNAME
-									      of PRINTER))
-		(DISMISS 5000)
-		(GO RETRY)))
-	    (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
-				     COURIERSTREAM))         (* Check the status of the printer.)
-	    (bind (LASTSTATUS _ 0)
-	       do (SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
-						   (QUOTE GET.PRINTER.STATUS)
-						   (QUOTE RETURNERRORS)))
-		    [COND
-		      ((EQ (CAR STATUS)
-			     (QUOTE ERROR))
-			(COND
-			  ((NOT (EQUAL STATUS LASTSTATUS))
-			    (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME of PRINTER)
-				      " Error: "
-				      (SUBSTRING (CDR STATUS)
-						   2 -2)
-				      "; will retry]")))     (* Wait longer for this problem)
-			(DISMISS 30000))
-		      ((NEQ (SETQ STATUS (CADR (ASSOC (QUOTE SPOOLER)
-							      STATUS)))
-			      LASTSTATUS)
-			(SELECTQ STATUS
-				   (Available (RETURN))
-				   (Busy (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME
-									      of PRINTER)
-						   " Status: Spooler busy; will retry]"))
-				   (ERROR "Printer spooler" STATUS]
-		    (SETQ LASTSTATUS STATUS)
-		    (DISMISS 5000))
-	    [COND
-	      ((OR MEDIUM STAPLE? TWO.SIDED?)              (* Check that the printer supports these options.)
-		(SETQ PROPERTIES (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
-						   (QUOTE GET.PRINTER.PROPERTIES)
-						   (QUOTE RETURNERRORS)))
-		(COND
-		  ((EQ (CAR PROPERTIES)
-			 (QUOTE ERROR))
-		    (SETQ STATUS PROPERTIES)
-		    (GO HANDLE.ERROR)))
-		[COND
-		  (MEDIUM (COND
-			    ((SETQ VALUE (\NSPRINT.MEDIUM.CHECK MEDIUM
-								    (CADR (ASSOC (QUOTE MEDIA)
-										     PROPERTIES))
-								    PRINTER))
-			      (push PRINTOPTIONS (LIST (QUOTE MEDIUM.HINT)
-							   VALUE))
-			      (SETQ MEDIUM]
-		[COND
-		  (STAPLE? (COND
-			     ((CADR (ASSOC (QUOTE STAPLE)
-					       PROPERTIES))
-			       (push PRINTOPTIONS (LIST (QUOTE STAPLE)
-							    T))
-			       (SETQ STAPLE?))
-			     (T (printout PROMPTWINDOW .TAB0 0 
-					  "[Printer does not support stapled copies]"]
-		(COND
-		  (TWO.SIDED? (COND
-				((CADR (ASSOC (QUOTE TWO.SIDED)
-						  PROPERTIES))
-				  (push PRINTOPTIONS (QUOTE (TWO.SIDED T)))
-				  (SETQ TWO.SIDED?))
-				(T (printout PROMPTWINDOW .TAB0 0 
-					     "Printer does not support two-sided copies"]
-
-          (* * Finally, send the print document)
-
-
-	    (SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
-					   (QUOTE PRINT)
-					   TRANSFERFN ATTRIBUTES PRINTOPTIONS (QUOTE RETURNERRORS)))
-	    (COND
-	      ((NEQ (CAR STATUS)
-		      (QUOTE ERROR))
-		(RETURN STATUS)))
-	HANDLE.ERROR
-	    (ERROR (CONCAT "Unexpected error from " (fetch NSPRINTERNAME of PRINTER)
-			       " attempting to print " DOCNAME "
-RETURN to try again.")
-		     (CDR STATUS))
-	    (CLOSEF COURIERSTREAM)
-	    (GO RETRY])
-)
-(DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY 
-(FILESLOAD (LOADCOMP)
-	   NSPRINT)
-)
-(PUTPROPS PATCH-TWOSIDED COPYRIGHT ("Xerox Corporation" 1986 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (433 6305 (\NSPRINT.INTERNAL 443 . 6303)))))
-STOP
diff --git a/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT b/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT
deleted file mode 100644
index 169d3161..00000000
--- a/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP")
(FILECREATED "30-Mar-89 09:18:42" {ERINYES}<LISPUSERS>MEDLEY>POSTSCRIPT>POSTSCRIPT.;6 109842 

      changes to%:  (FNS POSTSCRIPT.INIT \BITBLT.PSC)

      previous date%: "22-Feb-89 15:28:19" {ERINYES}<LISPUSERS>MEDLEY>POSTSCRIPT>POSTSCRIPT.;5)


(* "
Copyright (c) 1986, 1987, 1988, 1989 by Beckman Instruments, Inc.  All rights reserved.
")

(PRETTYCOMPRINT POSTSCRIPTCOMS)

(RPAQQ POSTSCRIPTCOMS 
       [(RECORDS BRUSH FONTID ARRAYP PSCFONT \POSTSCRIPTDATA)
        (FNS CLOSEPOSTSCRIPTSTREAM OPENPOSTSCRIPTSTREAM POSTSCRIPT.BITMAPSCALE POSTSCRIPT.CLOSESTRING
             POSTSCRIPT.FONTCREATE POSTSCRIPT.FONTSAVAILABLE POSTSCRIPT.GETFONTID 
             POSTSCRIPT.HARDCOPYW POSTSCRIPT.INIT POSTSCRIPT.OUTSTR POSTSCRIPT.PUTBITMAPBYTES 
             POSTSCRIPT.PUTCOMMAND POSTSCRIPT.SHOWACCUM POSTSCRIPT.STARTPAGE POSTSCRIPT.TEDIT 
             POSTSCRIPT.TEXT POSTSCRIPTFILEP PSCFONT.READFONT PSCFONT.SPELLFILE PSCFONT.WRITEFONT 
             READ-AFM-FILE \BITBLT.PSC \BLTSHADE.PSC \CHARWIDTH.PSC \DRAWARC.PSC \DRAWCIRCLE.PSC 
             \DRAWCURVE.PSC \DRAWELLIPSE.PSC \DRAWLINE.PSC \DRAWPOLYGON.PSC \DSPBOTTOMMARGIN.PSC 
             \DSPCLIPPINGREGION.PSC \DSPFONT.PSC \DSPLEFTMARGIN.PSC \DSPLINEFEED.PSC \DSPRESET.PSC 
             \DSPRIGHTMARGIN.PSC \DSPSCALE.PSC \DSPSPACEFACTOR.PSC \DSPTOPMARGIN.PSC 
             \DSPXPOSITION.PSC \DSPYPOSITION.PSC \FILLCIRCLE.PSC \FILLPOLYGON.PSC \MOVETO.PSC 
             \NEWPAGE.PSC \POSTSCRIPT.OUTCHARFN \POSTSCRIPT.PUTCHAR \STRINGWIDTH.PSC \TERPRI.PSC 
             \DSPROTATE.PSC \DSPTRANSLATE.PSC \DRAWPOINT.PSC)
        (VARS (\POSTSCRIPT.ORIENTATION.MENU (create MENU ITEMS _ '(("Landscape" T 
                                            "Print this file/document/image in Landscape Orientation"
                                                                          )
                                                                   ("Portrait" 'NIL 
                                             "Print this file/document/image in Portrait Orientation"
                                                                          ))
                                                   TITLE _ "Orientation" CENTERFLG _ T MENUOFFSET _
                                                   (create POSITION XCOORD _ -1 YCOORD _ 0)
                                                   CHANGEOFFSETFLG _ 'Y))
              PS.BITMAPARRAY \POSTSCRIPT.JOB.SETUP SlopeMenuItems WeightMenuItems)
        (CONSTANTS (GOLDEN.RATIO 1.618034))
        (INITVARS (POSTSCRIPT.BITMAP.SCALE 1)
               (POSTSCRIPT.IMAGESIZEFACTOR 1.0)
               (POSTSCRIPT.PREFER.LANDSCAPE NIL)
               (POSTSCRIPT.TEXTFILE.LANDSCAPE NIL)
               (POSTSCRIPT.TEXTURE.SCALE 4)
               (POSTSCRIPTFONTDIRECTORIES '("{DSK}<LISPFILES>FONTS>PSC>"))
               (\POSTSCRIPT.LONGEDGE.SHIFT 0)
               (\POSTSCRIPT.SHORTEDGE.SHIFT 0)
               (\POSTSCRIPT.LONGEDGE.PTS (+ (TIMES 72 10.92)
                                            \POSTSCRIPT.SHORTEDGE.SHIFT))
               (\POSTSCRIPT.SHORTEDGE.PTS (+ (TIMES 72 8.0)
                                             \POSTSCRIPT.LONGEDGE.SHIFT))
               (\POSTSCRIPT.MAX.WILD.FONTSIZE 72))
        [ADDVARS (POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA)
                        (TIMESROMAN . TIMES)
                        (TIMESROMAND . TIMES)
                        (COURIER . COURIER)
                        (GACHA . COURIER)
                        (CLASSIC . TIMES)
                        (MODERN . HELVETICA)
                        (CREAM . HELVETICA)
                        (TERMINAL . COURIER)
                        (LOGO . HELVETICA))
               [PRINTERTYPES ((POSTSCRIPT)
                              (CANPRINT (POSTSCRIPT))
                              (STATUS TRUE)
                              (PROPERTIES NILL)
                              (SEND POSTSCRIPT.SEND)
                              (BITMAPSCALE POSTSCRIPT.BITMAPSCALE)
                              (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION 
                                                 ROTATION TITLE]
               [PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP)
                                      (EXTENSION (PS PSC))
                                      (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT]
               (IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM)
                                        (FONTCREATE POSTSCRIPT.FONTCREATE)
                                        (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE)
                                        (CREATECHARSET NILL]
        (GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.FONT.ALIST 
               POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE 
               POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.LONGEDGE.PTS 
               \POSTSCRIPT.LONGEDGE.SHIFT \POSTSCRIPT.MAX.WILD.FONTSIZE \POSTSCRIPT.ORIENTATION.MENU
               \POSTSCRIPT.SHORTEDGE.PTS \POSTSCRIPT.SHORTEDGE.SHIFT \POSTSCRIPTIMAGEOPS)
        (FILES PS-SEND)
        (P (POSTSCRIPT.INIT))
        (PROP (FILETYPE MAKEFILE-ENVIRONMENT)
              POSTSCRIPT)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA 
                                                                                POSTSCRIPT.PUTCOMMAND
                                                                                   ])
(DECLARE%: EVAL@COMPILE

(RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR)
                  BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1)

(RECORD FONTID (FONTIDNAME FONTXFACTOR FONTOBLIQUEFACTOR))

(DATATYPE ARRAYP ((ORIG BITS 1)
                      (NIL BITS 1)
                      (READONLY FLAG)                        (* ; "probably no READONLY arrays now")
                      (NIL BITS 1)
                      (TYP BITS 4)
                      (BASE POINTER)
                      (LENGTH WORD)
                      (OFFST WORD))

                     (* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}")

                     )

(RECORD PSCFONT (FID IL-FONTID FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTHS))

(DATATYPE \POSTSCRIPTDATA 
          (POSTSCRIPTFONT                                    (* ; 
                                                           "The fontdescriptor of the current font")
                 POSTSCRIPTX POSTSCRIPTY POSTSCRIPTLEFTMARGIN POSTSCRIPTRIGHTMARGIN 
                 POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTLINESPACING POSTSCRIPTCOLOR 
                 POSTSCRIPTSCALE POSTSCRIPTOPERATION POSTSCRIPTCLIPPINGREGION POSTSCRIPTPAGENUM 
                 POSTSCRIPTHEADING POSTSCRIPTHEADINGFONT POSTSCRIPTSPACEFACTOR 
                                                             (* ; 
                                             "The expansion factor for spaces (see DSPSPACEFACTOR)")
                 POSTSCRIPTLANDSCAPE                         (* ; 
                                                    "T means that the paper is in 'landscape' mode")
                 POSTSCRIPTCHARSTOSHOW                       (* ; 
                                        "T means that the string of chars has already been started")
                 )
          POSTSCRIPTSPACEFACTOR _ 1 POSTSCRIPTPAGENUM _ 0)
)

(/DECLAREDATATYPE 'ARRAYP '((BITS 1)
                            (BITS 1)
                            FLAG
                            (BITS 1)
                            (BITS 4)
                            POINTER WORD WORD)
       '((ARRAYP 0 (BITS . 0))
         (ARRAYP 0 (BITS . 16))
         (ARRAYP 0 (FLAGBITS . 32))
         (ARRAYP 0 (BITS . 48))
         (ARRAYP 0 (BITS . 67))
         (ARRAYP 0 POINTER)
         (ARRAYP 2 (BITS . 15))
         (ARRAYP 3 (BITS . 15)))
       '4)

(/DECLAREDATATYPE '\POSTSCRIPTDATA
       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
               POINTER POINTER POINTER POINTER POINTER POINTER POINTER)
       '((\POSTSCRIPTDATA 0 POINTER)
         (\POSTSCRIPTDATA 2 POINTER)
         (\POSTSCRIPTDATA 4 POINTER)
         (\POSTSCRIPTDATA 6 POINTER)
         (\POSTSCRIPTDATA 8 POINTER)
         (\POSTSCRIPTDATA 10 POINTER)
         (\POSTSCRIPTDATA 12 POINTER)
         (\POSTSCRIPTDATA 14 POINTER)
         (\POSTSCRIPTDATA 16 POINTER)
         (\POSTSCRIPTDATA 18 POINTER)
         (\POSTSCRIPTDATA 20 POINTER)
         (\POSTSCRIPTDATA 22 POINTER)
         (\POSTSCRIPTDATA 24 POINTER)
         (\POSTSCRIPTDATA 26 POINTER)
         (\POSTSCRIPTDATA 28 POINTER)
         (\POSTSCRIPTDATA 30 POINTER)
         (\POSTSCRIPTDATA 32 POINTER)
         (\POSTSCRIPTDATA 34 POINTER))
       '36)
(DEFINEQ

(CLOSEPOSTSCRIPTSTREAM
  [LAMBDA (VSTREAM)                               (* ; "Edited 20-Jan-88 17:43 by Matt Heffron")
    (POSTSCRIPT.PUTCOMMAND VSTREAM "
 savepage restore
showpage
%%%%Trailer
"])

(OPENPOSTSCRIPTSTREAM
  [LAMBDA (FILE OPTIONS)                          (* ; "Edited 20-Oct-88 14:45 by Matt Heffron")
    (LET ([FP (OPENSTREAM (if (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'EXTENSION)
                                              "")
                                       (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'HOST)
                                              "LPT"))
                              then (PACKFILENAME.STRING 'HOST "LPT" 'NAME (UNPACKFILENAME.STRING
                                                                               FILE
                                                                               'NAME)
                                              'EXTENSION "PS")
                            else FILE)
                     'OUTPUT NIL '((TYPE POSTSCRIPT)
                                   (SEQUENTIAL T]
          (IMAGEDATA (create \POSTSCRIPTDATA))
          LANDSCAPE? FONT IMAGESIZEFACTOR SHORTEDGE LONGEDGE TEMP)
         (SETFILEINFO FP 'EOL 'CR)
         (replace (STREAM OUTCHARFN) of FP with '\FILEOUTCHARFN)
         (printout FP "%%!PS-Adobe-2.0" T "%%%%Title: " (MKSTRING (OR (LISTGET OPTIONS 
                                                                             'DOCUMENT.NAME)
                                                                      FILE))
                T "%%%%Creator: PostScript ImageStream Driver by Matt Heffron of Beckman Instruments"
                T "%%%%CreationDate: " (DATE)
                T "%%%%For: " (if (STRING-EQUAL INITIALS "Edited:")
                                  then (MKSTRING USERNAME)
                                else INITIALS)
                T "%%%%EndComments" T)
         (for PJS in \POSTSCRIPT.JOB.SETUP do (PRIN1 PJS FP)
                                                         (TERPRI FP))
         [if (SETQ LANDSCAPE? (CL:GETF OPTIONS 'ROTATION 'DEFAULTNIL))
             then (if (EQ LANDSCAPE? 'DEFAULTNIL)
                          then (SETQ LANDSCAPE? (if (EQ POSTSCRIPT.PREFER.LANDSCAPE
                                                                'ASK)
                                                        then (MENU \POSTSCRIPT.ORIENTATION.MENU)
                                                      else POSTSCRIPT.PREFER.LANDSCAPE]
         (replace POSTSCRIPTLANDSCAPE of IMAGEDATA with LANDSCAPE?)
         (if (NOT (AND (SETQ IMAGESIZEFACTOR (LISTGET OPTIONS 'IMAGESIZEFACTOR))
                           (NUMBERP IMAGESIZEFACTOR)
                           (CL:PLUSP IMAGESIZEFACTOR)))
             then (SETQ IMAGESIZEFACTOR 1.0))
         (if (AND (NUMBERP POSTSCRIPT.IMAGESIZEFACTOR)
                      (CL:PLUSP POSTSCRIPT.IMAGESIZEFACTOR))
             then (SETQ IMAGESIZEFACTOR (TIMES IMAGESIZEFACTOR POSTSCRIPT.IMAGESIZEFACTOR)))
         (PRIN1 "/imagesizefactor " FP)
         (PRIN1 IMAGESIZEFACTOR FP)
         (PRIN1 " def" FP)
         (TERPRI FP)
         (PRIN1 "%%%%EndSetup" FP)
         (TERPRI FP)
         (replace POSTSCRIPTSCALE of IMAGEDATA with 100.0)
         (SETQ LONGEDGE (FQUOTIENT (FTIMES \POSTSCRIPT.LONGEDGE.PTS 100.0)
                               IMAGESIZEFACTOR))
         (SETQ SHORTEDGE (FQUOTIENT (FTIMES \POSTSCRIPT.SHORTEDGE.PTS 100.0)
                                IMAGESIZEFACTOR))
         (replace (STREAM IMAGEOPS) of FP with \POSTSCRIPTIMAGEOPS)
         (replace (STREAM IMAGEDATA) of FP with IMAGEDATA)
         (replace (STREAM LINELENGTH) of FP with MAX.SMALLP)
         (replace (STREAM CHARPOSITION) of FP with 0)
         (replace (STREAM OUTCHARFN) of FP with '\POSTSCRIPT.OUTCHARFN)
         (if LANDSCAPE?
             then (\DSPTOPMARGIN.PSC FP (FIXR SHORTEDGE))
                   (\DSPRIGHTMARGIN.PSC FP (FIXR LONGEDGE))
                   (replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA
                      with (create REGION
                                      LEFT _ 0.0
                                      BOTTOM _ 0.0
                                      WIDTH _ LONGEDGE
                                      HEIGHT _ SHORTEDGE))
           else (\DSPTOPMARGIN.PSC FP (FIXR LONGEDGE))
                 (\DSPRIGHTMARGIN.PSC FP (FIXR SHORTEDGE))
                 (replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA
                    with (create REGION
                                    LEFT _ 0.0
                                    BOTTOM _ 0.0
                                    WIDTH _ SHORTEDGE
                                    HEIGHT _ LONGEDGE)))
         (SETQ FONT (FONTCREATE (OR [CAR (MKLIST (LISTGET OPTIONS 'FONTS]
                                    DEFAULTFONT)
                           NIL NIL NIL FP))
         (if (SETQ TEMP (LISTGET OPTIONS 'HEADING))
             then (replace POSTSCRIPTHEADING of IMAGEDATA with TEMP)
                   (replace POSTSCRIPTHEADINGFONT of IMAGEDATA with FONT))
         (\DSPLEFTMARGIN.PSC FP 0)
         (\DSPBOTTOMMARGIN.PSC FP 0)
         (\DSPFONT.PSC FP FONT)
         (\DSPLINEFEED.PSC FP (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of FONT)))
         (POSTSCRIPT.STARTPAGE FP)
         FP])

(POSTSCRIPT.BITMAPSCALE
  [LAMBDA (WIDTH HEIGHT)                          (* ; "Edited 20-Oct-88 14:48 by Matt Heffron")
    (LET* ([MINDIMP (MIN (FQUOTIENT \POSTSCRIPT.LONGEDGE.PTS (SETQ HEIGHT (TIMES HEIGHT 
                                                                              POSTSCRIPT.BITMAP.SCALE
                                                                                 )))
                         (FQUOTIENT \POSTSCRIPT.SHORTEDGE.PTS (SETQ WIDTH (TIMES WIDTH 
                                                                              POSTSCRIPT.BITMAP.SCALE
                                                                                 ]
           (MINDIML (MIN (FQUOTIENT \POSTSCRIPT.SHORTEDGE.PTS HEIGHT)
                         (FQUOTIENT \POSTSCRIPT.LONGEDGE.PTS WIDTH)))
           (PPL (if (EQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK)
                    then (MENU \POSTSCRIPT.ORIENTATION.MENU)
                  else POSTSCRIPT.PREFER.LANDSCAPE))
           MINDIM OTHERDIM SF1 SF2)
          (if PPL
              then (SETQ MINDIM MINDIML)
                    (SETQ OTHERDIM MINDIMP)
            else (SETQ MINDIM MINDIMP)
                  (SETQ OTHERDIM MINDIML))
          (SETQ SF1 (if (GREATERP MINDIM 1)
                        then 1
                      elseif (GREATERP MINDIM 0.75)
                        then 0.75
                      elseif (GREATERP MINDIM 0.5)
                        then 0.5
                      elseif (GREATERP MINDIM 0.25)
                        then 0.25
                      else MINDIM))
          (SETQ SF2 (if (GREATERP OTHERDIM 1)
                        then 1
                      elseif (GREATERP OTHERDIM 0.75)
                        then 0.75
                      elseif (GREATERP OTHERDIM 0.5)
                        then 0.5
                      elseif (GREATERP OTHERDIM 0.25)
                        then 0.25
                      else OTHERDIM))
          (if (AND (LESSP SF1 1)
                       (LESSP SF1 SF2))
              then (CONS SF2 (NOT PPL))
            else (CONS SF1 PPL])

(POSTSCRIPT.CLOSESTRING
  [LAMBDA (STREAM)                                (* ; "Edited 12-Jan-88 12:33 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (if (fetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA)
             then (POSTSCRIPT.OUTSTR STREAM ") ")
                   (replace POSTSCRIPTCHARSTOSHOW of IMAGEDATA with NIL)
                   T
           else NIL])

(POSTSCRIPT.FONTCREATE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)      (* ; "Edited 12-Jan-88 12:36 by Matt Heffron")
    (LET (UNITFONT FULLNAME SCALEFONTP PSCFD ASCENT DESCENT FIXPWIDTHS CHARSETINFO0 WIDTHSBLOCK FD 
                FACECHANGED (WEIGHT (CAR FACE))
                (SLOPE (CADR FACE))
                (EXPANSION (CADDR FACE)))

         (* ;; 
  "Ignore rotations, it is **MUCH** easier to rotate the Postscript stream user space coordinates.")

         (if (EQ SIZE 1)
             then 

                   (* ;; "Since a 1 point font is rediculously small, and it is the standard size for Postscript font info, a 1 point font is presumed to be the unit size Postscript font info")

                   (if (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE))
                       then (SETQ FACECHANGED NIL)
                     elseif (AND (NEQ EXPANSION 'REGULAR)
                                     (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE
                                                           (LIST WEIGHT SLOPE 'REGULAR)
                                                           ROTATION DEVICE)))
                       then (SETQ FACECHANGED T)
                     elseif (AND (EQ SLOPE 'ITALIC)
                                     (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE
                                                           (LIST WEIGHT 'REGULAR EXPANSION)
                                                           ROTATION DEVICE)))
                       then (SETQ FACECHANGED T)
                     elseif (AND (NEQ EXPANSION 'REGULAR)
                                     (EQ SLOPE 'ITALIC)
                                     (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE
                                                           (LIST WEIGHT 'REGULAR 'REGULAR)
                                                           ROTATION DEVICE)))
                       then (SETQ FACECHANGED T)
                     elseif (AND (NEQ WEIGHT 'MEDIUM)
                                     (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE
                                                           (LIST 'MEDIUM SLOPE EXPANSION)
                                                           ROTATION DEVICE)))
                       then (SETQ FACECHANGED T)
                     elseif (AND (NEQ WEIGHT 'MEDIUM)
                                     (NEQ EXPANSION 'REGULAR)
                                     (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE
                                                           (LIST 'MEDIUM SLOPE 'REGULAR)
                                                           ROTATION DEVICE)))
                       then (SETQ FACECHANGED T)
                     elseif (AND (NEQ WEIGHT 'MEDIUM)
                                     (EQ SLOPE 'ITALIC)
                                     (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE
                                                           (LIST 'MEDIUM 'REGULAR EXPANSION)
                                                           ROTATION DEVICE)))
                       then (SETQ FACECHANGED T)
                     elseif (AND (NEQ WEIGHT 'MEDIUM)
                                     (NEQ EXPANSION 'REGULAR)
                                     (EQ SLOPE 'ITALIC)
                                     (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE
                                                           (LIST 'MEDIUM 'REGULAR 'REGULAR)
                                                           ROTATION DEVICE)))
                       then (SETQ FACECHANGED T))
                   [if FULLNAME
                       then (SETQ PSCFD (PSCFONT.READFONT FULLNAME))
                             (SETQ ASCENT (FIXR (TIMES (fetch (PSCFONT ASCENT) of PSCFD)
                                                       0.1)))
                             (SETQ DESCENT (FIXR (TIMES (fetch (PSCFONT DESCENT) of PSCFD)
                                                        0.1)))
                             (if FACECHANGED
                                 then (replace (PSCFONT IL-FONTID) of PSCFD
                                             with (POSTSCRIPT.GETFONTID (fetch
                                                                                 (PSCFONT FID)
                                                                                   of PSCFD)
                                                             WEIGHT SLOPE EXPANSION]
           elseif (SETQ UNITFONT (FONTCREATE FAMILY 1 FACE ROTATION DEVICE T))
             then (SETQ PSCFD (fetch (FONTDESCRIPTOR FONTDEVICESPEC) of UNITFONT)) 

                   (* ;; "Scale the ASCENT and DESCENT")

                   (SETQ ASCENT (FIXR (TIMES SIZE (fetch (PSCFONT ASCENT) of PSCFD)
                                             0.1)))
                   (SETQ DESCENT (FIXR (TIMES SIZE (fetch (PSCFONT DESCENT) of PSCFD)
                                              0.1)))
                   (SETQ SCALEFONTP T)
           else 

                 (* ;; "Here for fonts that only come in specific sizes.  Their info is not scaled like built-in Postscript fonts, it is already correct for this pointsize.")

                 (if (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE))
                     then (SETQ PSCFD (PSCFONT.READFONT FULLNAME))
                           (SETQ ASCENT (fetch (PSCFONT ASCENT) of PSCFD))
                           (SETQ DESCENT (fetch (PSCFONT DESCENT) of PSCFD))
                           (SETQ SCALEFONTP NIL)))
         (if PSCFD
             then (SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of PSCFD))
                   (SETQ CHARSETINFO0 (create CHARSETINFO))
                   (SETQ WIDTHSBLOCK (fetch (CHARSETINFO WIDTHS) of CHARSETINFO0))
                   (SETQ FD
                    (create FONTDESCRIPTOR
                           FONTDEVICESPEC _ PSCFD
                           FONTSCALE _ 100.0
                           FONTDEVICE _ DEVICE
                           FONTFAMILY _ FAMILY
                           FONTSIZE _ SIZE
                           FONTFACE _ FACE
                           ROTATION _ 0
                           \SFHeight _ (IPLUS ASCENT DESCENT)
                           \SFAscent _ ASCENT
                           \SFDescent _ DESCENT
                           \SFRWidths _ WIDTHSBLOCK
                           FONTIMAGEWIDTHS _ WIDTHSBLOCK))
                   (replace (CHARSETINFO IMAGEWIDTHS) of CHARSETINFO0 with WIDTHSBLOCK)
                   (replace (CHARSETINFO CHARSETASCENT) of CHARSETINFO0 with ASCENT)
                   (replace (CHARSETINFO CHARSETDESCENT) of CHARSETINFO0 with DESCENT)
                   [if SCALEFONTP
                       then [for CH from 0 to 255
                                   do (\FSETWIDTH WIDTHSBLOCK CH (FIXR (TIMES SIZE
                                                                                  (ELT FIXPWIDTHS CH)
                                                                                  0.1]
                     else (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH
                                                                              (ELT FIXPWIDTHS CH]
                   (\SETCHARSETINFO (fetch FONTCHARSETVECTOR of FD)
                          0 CHARSETINFO0)
                   FD
           else NIL])

(POSTSCRIPT.FONTSAVAILABLE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)      (* ; "Edited 12-Jan-88 13:04 by Matt Heffron")

    (* ;; "the filtering code was borrowed from Richard Burton's \SEARCHINTERPRESSFONTS.  Note that without it [HELVETICA * (MEDIUM REGULAR REGULAR)]  would pick up [HELVETICA-NARROW * (MEDIUM REGULAR REGULAR)] as well.")

    (LET
     ((PATTERN (\FONTFILENAME (OR (CDR (ASSOC FAMILY POSTSCRIPT.FONT.ALIST))
                                  FAMILY)
                      SIZE FACE 'PSCFONT))
      [INVERSE.ALIST (for PAIR in POSTSCRIPT.FONT.ALIST collect (CONS (CDR PAIR)
                                                                                  (CAR PAIR]
      FONTSAVAILABLE)
     (SETQ FONTSAVAILABLE
      (for FD in [for DIRECTORY in POSTSCRIPTFONTDIRECTORIES
                            join (for FILE in (DIRECTORY (CONCAT DIRECTORY PATTERN))
                                        collect (LET* ((RAWFD (\FONTINFOFROMFILENAME FILE DEVICE)
                                                                  )
                                                           (RAWNAME (CAR RAWFD)))
                                                          (RPLACA RAWFD
                                                                 (OR (CDR (ASSOC RAWNAME 
                                                                                 INVERSE.ALIST))
                                                                     RAWNAME]
         when (AND (OR (EQ FAMILY '*)
                           (EQ FAMILY (CAR FD)))
                       (OR (EQ SIZE '*)
                           (EQ SIZE (CADR FD))
                           (EQ (CADR FD)
                               1))
                       (OR (EQ FACE '*)
                           (EQUAL FACE (CADDR FD))
                           (EQUAL [CDR (ASSOC FACE '((MRR MEDIUM REGULAR REGULAR)
                                                     (STANDARD MEDIUM REGULAR REGULAR)
                                                     (MIR MEDIUM ITALIC REGULAR)
                                                     (ITALIC MEDIUM ITALIC REGULAR)
                                                     (BRR BOLD REGULAR REGULAR)
                                                     (BOLD BOLD REGULAR REGULAR)
                                                     (BIR BOLD ITALIC REGULAR)
                                                     (BOLDITALIC BOLD ITALIC REGULAR]
                                  (CADDR FD)))
                       (NOT (MEMBER FD $$VAL))) collect FD))
     (if (EQ SIZE '*)
         then

(* ;;; "If SIZE was wildcarded, then provide list of pointsizes for Postscript scaled fonts (those with a 1 point descriptor file)")

         (for FD in FONTSAVAILABLE
            join (if (EQ 1 (CADR FD))
                         then (CONS FD (for NF
                                              in (for S from 2 to 
                                                                        \POSTSCRIPT.MAX.WILD.FONTSIZE
                                                        collect (LET ((NFD (COPY FD)))
                                                                         (RPLACA (CDR NFD)
                                                                                S)
                                                                         NFD))
                                              unless (MEMBER NF FONTSAVAILABLE) collect
                                                                                    NF))
                       else (LIST FD)))
       else FONTSAVAILABLE])

(POSTSCRIPT.GETFONTID
  [LAMBDA (FID WEIGHT SLOPE EXPANSION)            (* ; "Edited 12-Jan-88 12:58 by Matt Heffron")
    (LET (FONTID)
         (SETQ FONTID (create FONTID
                             FONTIDNAME _ (CAR FID)
                             FONTXFACTOR _ 1.0
                             FONTOBLIQUEFACTOR _ 0.0))
         [if (AND (NEQ (CADDR FID)
                           SLOPE)
                      (EQ SLOPE 'ITALIC))
             then (replace FONTOBLIQUEFACTOR of FONTID with (CONSTANT (TAN 7.0]
         (if (AND (NEQ (CADR FID)
                           WEIGHT)
                      (EQ WEIGHT 'BOLD))
             then                                        (* ; "Fake bold by slight expansion.")
                   (replace FONTXFACTOR of FONTID with 1.1))
         [if (NEQ EXPANSION 'REGULAR)
             then (replace FONTXFACTOR of FONTID
                         with (TIMES (fetch FONTXFACTOR of FONTID)
                                         (if (EQ EXPANSION 'COMPRESSED)
                                             then (CONSTANT (QUOTIENT 1.0 GOLDEN.RATIO))
                                           else GOLDEN.RATIO]
         FONTID])

(POSTSCRIPT.HARDCOPYW
  [LAMBDA (FILE BITMAP SCALEFACTOR REGION Landscape? TITLE)
                                                      (* ; "Edited  4-Feb-88 13:18 by Matt Heffron")
    (SPAWN.MOUSE)                                            (* ; 
                                 "(SETQ Landscape? T) ;Must be landscape to prevent printer hang??")
    (LET ((STREAM (OPENPOSTSCRIPTSTREAM FILE (LIST 'DOCUMENT.NAME TITLE 'ROTATION Landscape?
                                                       'IMAGESIZEFACTOR SCALEFACTOR)))
          SCLIP W H SCALE)
         [SETQ W (fetch (REGION WIDTH) of (SETQ SCLIP (DSPCLIPPINGREGION NIL STREAM]
         (SETQ H (fetch (REGION HEIGHT) of SCLIP))
         [if REGION
             then (SETQ REGION (COPY REGION))            (* ; "In case we need to change it.")
                   [if (< (BITMAPWIDTH BITMAP)
                              (+ (fetch (REGION LEFT) of REGION)
                                 (fetch (REGION WIDTH) of REGION)))
                       then (replace (REGION WIDTH) of REGION
                                   with (- (BITMAPWIDTH BITMAP)
                                               (fetch (REGION LEFT) of REGION]
                   [if (< (BITMAPHEIGHT BITMAP)
                              (+ (fetch (REGION BOTTOM) of REGION)
                                 (fetch (REGION HEIGHT) of REGION)))
                       then (replace (REGION HEIGHT) of REGION
                                   with (- (BITMAPHEIGHT BITMAP)
                                               (fetch (REGION BOTTOM) of REGION]
           else (SETQ REGION (create REGION
                                        LEFT _ 0
                                        BOTTOM _ 0
                                        WIDTH _ (BITMAPWIDTH BITMAP)
                                        HEIGHT _ (BITMAPHEIGHT BITMAP]
         (SETQ SCALE (TIMES POSTSCRIPT.BITMAP.SCALE (DSPSCALE NIL STREAM)))
         (BITBLT BITMAP (fetch (REGION LEFT) of REGION)
                (fetch (REGION BOTTOM) of REGION)
                STREAM
                (QUOTIENT (DIFFERENCE W (TIMES SCALE (fetch (REGION WIDTH) of REGION)))
                       2)
                (QUOTIENT (DIFFERENCE H (TIMES SCALE (fetch (REGION HEIGHT) of REGION)))
                       2)
                (fetch (REGION WIDTH) of REGION)
                (fetch (REGION HEIGHT) of REGION)
                'INPUT
                'REPLACE)
         (CLOSEF STREAM)
         (FULLNAME STREAM])

(POSTSCRIPT.INIT
  [LAMBDA NIL                                            (* ; "Edited 29-Mar-89 11:21 by snow")
    [MAPC
     [CL:REMOVE-DUPLICATES (NCONC (for FD in FONTDEFS
                                     join (for FP in (CDR (ASSOC 'FONTPROFILE
                                                                             (CDR FD)))
                                                 collect (CAR FP)))
                                  '(FONT7 FONT6 FONT5 FONT4 FONT3 FONT2 FONT1 BOLDFONT LITTLEFONT 
                                          BIGFONT PRETTYCOMFONT COMMENTFONT USERFONT SYSTEMFONT 
                                          CLISPFONT LAMBDAFONT CHANGEFONT DEFAULTFONT]
     (FUNCTION (LAMBDA (CLASS)
                 (LET
                  (COPYFD OLDPSCFD)
                  (if (BOUNDP CLASS)
                      then
                      (SETQ CLASS (EVALV CLASS))
                      (if (TYPEP CLASS 'FONTCLASS)
                          then (SETQ COPYFD (OR (fetch (FONTCLASS PRESSFD) of CLASS)
                                                    (fetch (FONTCLASS INTERPRESSFD) of CLASS)
                                                    (fetch (FONTCLASS DISPLAYFD) of CLASS)))
                                (if (SETQ OLDPSCFD (ASSOC 'POSTSCRIPT (fetch (FONTCLASS
                                                                                      OTHERFDS)
                                                                             of CLASS)))
                                    then [if (NOT (CDR OLDPSCFD))
                                                 then (RPLACD OLDPSCFD (if (LISTP COPYFD)
                                                                               then COPYFD
                                                                             else (FONTUNPARSE
                                                                                       COPYFD]
                                  else (push (fetch (FONTCLASS OTHERFDS) of CLASS)
                                                  (CONS 'POSTSCRIPT (if (LISTP COPYFD)
                                                                        then COPYFD
                                                                      else (FONTUNPARSE COPYFD]
    (SETQ \POSTSCRIPTIMAGEOPS (create IMAGEOPS
                                     IMAGETYPE _ 'POSTSCRIPT
                                     IMCLOSEFN _ (FUNCTION CLOSEPOSTSCRIPTSTREAM)
                                     IMXPOSITION _ (FUNCTION \DSPXPOSITION.PSC)
                                     IMYPOSITION _ (FUNCTION \DSPYPOSITION.PSC)
                                     IMMOVETO _ (FUNCTION \MOVETO.PSC)
                                     IMFONT _ (FUNCTION \DSPFONT.PSC)
                                     IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.PSC)
                                     IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.PSC)
                                     IMLINEFEED _ (FUNCTION \DSPLINEFEED.PSC)
                                     IMDRAWLINE _ (FUNCTION \DRAWLINE.PSC)
                                     IMDRAWCURVE _ (FUNCTION \DRAWCURVE.PSC)
                                     IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.PSC)
                                     IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.PSC)
                                     IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.PSC)
                                     IMBLTSHADE _ (FUNCTION \BLTSHADE.PSC)
                                     IMBITBLT _ (FUNCTION \BITBLT.PSC)
                                     IMNEWPAGE _ (FUNCTION \NEWPAGE.PSC)
                                     IMSCALE _ (FUNCTION \DSPSCALE.PSC)
                                     IMTERPRI _ (FUNCTION \TERPRI.PSC)
                                     IMTOPMARGIN _ (FUNCTION \DSPTOPMARGIN.PSC)
                                     IMBOTTOMMARGIN _ (FUNCTION \DSPBOTTOMMARGIN.PSC)
                                     IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.PSC)
                                     IMFONTCREATE _ 'POSTSCRIPT
                                     IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.PSC)
                                     IMRESET _ (FUNCTION \DSPRESET.PSC)
                                     IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.PSC)
                                     IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.PSC)
                                     IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.PSC)
                                     IMCHARWIDTH _ (FUNCTION \CHARWIDTH.PSC)
                                     IMDRAWARC _ (FUNCTION \DRAWARC.PSC)
                                     IMROTATE _ (FUNCTION \DSPROTATE.PSC)
                                     IMTRANSLATE _ (FUNCTION \DSPTRANSLATE.PSC)
                                     IMDRAWPOINT _ (FUNCTION \DRAWPOINT.PSC)
                                     IMSCALEDBITBLT _ (FUNCTION \BITBLT.PSC])

(POSTSCRIPT.OUTSTR
  [LAMBDA (STREAM STRING)                         (* ; "Edited 13-Apr-88 16:33 by Matt Heffron")
    (if (OR (LITATOM STRING)
                (STRINGP STRING)
                (AND (ZEROP STRING)
                     (SETQ STRING "0.0")))
        then [for CI from 1 to (NCHARS STRING)
                    do (BOUT STREAM (LOGAND 255 (NTHCHARCODE STRING CI]
      else (for CC in (CHCON STRING) do (BOUT STREAM (LOGAND 255 CC])

(POSTSCRIPT.PUTBITMAPBYTES
  [LAMBDA (STREAM BITMAP DELIMFLG)
    (DECLARE (GLOBALVARS PS.BITMAPARRAY)
           (LOCALVARS . T))                       (* ; "Edited 27-Jan-89 11:16 by Matt Heffron")
    (LET ((BMBASE (fetch BITMAPBASE of BITMAP))
          (BYTESPERROW (LRSH (IPLUS (fetch BITMAPWIDTH of BITMAP)
                                    7)
                             3))
          (BYTEOFFSETPERROW (LSH (fetch BITMAPRASTERWIDTH of BITMAP)
                                 1))
          (HEIGHT (fetch BITMAPHEIGHT of BITMAP))
          (POS 0)
          (BYTE)
          (PS.BITMAPARRAYBASE (fetch (ARRAYP BASE) of PS.BITMAPARRAY)))

         (* ;; "PS.BITMAPARRAY code speedup by Will Snow @ Envos")

         (if DELIMFLG
             then (POSTSCRIPT.OUTSTR STREAM " <
"))
         (for R from (SUB1 HEIGHT) to 0 by -1 as ROWOFFSET
            from (ITIMES (SUB1 HEIGHT)
                            BYTEOFFSETPERROW) by (IMINUS BYTEOFFSETPERROW)
            do (for B from 1 to BYTESPERROW as BYTEOFFSET from ROWOFFSET
                      by 1 do (if (IGEQ POS 254)
                                          then (\BUFFERED.BOUT STREAM (CHARCODE EOL))
                                                (SETQ POS 0))
                                     (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET))
                                     [\BUFFERED.BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE
                                                                   (LOGAND 15 (LRSH BYTE 4]
                                     (\BUFFERED.BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE
                                                                   (LOGAND 15 BYTE)))
                                     (SETQ POS (IPLUS POS 2)))
                  (\BUFFERED.BOUT STREAM (CHARCODE EOL))
                  (SETQ POS 0))
         (if DELIMFLG
             then (POSTSCRIPT.OUTSTR STREAM ">
"])

(POSTSCRIPT.PUTCOMMAND
  [LAMBDA S.STRS                                  (* ; "Edited 12-Jan-88 13:01 by Matt Heffron")
    (LET ((STREAM (ARG S.STRS 1)))
         (POSTSCRIPT.SHOWACCUM STREAM)
         (for STR# from 2 to S.STRS do (POSTSCRIPT.OUTSTR STREAM (ARG S.STRS STR#
                                                                                          ])

(POSTSCRIPT.SHOWACCUM
  [LAMBDA (STREAM)                                (* ; "Edited 12-Jan-88 16:06 by Matt Heffron")
    (if (POSTSCRIPT.CLOSESTRING STREAM)
        then (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
                        (SPACEFACTOR (fetch POSTSCRIPTSPACEFACTOR of IMAGEDATA))
                        WIDTH)
                       (if (EQP SPACEFACTOR 1)
                           then (POSTSCRIPT.OUTSTR STREAM "show ")
                         else (replace POSTSCRIPTSPACEFACTOR of IMAGEDATA with 1)
                               (SETQ WIDTH (\CHARWIDTH.PSC STREAM (CHARCODE SPACE)))
                               (replace POSTSCRIPTSPACEFACTOR of IMAGEDATA with 
                                                                                         SPACEFACTOR)
                               (POSTSCRIPT.OUTSTR STREAM (TIMES WIDTH (DIFFERENCE SPACEFACTOR 1))
                                      )
                               (POSTSCRIPT.OUTSTR STREAM " 0 ")
                               (POSTSCRIPT.OUTSTR STREAM (CHARCODE SPACE))
                               (POSTSCRIPT.OUTSTR STREAM " 4 -1 roll widthshow "])

(POSTSCRIPT.STARTPAGE
  [LAMBDA (STREAM)                                (* ; "Edited  9-Sep-88 10:48 by Matt Heffron")
    (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))
           (CLIPREGN (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA))
           (CFONT (fetch POSTSCRIPTFONT of IMAGEDATA))
           LEFT BOTTOM WIDTH HEIGHT)
          (POSTSCRIPT.PUTCOMMAND STREAM "
%%%%BeginPageSetup
")
          (if (fetch POSTSCRIPTLANDSCAPE of IMAGEDATA)
              then (POSTSCRIPT.PUTCOMMAND STREAM "xmax ymin translate 90 rotate
")
                    (if (OR (NOT (ZEROP \POSTSCRIPT.SHORTEDGE.SHIFT))
                                (NOT (ZEROP \POSTSCRIPT.LONGEDGE.SHIFT)))
                        then (POSTSCRIPT.PUTCOMMAND STREAM \POSTSCRIPT.SHORTEDGE.SHIFT " "
                                        (MINUS \POSTSCRIPT.LONGEDGE.SHIFT)
                                        " translate
"))
            else (if (AND (ZEROP \POSTSCRIPT.LONGEDGE.SHIFT)
                                  (ZEROP \POSTSCRIPT.SHORTEDGE.SHIFT))
                         then (POSTSCRIPT.PUTCOMMAND STREAM "xmin ymin translate
")
                       else (POSTSCRIPT.PUTCOMMAND STREAM "xmin " \POSTSCRIPT.LONGEDGE.SHIFT
                                       " add ymin " \POSTSCRIPT.SHORTEDGE.SHIFT " add translate
")))
          (POSTSCRIPT.PUTCOMMAND STREAM 
        "0.01 imagesizefactor mul 0.01 imagesizefactor mul scale
%%%%EndPageSetup
/savepage save def")

          (* ;; "Since the clipping region is per page in Postscript by virtue of the savepage ..., reset the current clipping region for this page.")

          (SETQ LEFT (fetch LEFT of CLIPREGN))
          (SETQ BOTTOM (fetch BOTTOM of CLIPREGN))
          (SETQ WIDTH (fetch (REGION WIDTH) of CLIPREGN))
          (SETQ HEIGHT (fetch (REGION HEIGHT) of CLIPREGN))
          (POSTSCRIPT.PUTCOMMAND STREAM "
newpath " LEFT " " BOTTOM " mto " WIDTH " 0 rlineto 0 " HEIGHT " rlineto " (IMINUS WIDTH)
                 " 0 rlineto closepath
 clip newpath
")
          (* ;; "It seems that Lisp depends on the current font being carried over from page to page, so reset it explicitly here.")

          (replace POSTSCRIPTFONT of IMAGEDATA with NIL)
                                                             (* ; 
                                                     "There is no FONT at the beginning of a page.")
          (if (fetch POSTSCRIPTHEADING of IMAGEDATA)
              then 

                    (* ;; "Here we handle headings.  This imitates the INTERPRESS code.")

                    (\DSPFONT.PSC STREAM (fetch POSTSCRIPTHEADINGFONT of IMAGEDATA))
                    (\DSPRESET.PSC STREAM)
                    (PRIN3 (fetch POSTSCRIPTHEADING of IMAGEDATA)
                           STREAM)
                    (RELMOVETO 7200 0 STREAM)                (* ; "Skip an inch before page number")
                    (PRIN3 "Page " STREAM)
                    (PRIN3 (CL:INCF (fetch POSTSCRIPTPAGENUM of IMAGEDATA))
                           STREAM)
                    (\TERPRI.PSC STREAM)                 (* ; "Skip 2 lines")
                    (\TERPRI.PSC STREAM)
                    (\DSPFONT.PSC STREAM CFONT)
            else (\DSPFONT.PSC STREAM CFONT)
                  (\DSPRESET.PSC STREAM])

(POSTSCRIPT.TEDIT
  [LAMBDA (FILE PFILE)                            (* ; "Edited 12-Jan-88 13:03 by Matt Heffron")
    (SETQ FILE (OPENTEXTSTREAM FILE))
    (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL NIL 'POSTSCRIPT)
    (CLOSEF? FILE)
    PFILE])

(POSTSCRIPT.TEXT
  [LAMBDA (FILE PSCFILE FONTS HEADING TABS)       (* ; "Edited 12-Jan-88 13:03 by Matt Heffron")
    (TEXTTOIMAGEFILE FILE PSCFILE 'POSTSCRIPT FONTS HEADING TABS (if 
                                                                        POSTSCRIPT.TEXTFILE.LANDSCAPE
                                                                     then '(ROTATION T)
                                                                   else NIL])

(POSTSCRIPTFILEP
  [LAMBDA (FILE)                                  (* ; "Edited  4-Apr-88 16:31 by Matt Heffron")
    (OR (CL:MEMBER (UNPACKFILENAME.STRING FILE 'EXTENSION)
               '("PS" "PSC")
               :TEST
               (FUNCTION STRING-EQUAL))
        (CL:UNWIND-PROTECT
            [PROGN (SETQ FILE (OPENSTREAM FILE 'INPUT))
                   (AND (EQ (BIN FILE)
                            (CHARCODE %%))
                        (EQ (BIN FILE)
                            (CHARCODE !]
            (CLOSEF? FILE))])

(PSCFONT.READFONT
  [LAMBDA (FONTFILENAME)                          (* ; "Edited 15-Oct-87 11:10 by Matt Heffron")
    (LET ((PF (create PSCFONT))
          [S (OPENSTREAM FONTFILENAME 'INPUT NIL '((SEQUENTIAL T]
          FID W)
         [replace (PSCFONT FID) of PF with (SETQ FID (READ S (FIND-READTABLE "INTERLISP"]
         (CL:DO NIL
                ((EQ (BIN S)
                     255))

             (* ;; "Body of the loop is empty, the test does all of the work")

             )
         (replace (PSCFONT IL-FONTID) of PF with (CAR FID))
         (replace (PSCFONT FIRSTCHAR) of PF with (\WIN S))
         (replace (PSCFONT LASTCHAR) of PF with (\WIN S))
         (replace (PSCFONT ASCENT) of PF with (\WIN S))
         (replace (PSCFONT DESCENT) of PF with (\WIN S))
         (replace (PSCFONT WIDTHS) of PF with (SETQ W (ARRAY 256 'SMALLPOSP 0 0)))
         (for C from 0 to 255 do (SETA W C (\WIN S)))
         (CLOSEF S)
         PF])

(PSCFONT.SPELLFILE
  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE)      (* ; "Edited 12-Jan-88 13:04 by Matt Heffron")
    (SETQ FAMILY (OR (CDR (ASSOC FAMILY POSTSCRIPT.FONT.ALIST))
                     FAMILY))
    (bind FULLNAME for PATH in POSTSCRIPTFONTDIRECTORIES
       thereis [SETQ FULLNAME (INFILEP (CONCAT PATH (\FONTFILENAME FAMILY SIZE FACE '.PSCFONT]
       finally (RETURN FULLNAME])

(PSCFONT.WRITEFONT
  [LAMBDA (FONTFILENAME PF)                       (* ; "Edited 15-Oct-87 11:12 by Matt Heffron")
    (LET ([S (OPENSTREAM FONTFILENAME 'OUTPUT NIL '((TYPE BINARY)
                                                    (SEQUENTIAL T]
          (W (fetch (PSCFONT WIDTHS) of PF))
          (*READTABLE* (FIND-READTABLE "INTERLISP")))
         (PRIN3 (fetch (PSCFONT FID) of PF)
                S)
         (BOUT S 0)
         (BOUT S 255)
         (\WOUT S (fetch (PSCFONT FIRSTCHAR) of PF))
         (\WOUT S (fetch (PSCFONT LASTCHAR) of PF))
         (\WOUT S (fetch (PSCFONT ASCENT) of PF))
         (\WOUT S (fetch (PSCFONT DESCENT) of PF))
         (for C from 0 to 255 do (\WOUT S (ELT W C)))
         (CLOSEF S)
         FONTFILENAME])

(READ-AFM-FILE
  [LAMBDA (FILE)                                  (* ; "Edited 20-Jan-88 17:22 by Matt Heffron")
    (LET ((IFILE (OPENSTREAM FILE 'INPUT))
          (PSCFONT (create PSCFONT))
          (FCHAR 1000)
          (LCHAR 0)
          (W (ARRAY 256 'SMALLPOSP 0 0))
          TOKEN WEIGHT SLOPE CMCOUNT FBBOX)
         (with PSCFONT PSCFONT (repeatuntil (STRING-EQUAL "FontName" (RSTRING IFILE))
                                      do (READCCODE IFILE))
                (repeatwhile (STRING-EQUAL "" (SETQ TOKEN (RSTRING IFILE)))
                   do (READCCODE IFILE))
                [if (NOT (AND (BOUNDP 'WeightMenu)
                                  (type? MENU WeightMenu)))
                    then (SETQ WeightMenu (create MENU
                                                     ITEMS _ WeightMenuItems
                                                     MENUFONT _ (FONTCREATE 'HELVETICA 12]
                [if (NOT (AND (BOUNDP 'SlopeMenu)
                                  (type? MENU SlopeMenu)))
                    then (SETQ SlopeMenu (create MENU
                                                    ITEMS _ SlopeMenuItems
                                                    MENUFONT _ (FONTCREATE 'HELVETICA 12]
                (printout T T "Font WEIGHT for " PSCFONT ": " (SETQ WEIGHT (MENU WeightMenu))
                       T)
                (printout T T "Font SLOPE for " PSCFONT ": " (SETQ SLOPE (MENU SlopeMenu))
                       T)
                (SETQ FID (LIST TOKEN WEIGHT SLOPE 'REGULAR))
                [SETQ IL-FONTID (if (AND (EQ SLOPE 'REGULAR)
                                             (EQ WEIGHT 'MEDIUM))
                                    then TOKEN
                                  else (POSTSCRIPT.GETFONTID FID WEIGHT SLOPE 'REGULAR]
                (repeatuntil (STRING-EQUAL "StartCharMetrics" TOKEN)
                   do (SETQ TOKEN (RSTRING IFILE))
                         (if (STRING-EQUAL "FontBBox" TOKEN)
                             then (SETQ FBBOX (LIST (READ IFILE)
                                                        (READ IFILE)
                                                        (READ IFILE)
                                                        (READ IFILE))) 

                                   (* ;; "The Ascender and Descender properties from the AFM file are currently ignored, and the values from the FontBBox are used.")

                                   (SETQ DESCENT (IABS (CADR FBBOX)))
                                   (SETQ ASCENT (CADDDR FBBOX))
                           else (READCCODE IFILE)))
                (SETQ CMCOUNT (RATOM IFILE))
                (repeatuntil (EQ (CHARCODE EOL)
                                     (READCCODE IFILE)) do)
                (SETQ WIDTHS W)
                (for CC from 1 to CMCOUNT
                   do (LET (CCODE)
                               (repeatuntil (EQ 'C (RATOM IFILE)) do)
                               (SETQ CCODE (READ IFILE))
                               (if (CL:PLUSP CCODE)
                                   then (if (ILESSP CCODE FCHAR)
                                                then (SETQ FCHAR CCODE))
                                         (if (IGREATERP CCODE LCHAR)
                                             then (SETQ LCHAR CCODE))
                                         (RATOMS 'WX IFILE)
                                         (SETA W CCODE (READ IFILE)))
                               (repeatuntil (EQ (CHARCODE EOL)
                                                    (READCCODE IFILE)) do)))
                (SETQ FIRSTCHAR FCHAR)
                (SETQ LASTCHAR LCHAR))
         (CLOSEF IFILE)
         PSCFONT])

(\BITBLT.PSC
  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
                 SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM 
                 SCALEFACTOR)                            (* ; "Edited 29-Mar-89 18:31 by snow")

    (* ;; 
  "Added SCALEFACTOR so this can be used by both IMBITBLT and IMSCALEDBITBLT.  --was 29-Mar-89")

    (* ;; "Postscript can only handle OPERATION REPLACE and PAINT.  SOURCETYPE = TEXTURE is converted to BLTSHADE before getting here (so the TEXTURE argument can be ignored) (What are the CLIPPEDSOURCELEFT & CLIPPEDSOURCEBOTTOM arguments?  They are not documented)")

    (LET (RGN LEFT BOTTOM TEMPBM (SCALE (DSPSCALE NIL STREAM)))

         (* ;; "scaledbitblt may pass nil as DESTINATIONLEFT or DESTINATIONBOTTOM, which means print this at the current position.")

         (SETQ DESTINATIONLEFT (OR DESTINATIONLEFT (DSPXPOSITION NIL STREAM)))
         (SETQ DESTINATIONBOTTOM (OR DESTINATIONBOTTOM (DSPYPOSITION NIL STREAM)))
         (SETQ RGN (create REGION
                          LEFT _ (QUOTIENT DESTINATIONLEFT SCALE)
                          BOTTOM _ (QUOTIENT DESTINATIONBOTTOM SCALE)
                          WIDTH _ WIDTH
                          HEIGHT _ HEIGHT))
         (if CLIPPINGREGION
             then (SETQ RGN (INTERSECTREGIONS CLIPPINGREGION RGN))
                   (SETQ LEFT (TIMES (fetch (REGION LEFT) of RGN)
                                     SCALE))
                   (SETQ BOTTOM (TIMES (fetch (REGION BOTTOM) of RGN)
                                       SCALE))
                   (SETQ WIDTH (fetch (REGION WIDTH) of RGN))
                   (SETQ HEIGHT (fetch (REGION HEIGHT) of RGN))
           else (SETQ LEFT DESTINATIONLEFT)
                 (SETQ BOTTOM DESTINATIONBOTTOM))
         (if RGN
             then (SETQ TEMPBM (BITMAPCREATE WIDTH HEIGHT 1))
                   (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM TEMPBM 0 0 WIDTH HEIGHT SOURCETYPE
                          'REPLACE)
                   (SETQ SCALE (TIMES SCALE (OR (AND (BOUNDP 'POSTSCRIPT.BITMAP.SCALE)
                                                     (NUMBERP POSTSCRIPT.BITMAP.SCALE))
                                                1)
                                      (OR SCALEFACTOR 1)))
                   (POSTSCRIPT.PUTCOMMAND STREAM "
/bitbltsave save def " LEFT " " BOTTOM " translate " (TIMES SCALE WIDTH)
                          " "
                          (TIMES SCALE HEIGHT)
                          " scale " WIDTH " " HEIGHT (if (EQ OPERATION 'PAINT)
                                                         then " true"
                                                       else " false")
                          " thebitimage
")
                   (POSTSCRIPT.PUTBITMAPBYTES STREAM TEMPBM NIL)
                   (POSTSCRIPT.OUTSTR STREAM "
bitbltsave restore
")
                   (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM)
                   T
           else NIL])

(\BLTSHADE.PSC
  [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)
                                                      (* ; "Edited  9-Sep-88 10:56 by Matt Heffron")

    (* ;; "Maybe we should do something with OPERATION")

    (LET (TEXTUREBM TEXTUREWIDTH LEFT BOTTOM RGN)
         (if CLIPPINGREGION
             then (SETQ RGN
                       (INTERSECTREGIONS CLIPPINGREGION
                              (create REGION
                                     LEFT _ DESTINATIONLEFT
                                     BOTTOM _ DESTINATIONBOTTOM
                                     WIDTH _ WIDTH
                                     HEIGHT _ HEIGHT)))
                   (SETQ LEFT (fetch (REGION LEFT) of RGN))
                   (SETQ BOTTOM (fetch (REGION BOTTOM) of RGN))
                   (SETQ WIDTH (fetch (REGION WIDTH) of RGN))
                   (SETQ HEIGHT (fetch (REGION HEIGHT) of RGN))
           else (SETQ RGN T)
                 (SETQ LEFT DESTINATIONLEFT)
                 (SETQ BOTTOM DESTINATIONBOTTOM))
         (if RGN
             then (POSTSCRIPT.PUTCOMMAND STREAM "
gsave
 newpath ")
                   (if (FIXP TEXTURE)
                       then (if (ZEROP TEXTURE)
                                    then (SETQ TEXTURE 1.0) 
                                                             (* ; "The setgray version of white")
                                  elseif (OR (EQL TEXTURE 65535)
                                                 (EQL TEXTURE -1))
                                    then (SETQ TEXTURE 0.0) 
                                                             (* ; "The setgray version of black")
                                       ))
                   (if (FLOATP TEXTURE)
                       then 

                             (* ;; 
                     "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.")

                             (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ")
                     elseif (OR (TEXTUREP TEXTURE)
                                    (NULL TEXTURE))
                       then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1))
                             (SETQ TEXTUREWIDTH 16)
                             (BLTSHADE TEXTURE TEXTUREBM)
                     elseif (BITMAPP TEXTURE)
                       then (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM)
                                                        (fetch BITMAPHEIGHT of TEXTUREBM)))
                             (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1))
                             (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT
                                    'REPLACE))
                   (if TEXTUREBM
                       then (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale " (QUOTIENT LEFT 
                                                                                          100.0)
                                       " "
                                       (QUOTIENT BOTTOM 100.0)
                                       " mto "
                                       (SETQ WIDTH (QUOTIENT WIDTH 100.0))
                                       " 0 rlineto 0 "
                                       (QUOTIENT HEIGHT 100.0)
                                       " rlineto "
                                       (MINUS WIDTH)
                                       " 0 rlineto closepath
")
                             (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T)
                             (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " "
                                    (LSH (fetch BITMAPRASTERWIDTH of TEXTUREBM)
                                         1)
                                    " 0 "
                                    (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM)
                                                     100.0))
                                    " findresolution " TEXTUREWIDTH " div div ceiling " 
                                    POSTSCRIPT.TEXTURE.SCALE " mul setpattern eofill
grestore
")
                     else (POSTSCRIPT.PUTCOMMAND STREAM LEFT " " BOTTOM " mto " WIDTH 
                                     " 0 rlineto 0 " HEIGHT " rlineto " (MINUS WIDTH)
                                     " 0 rlineto closepath eofill
grestore
"))
                   (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM)
                   T
           else NIL])

(\CHARWIDTH.PSC
  [LAMBDA (STREAM CHARCODE)                       (* ; "Edited 12-Jan-88 15:54 by Matt Heffron")

    (* ;; "no NS character set treatment yet")

    (LET (WID SPACEFACTOR (IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (SETQ WID (\FGETWIDTH (fetch FONTIMAGEWIDTHS of (fetch POSTSCRIPTFONT
                                                                    of IMAGEDATA))
                          (LOGAND CHARCODE 255)))
         (if (AND (EQ CHARCODE (CHARCODE SPACE))
                      (NOT (EQP (SETQ SPACEFACTOR (fetch POSTSCRIPTSPACEFACTOR of IMAGEDATA))
                                1)))
             then (FIXR (TIMES WID SPACEFACTOR))
           else WID])

(\DRAWARC.PSC
  [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING)
                                                      (* ; "Edited  9-Sep-88 10:59 by Matt Heffron")
    (LET (WIDTH COLOR)
         (if (NUMBERP BRUSH)
             then (SETQ WIDTH BRUSH)
           elseif (LISTP BRUSH)
             then (if (NEQ (fetch BRUSHSHAPE of BRUSH)
                                   'ROUND)
                          then (printout T T 
                              "[In \DRAWARC.PSC: Non-ROUND BRUSH not supported.]
[Using ROUND BRUSH]" T))
                   (SETQ WIDTH (fetch BRUSHSIZE of BRUSH))
                   (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))
           else                                          (* ; 
                                                           "If FUNCTIONAL BRUSH big trouble!")
                 (printout T T 
                     "[In \DRAWARC.PSC: Functional BRUSH not supported.]
[Using ROUND 1 point BRUSH]" T)
                 (SETQ WIDTH (DSPSCALE NIL STREAM)))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM "
gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 
                                                             (* ; 
                                               "COLOR is specified in POSTSCRIPT setgray notation.")
                          )
                   (if (LISTP DASHING)
                       then (POSTSCRIPT.OUTSTR STREAM " [")
                             (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM
                                                                     (TIMES D WIDTH)
                                                                     " "))
                             (POSTSCRIPT.OUTSTR STREAM "] 0 setdash
")                                                           (* ; 
         "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")
                          )
                   (POSTSCRIPT.PUTCOMMAND STREAM WIDTH 
                          " setlinewidth 1 setlinecap 1 setlinejoin " CENTERX " " CENTERY " " RADIUS
                          " " STARTANGLE " " (+ STARTANGLE NDEGREES)
                          " arc stroke
grestore"))
         (\MOVETO.PSC STREAM CENTERX CENTERY])

(\DRAWCIRCLE.PSC
  [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING)
                                                      (* ; "Edited  9-Sep-88 10:59 by Matt Heffron")
    (LET (WIDTH COLOR)
         (if (NUMBERP BRUSH)
             then (SETQ WIDTH BRUSH)
           elseif (LISTP BRUSH)
             then (if (NEQ (fetch BRUSHSHAPE of BRUSH)
                                   'ROUND)
                          then (printout T T 
                           "[In \DRAWCIRCLE.PSC: Non-ROUND BRUSH not supported.]
[Using ROUND BRUSH]" T))
                   (SETQ WIDTH (fetch BRUSHSIZE of BRUSH))
                   (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))
           else                                          (* ; 
                                                           "If FUNCTIONAL BRUSH big trouble!")
                 (printout T T 
                      "[In \DRAWCIRCLE.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
                 (SETQ WIDTH 1))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM "
gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 
                                                             (* ; 
                                               "COLOR is specified in POSTSCRIPT setgray notation.")
                          )
                   (if (LISTP DASHING)
                       then (POSTSCRIPT.OUTSTR STREAM " [")
                             (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM
                                                                     (TIMES D WIDTH)
                                                                     " "))
                             (POSTSCRIPT.OUTSTR STREAM "] 0 setdash
")                                                           (* ; 
         "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")
                          )
                   (POSTSCRIPT.PUTCOMMAND STREAM WIDTH 
                          " setlinewidth 1 setlinecap 1 setlinejoin " CENTERX " " CENTERY " " RADIUS
                          " 0 360 arc stroke
grestore"))
         (\MOVETO.PSC STREAM CENTERX CENTERY])

(\DRAWCURVE.PSC
  [LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING)     (* ; "Edited  9-Sep-88 10:56 by Matt Heffron")
    (LET (WIDTH SHAPE COLOR PSPLINE XA YA DXA DYA N PREVX PREVY PREV-DX3 PREV-DY3)
         (if (NUMBERP BRUSH)
             then (SETQ WIDTH BRUSH)
                   (SETQ SHAPE 'ROUND)
           elseif (LISTP BRUSH)
             then (SETQ WIDTH (fetch BRUSHSIZE of BRUSH))
                   (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH))
                   (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))
           else 

                 (* ;; "If FUNCTIONAL BRUSH then BIG trouble!")

                 (printout T T 
                       "[In \DRAWCURVE.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
                 (SETQ WIDTH (DSPSCALE NIL STREAM))
                 (SETQ SHAPE 'ROUND))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM "
gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 

                             (* ;; "COLOR is specified in POSTSCRIPT setgray notation.")
)
                   (if (LISTP DASHING)
                       then (POSTSCRIPT.OUTSTR STREAM " [")
                             (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM
                                                                     (TIMES D WIDTH)
                                                                     " "))
                             (POSTSCRIPT.OUTSTR STREAM "] 0 setdash
") 
                             (* ;; 
         "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")
)
                   (SETQ PSPLINE (PARAMETRICSPLINE KNOTS CLOSED NIL))
                   (SETQ N (pop PSPLINE))
                   (SETQ XA (pop PSPLINE))
                   (SETQ YA (pop PSPLINE))
                   (SETQ DXA (pop PSPLINE))
                   (SETQ DYA (pop PSPLINE))
                   (POSTSCRIPT.PUTCOMMAND STREAM (SELECTQ SHAPE
                                                         (ROUND " 1 setlinecap 1 setlinejoin ")
                                                         (SQUARE " 2 setlinecap 0 setlinejoin ")
                                                         " 0 setlinecap 0 setlinejoin ")
                          WIDTH " setlinewidth " (SETQ PREVX (ELT XA 1))
                          " "
                          (SETQ PREVY (ELT YA 1))
                          " mto
")
                   (SETQ PREV-DX3 (FQUOTIENT (ELT DXA 1)
                                         3.0))
                   (SETQ PREV-DY3 (FQUOTIENT (ELT DYA 1)
                                         3.0))
                   (for C from 2 to N
                      do (POSTSCRIPT.PUTCOMMAND STREAM (FPLUS PREVX PREV-DX3)
                                    " "
                                    (FPLUS PREVY PREV-DY3)
                                    " "
                                    (FDIFFERENCE (SETQ PREVX (ELT XA C))
                                           (SETQ PREV-DX3 (FQUOTIENT (ELT DXA C)
                                                                 3.0)))
                                    " "
                                    (FDIFFERENCE (SETQ PREVY (ELT YA C))
                                           (SETQ PREV-DY3 (FQUOTIENT (ELT DYA C)
                                                                 3.0)))
                                    " " PREVX " " PREVY " curveto
"))
                   (POSTSCRIPT.PUTCOMMAND STREAM "stroke
grestore"))
         (\MOVETO.PSC STREAM PREVX PREVY))
    NIL])

(\DRAWELLIPSE.PSC
  [LAMBDA (STREAM CENTERX CENTERY MINORRADIUS MAJORRADIUS ORIENTATION BRUSH DASHING)
                                                      (* ; "Edited  9-Sep-88 10:59 by Matt Heffron")
    (LET (WIDTH COLOR)
         (if (NUMBERP BRUSH)
             then (SETQ WIDTH BRUSH)
           elseif (LISTP BRUSH)
             then (if (NEQ (fetch BRUSHSHAPE of BRUSH)
                                   'ROUND)
                          then (printout T T 
                          "[In \DRAWELLIPSE.PSC: Non-ROUND BRUSH not supported.]
[Using ROUND BRUSH]" T))
                   (SETQ WIDTH (fetch BRUSHSIZE of BRUSH))
                   (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))
           else                                          (* ; 
                                                           "If FUNCTIONAL BRUSH, big trouble!")
                 (printout T T 
                     "[In \DRAWELLIPSE.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
                 (SETQ WIDTH 1))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM "
gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 
                                                             (* ; 
                                               "COLOR is specified in POSTSCRIPT setgray notation.")
                          )
                   (if (LISTP DASHING)
                       then (POSTSCRIPT.OUTSTR STREAM " [")
                             (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM
                                                                     (TIMES D WIDTH)
                                                                     " "))
                             (POSTSCRIPT.OUTSTR STREAM "] 0 setdash
")                                                           (* ; 
         "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")
                          )
                   (POSTSCRIPT.PUTCOMMAND STREAM WIDTH 
                          " setlinewidth 1 setlinecap 1 setlinejoin " CENTERX " " CENTERY " " 
                          MAJORRADIUS " " MINORRADIUS " " ORIENTATION 
                          " 0 360 ellipse stroke
grestore"))
         (\MOVETO.PSC STREAM CENTERX CENTERY])

(\DRAWLINE.PSC
  [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING)
                                                             (* ; "Edited 22-Feb-89 11:26 by snow")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (if (NOT (NUMBERP WIDTH))
             then 

                   (* ;; "The WIDTH = NIL should have been handled before here, but just in case!")

                   (SETQ WIDTH (DSPSCALE NIL STREAM)))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM "
gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 

                             (* ;; "COLOR is specified in POSTSCRIPT setgray notation.")
)
                   (if (LISTP DASHING)
                       then (POSTSCRIPT.OUTSTR STREAM " [")
                             (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM
                                                                     (TIMES D WIDTH)
                                                                     " "))
                             (POSTSCRIPT.OUTSTR STREAM "] 0 setdash
") 
                             (* ;; 
         "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")
)
                   (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 0 setlinecap " X1 " " Y1 
                          " mto " X2 " " Y2 " lineto stroke
grestore " X2 " " Y2 " mto "))
         (replace POSTSCRIPTX of IMAGEDATA with X2)
         (replace POSTSCRIPTY of IMAGEDATA with Y2])

(\DRAWPOLYGON.PSC
  [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING)    (* ; "Edited  9-Sep-88 11:00 by Matt Heffron")
    (LET ((LASTPOINT (CAR (LAST POINTS)))
          WIDTH SHAPE COLOR)
         (if (NUMBERP BRUSH)
             then (SETQ WIDTH BRUSH)
                   (SETQ SHAPE 'ROUND)
           elseif (LISTP BRUSH)
             then (SETQ WIDTH (fetch BRUSHSIZE of BRUSH))
                   (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH))
                   (SETQ COLOR (fetch BRUSHCOLOR of BRUSH))
           else 

                 (* ;; "If FUNCTIONAL BRUSH then BIG trouble!")

                 (printout T T 
                     "[In \DRAWPOLYGON.PSC: Functional BRUSH not supported.]
[Using (ROUND 1) BRUSH]" T)
                 (SETQ WIDTH (DSPSCALE NIL STREAM))
                 (SETQ SHAPE 'ROUND))
         (if (NOT (ZEROP WIDTH))
             then (POSTSCRIPT.PUTCOMMAND STREAM "
gsave newpath ")
                   (if (FLOATP COLOR)
                       then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") 

                             (* ;; "COLOR is specified in POSTSCRIPT setgray notation.")
)
                   (if (LISTP DASHING)
                       then (POSTSCRIPT.OUTSTR STREAM " [")
                             (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM
                                                                     (TIMES D WIDTH)
                                                                     " "))
                             (POSTSCRIPT.OUTSTR STREAM "] 0 setdash
")                                                           (* ; 
         "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.")
                          )
                   (POSTSCRIPT.PUTCOMMAND STREAM (SELECTQ SHAPE
                                                         (ROUND " 1 setlinecap 1 setlinejoin ")
                                                         (SQUARE " 2 setlinecap 0 setlinejoin ")
                                                         " 0 setlinecap 0 setlinejoin ")
                          WIDTH " setlinewidth " (fetch XCOORD of (CAR POINTS))
                          " "
                          (fetch YCOORD of (CAR POINTS))
                          " mto
")
                   (for P in (CDR POINTS) do (POSTSCRIPT.PUTCOMMAND STREAM
                                                                (fetch XCOORD of P)
                                                                " "
                                                                (fetch YCOORD of P)
                                                                " lineto
"))
                   (if CLOSED
                       then (POSTSCRIPT.PUTCOMMAND STREAM " closepath"))
                   (POSTSCRIPT.PUTCOMMAND STREAM " stroke
grestore"))
         (\MOVETO.PSC STREAM (fetch XCOORD of LASTPOINT)
                (fetch YCOORD of LASTPOINT])

(\DSPBOTTOMMARGIN.PSC
  [LAMBDA (STREAM YPOSITION)                      (* ; "Edited 12-Jan-88 13:14 by Matt Heffron")
    (PROG1 (fetch POSTSCRIPTBOTTOMMARGIN of (fetch IMAGEDATA of STREAM))
        (if YPOSITION
            then (replace POSTSCRIPTBOTTOMMARGIN of (fetch IMAGEDATA of STREAM)
                        with YPOSITION)))])

(\DSPCLIPPINGREGION.PSC
  [LAMBDA (STREAM REGION)                         (* ; "Edited 12-Jan-88 13:15 by Matt Heffron")
    (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
           (CURRGN (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA))
           (SCALE (fetch POSTSCRIPTSCALE of IMAGEDATA))
           (LONGEDGE (TIMES \POSTSCRIPT.LONGEDGE.PTS (QUOTIENT 10000 SCALE)))
           (SHORTEDGE (TIMES \POSTSCRIPT.SHORTEDGE.PTS (QUOTIENT 10000 SCALE)))
           RGN WIDTH DEFREGION)
          (SETQ DEFREGION
           (if (fetch POSTSCRIPTLANDSCAPE of IMAGEDATA)
               then (create REGION
                               LEFT _ 0.0
                               BOTTOM _ 0.0
                               WIDTH _ LONGEDGE
                               HEIGHT _ SHORTEDGE)
             else (create REGION
                             LEFT _ 0.0
                             BOTTOM _ 0.0
                             WIDTH _ SHORTEDGE
                             HEIGHT _ LONGEDGE)))
          (if REGION
              then (SETQ RGN (INTERSECTREGIONS REGION DEFREGION)) 

                    (* ;; "If the new clipping region doesn't intersect with the default for the appropriate page orientation, just ignore this and reset to the default.")

                    (if RGN
                        then (replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA with
                                                                                        RGN)
                              (SETQ WIDTH (fetch (REGION WIDTH) of RGN))
                              (POSTSCRIPT.PUTCOMMAND STREAM " initclip newpath "
                                     (fetch LEFT of RGN)
                                     " "
                                     (fetch BOTTOM of RGN)
                                     " moveto " WIDTH " 0 rlineto 0 " (fetch (REGION HEIGHT)
                                                                         of RGN)
                                     " rlineto "
                                     (IMINUS WIDTH)
                                     " 0 rlineto closepath
 clip newpath")
                      else DEFREGION))
          CURRGN])

(\DSPFONT.PSC
  [LAMBDA (STREAM FONT)                           (* ; "Edited  9-Sep-88 10:57 by Matt Heffron")
    (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
           FONTID)
          (PROG1 (fetch POSTSCRIPTFONT of IMAGEDATA)
              [if FONT
                  then (SETQ FONT (SELECTQ (TYPENAME FONT)
                                          (FONTDESCRIPTOR 
                                               FONT)
                                          (FONTCLASS (FONTCREATE FONT NIL NIL NIL STREAM))
                                          (SHOULDNT "arg not FONT descriptor or class")))
                        (if (NEQ (IMAGESTREAMTYPE STREAM)
                                     (fetch FONTDEVICE of FONT))
                            then (SETQ FONT (with FONTDESCRIPTOR FONT
                                                       (FONTCREATE FONTFAMILY FONTSIZE FONTFACE NIL 
                                                              STREAM]
              [if (AND FONT (NEQ FONT (fetch POSTSCRIPTFONT of IMAGEDATA)))
                  then (SETQ FONTID (fetch (PSCFONT IL-FONTID) of (fetch (
                                                                                       FONTDESCRIPTOR
                                                                                          
                                                                                       FONTDEVICESPEC
                                                                                          )
                                                                                 of FONT)))
                        (if (LISTP FONTID)
                            then (POSTSCRIPT.PUTCOMMAND STREAM "
/" (fetch FONTIDNAME of FONTID)
                                            " findfont ["
                                            (TIMES (fetch FONTXFACTOR of FONTID)
                                                   (fetch (FONTDESCRIPTOR FONTSIZE) of FONT)
                                                   100)
                                            " 0 "
                                            (TIMES (fetch FONTOBLIQUEFACTOR of FONTID)
                                                   (fetch (FONTDESCRIPTOR FONTSIZE) of FONT)
                                                   100)
                                            " "
                                            (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT)
                                                   100)
                                            " 0 0] makefont setfont
")
                          else (POSTSCRIPT.PUTCOMMAND STREAM "
/" FONTID " findfont " (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT)
                              100)
                                          " scalefont setfont
"))
                        (replace POSTSCRIPTFONT of IMAGEDATA with FONT)
                        (\DSPLINEFEED.PSC STREAM (IMINUS (fetch (FONTDESCRIPTOR \SFHeight)
                                                                of FONT])])

(\DSPLEFTMARGIN.PSC
  [LAMBDA (STREAM XPOSITION)                      (* ; "Edited 12-Jan-88 13:15 by Matt Heffron")
    (PROG1 (fetch POSTSCRIPTLEFTMARGIN of (fetch IMAGEDATA of STREAM))
        (if XPOSITION
            then (replace POSTSCRIPTLEFTMARGIN of (fetch IMAGEDATA of STREAM)
                        with XPOSITION)))])

(\DSPLINEFEED.PSC
  [LAMBDA (STREAM LINELEADING)                    (* ; "Edited 12-Jan-88 13:16 by Matt Heffron")
    (PROG1 (fetch POSTSCRIPTLINESPACING of (fetch IMAGEDATA of STREAM))
        (if LINELEADING
            then (replace POSTSCRIPTLINESPACING of (fetch IMAGEDATA of STREAM)
                        with LINELEADING)))])

(\DSPRESET.PSC
  [LAMBDA (STREAM)                                (* ; "Edited  9-Sep-88 11:00 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (\MOVETO.PSC STREAM (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA)
                (DIFFERENCE (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA)
                       (FONTPROP (fetch POSTSCRIPTFONT of IMAGEDATA)
                              'ASCENT])

(\DSPRIGHTMARGIN.PSC
  [LAMBDA (STREAM XPOSITION)                      (* ; "Edited 12-Jan-88 13:16 by Matt Heffron")
    (PROG1 (fetch POSTSCRIPTRIGHTMARGIN of (fetch IMAGEDATA of STREAM))
        (if XPOSITION
            then (replace POSTSCRIPTRIGHTMARGIN of (fetch IMAGEDATA of STREAM)
                        with XPOSITION)))])

(\DSPSCALE.PSC
  [LAMBDA (STREAM SCALE)                          (* ; "Edited 28-Sep-87 13:30 by Matt Heffron")
    (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM))
           (OSCALE (fetch POSTSCRIPTSCALE of IMAGEDATA))
           NSCALE)
          (if (AND NIL 

                       (* ;; "Changing SCALE is not implemented.  According to IRM.")

                       (NUMBERP SCALE)
                       (CL:PLUSP SCALE))
              then (SETQ NSCALE (QUOTIENT SCALE OSCALE)) 

                    (* ;; 
      "NSCALE is the adjustment for the fact that the scale operator takes RELATIVE scale changes.")

                    (POSTSCRIPT.PUTCOMMAND STREAM " " NSCALE " " NSCALE " scale")
                    (replace POSTSCRIPTSCALE of IMAGEDATA with SCALE))
          OSCALE])

(\DSPSPACEFACTOR.PSC
  [LAMBDA (STREAM FACTOR)                         (* ; "Edited 12-Jan-88 13:49 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (PROG1 (fetch POSTSCRIPTSPACEFACTOR of IMAGEDATA)
             (if FACTOR
                 then (POSTSCRIPT.SHOWACCUM STREAM)
                       (replace POSTSCRIPTSPACEFACTOR of IMAGEDATA with FACTOR)))])

(\DSPTOPMARGIN.PSC
  [LAMBDA (STREAM YPOSITION)                      (* ; "Edited 12-Jan-88 13:17 by Matt Heffron")
    (PROG1 (fetch POSTSCRIPTTOPMARGIN of (fetch IMAGEDATA of STREAM))
        (if YPOSITION
            then (replace POSTSCRIPTTOPMARGIN of (fetch IMAGEDATA of STREAM)
                        with YPOSITION)))])

(\DSPXPOSITION.PSC
  [LAMBDA (STREAM XPOSITION)                      (* ; "Edited  9-Sep-88 10:58 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))
          OLDX)
         (PROG1 (SETQ OLDX (fetch POSTSCRIPTX of IMAGEDATA))
             (if (AND XPOSITION (NOT (EQUAL XPOSITION OLDX)))
                 then (\MOVETO.PSC STREAM XPOSITION (fetch POSTSCRIPTY of IMAGEDATA))
                    ))])

(\DSPYPOSITION.PSC
  [LAMBDA (STREAM YPOSITION)                      (* ; "Edited  9-Sep-88 10:58 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))
          OLDY)
         (PROG1 (SETQ OLDY (fetch POSTSCRIPTY of IMAGEDATA))
             (if (AND YPOSITION (NOT (EQUAL YPOSITION OLDY)))
                 then (\MOVETO.PSC STREAM (fetch POSTSCRIPTX of IMAGEDATA)
                                 YPOSITION)))])

(\FILLCIRCLE.PSC
  [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE) (* ; "Edited  9-Sep-88 11:00 by Matt Heffron")
    (LET (TEXTUREBM TEXTUREWIDTH)
         (POSTSCRIPT.PUTCOMMAND STREAM "
gsave
 newpath ")
         (if (FIXP TEXTURE)
             then (if (ZEROP TEXTURE)
                          then (SETQ TEXTURE 1.0)        (* ; "The setgray version of white")
                        elseif (OR (EQL TEXTURE 65535)
                                       (EQL TEXTURE -1))
                          then (SETQ TEXTURE 0.0)        (* ; "The setgray version of black")
                             ))
         (if (FLOATP TEXTURE)
             then 

                   (* ;; 
                 "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.")

                   (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ")
           elseif (OR (TEXTUREP TEXTURE)
                          (NULL TEXTURE))
             then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1))
                   (SETQ TEXTUREWIDTH 16)
                   (BLTSHADE TEXTURE TEXTUREBM)
           elseif (BITMAPP TEXTURE)
             then (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM)
                                              (fetch BITMAPHEIGHT of TEXTUREBM)))
                   (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1))
                   (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE))
         (POSTSCRIPT.PUTCOMMAND STREAM " " CENTERX " " CENTERY " " RADIUS " 0 360 arc
")
         (if TEXTUREBM
             then (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale ")
                   (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T)
                   (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " (LSH (fetch 
                                                                                  BITMAPRASTERWIDTH
                                                                              of TEXTUREBM)
                                                                           1)
                          " 0 "
                          (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM)
                                           100.0))
                          " findresolution " TEXTUREWIDTH " div div ceiling " 
                          POSTSCRIPT.TEXTURE.SCALE " mul setpattern eofill
grestore
")
           else (POSTSCRIPT.PUTCOMMAND STREAM " eofill
grestore
"))
         (\MOVETO.PSC STREAM CENTERX CENTERY])

(\FILLPOLYGON.PSC
  [LAMBDA (STREAM KNOTS TEXTURE OPERATION WINDNUMBER)
                                                      (* ; "Edited  9-Sep-88 11:01 by Matt Heffron")
    (DECLARE (SPECVARS FILL.WRULE))

    (* ;; "OPERATION is ignored here")

    (LET ((LASTPOINT (CAR (LAST KNOTS)))
          TEXTUREBM TEXTUREWIDTH)
         (POSTSCRIPT.PUTCOMMAND STREAM "
gsave
 newpath ")
         (if (NOT (OR (ZEROP WINDNUMBER)
                          (EQL WINDNUMBER 1)))
             then (SETQ WINDNUMBER FILL.WRULE))
         (if (FIXP TEXTURE)
             then (if (ZEROP TEXTURE)
                          then (SETQ TEXTURE 1.0)        (* ; "The setgray version of white")
                        elseif (OR (EQL TEXTURE 65535)
                                       (EQL TEXTURE -1))
                          then (SETQ TEXTURE 0.0)        (* ; "The setgray version of black")
                             ))
         (if (FLOATP TEXTURE)
             then 

                   (* ;; 
                 "If TEXTURE is a FLOATP, then it is specified in PostScript setgray notation.")

                   (POSTSCRIPT.PUTCOMMAND STREAM TEXTURE " setgray ")
           elseif (OR (TEXTUREP TEXTURE)
                          (NULL TEXTURE))
             then (SETQ TEXTUREBM (BITMAPCREATE 16 16 1))
                   (SETQ TEXTUREWIDTH 16)
                   (BLTSHADE TEXTURE TEXTUREBM)
           elseif (BITMAPP TEXTURE)
             then (SETQ TEXTUREWIDTH (MIN (fetch BITMAPWIDTH of TEXTUREBM)
                                              (fetch BITMAPHEIGHT of TEXTUREBM)))
                   (SETQ TEXTUREBM (BITMAPCREATE TEXTUREWIDTH TEXTUREWIDTH 1))
                   (BITBLT TEXTURE 0 0 TEXTUREBM 0 0 TEXTUREWIDTH TEXTUREWIDTH 'INPUT 'REPLACE))
         (POSTSCRIPT.PUTCOMMAND STREAM (fetch XCOORD of (CAR KNOTS))
                " "
                (fetch YCOORD of (CAR KNOTS))
                " mto
")
         (for K in (CDR KNOTS) do (POSTSCRIPT.PUTCOMMAND STREAM (fetch XCOORD
                                                                                   of K)
                                                     " "
                                                     (fetch YCOORD of K)
                                                     " lineto
"))
         (POSTSCRIPT.PUTCOMMAND STREAM " closepath
")
         (if TEXTUREBM
             then (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale ")
                   (POSTSCRIPT.PUTBITMAPBYTES STREAM TEXTUREBM T)
                   (POSTSCRIPT.PUTCOMMAND STREAM TEXTUREWIDTH " " (LSH (fetch 
                                                                                  BITMAPRASTERWIDTH
                                                                              of TEXTUREBM)
                                                                           1)
                          " 0 "
                          (TIMES 72 (QUOTIENT (DSPSCALE NIL STREAM)
                                           100.0))
                          " findresolution " TEXTUREWIDTH " div div ceiling " 
                          POSTSCRIPT.TEXTURE.SCALE " mul setpattern"))
         (POSTSCRIPT.PUTCOMMAND STREAM (if (ZEROP WINDNUMBER)
                                               then " fill
grestore
"
                                             else " eofill
grestore
"))
         (\MOVETO.PSC STREAM (fetch XCOORD of LASTPOINT)
                (fetch YCOORD of LASTPOINT])

(\MOVETO.PSC
  [LAMBDA (STREAM X Y)                            (* ; "Edited 12-Jan-88 13:18 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (POSTSCRIPT.PUTCOMMAND STREAM " " X " " Y " mto
")
         (with \POSTSCRIPTDATA IMAGEDATA (SETQ POSTSCRIPTX X)
                (SETQ POSTSCRIPTY Y])

(\NEWPAGE.PSC
  [LAMBDA (STREAM)                                (* ; "Edited 20-Jan-88 17:36 by Matt Heffron")
    (POSTSCRIPT.PUTCOMMAND STREAM "
 savepage restore
showpage")
    (POSTSCRIPT.STARTPAGE STREAM])

(\POSTSCRIPT.OUTCHARFN
  [LAMBDA (STREAM CHAR)                           (* ; "Edited  9-Sep-88 11:02 by Matt Heffron")
    (LET* ((POSTSCRIPTDATA (fetch IMAGEDATA of STREAM)))
          (SELCHARQ CHAR
               ((CR LF TENEXEOL) 
                    (\TERPRI.PSC STREAM))
               (FF (\NEWPAGE.PSC STREAM))
               (PROGN (if (NOT (fetch POSTSCRIPTCHARSTOSHOW of POSTSCRIPTDATA))
                          then (POSTSCRIPT.OUTSTR STREAM " (")
                                (replace POSTSCRIPTCHARSTOSHOW of POSTSCRIPTDATA with
                                                                                         T))
                      (\POSTSCRIPT.PUTCHAR STREAM CHAR])

(\POSTSCRIPT.PUTCHAR
  [LAMBDA (STREAM CHAR)                           (* ; "Edited  5-Feb-88 10:29 by Matt Heffron")
    (LET* ((POSTSCRIPTDATA (fetch IMAGEDATA of STREAM))
           (FONT (fetch POSTSCRIPTFONT of POSTSCRIPTDATA))
           TEMP)
          (SETQ CHAR (LOGAND CHAR 255))                      (* ; 
                                                           "no NS character set treatment yet")
          (if (EQ CHAR (CHARCODE TAB))
              then (RPTQ 8 (\POSTSCRIPT.PUTCHAR STREAM (CHARCODE SPACE))) 
                                                             (* ; "wimpy, but no better way yet.")
            else (if (FMEMB CHAR (CHARCODE (%( %) \)))
                         then (BOUT STREAM (CHARCODE \))
                               (BOUT STREAM CHAR)
                       elseif (NOT (<= (CHARCODE SPACE)
                                           CHAR 126))
                         then (BOUT STREAM (CHARCODE \))
                               (SETQ TEMP (CHCON (OCTALSTRING CHAR)))
                               (if (< (LENGTH TEMP)
                                          3)
                                   then (SETQ TEMP (APPEND
                                                        [if (CDR TEMP)
                                                            then (CONSTANT (CHARCODE (0)))
                                                          else (CONSTANT (CHARCODE (0 0]
                                                        TEMP)))
                               (for CC in TEMP do (BOUT STREAM CC))
                       else (BOUT STREAM CHAR))
                  (add (fetch POSTSCRIPTX of POSTSCRIPTDATA)
                         (\FGETWIDTH (fetch FONTIMAGEWIDTHS of FONT)
                                CHAR)))
          CHAR])

(\STRINGWIDTH.PSC
  [LAMBDA (STREAM STR RDTBL)                                 (* DECLARATIONS%: INTEGER)
                                                             (* ; 
                                                           "Edited 12-Jan-88 13:27 by Matt Heffron")
    (LET* [(FNT (DSPFONT NIL STREAM))
           (SPACEFACTOR (fetch POSTSCRIPTSPACEFACTOR of (fetch (STREAM IMAGEDATA)
                                                                   of STREAM)))
           (WA (fetch (PSCFONT WIDTHS) of (fetch (FONTDESCRIPTOR FONTDEVICESPEC)
                                                     of FNT)))
           (W (for CI from 1 to (NCHARS STR)
                 sum (LET* ((CC (LOGAND 255 (NTHCHARCODE STR CI NIL RDTBL)))
                                (WID (ELT WA CC)))
                               (if (EQ CC (CHARCODE SPACE))
                                   then (TIMES WID SPACEFACTOR)
                                 else WID]
          (FIXR (TIMES W (fetch (FONTDESCRIPTOR FONTSIZE) of FNT)
                       0.1])

(\TERPRI.PSC
  [LAMBDA (STREAM)                                (* ; "Edited  9-Sep-88 11:02 by Matt Heffron")
    (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)))
         (with \POSTSCRIPTDATA IMAGEDATA (SETQ POSTSCRIPTX POSTSCRIPTLEFTMARGIN)
                (SETQ POSTSCRIPTY (IPLUS POSTSCRIPTY POSTSCRIPTLINESPACING))

                (* ;; "IPLUS because POSTSCRIPTLINESPACING is -ve if correct.")

                (if (LESSP POSTSCRIPTY (IPLUS (fetch (FONTDESCRIPTOR \SFDescent) of
                                                                                         
                                                                                       POSTSCRIPTFONT
                                                         )
                                                  POSTSCRIPTBOTTOMMARGIN))
                    then (\NEWPAGE.PSC STREAM)
                  else (\MOVETO.PSC STREAM POSTSCRIPTX POSTSCRIPTY])

(\DSPROTATE.PSC
  [LAMBDA (STREAM ROTATION)                              (* ; "Edited 22-Feb-89 13:47 by snow")

    (* ;; "rotate the postscript  stream by ROTATION")

    (* ;; "we only know 90 degrees of rotation for now.")

    (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)))
         (replace POSTSCRIPTLANDSCAPE of IMAGEDATA with (IF (EQ ROTATION 0)
                                                                        THEN NIL
                                                                      ELSE T))
         (\NEWPAGE.PSC STREAM))
    1])

(\DSPTRANSLATE.PSC
  [LAMBDA (STREAM TX TY)                                 (* ; "Edited 22-Feb-89 11:40 by snow")

    (* ;; "the translation happens automatically when we do a rotate.  This isn't really a translate function, but it works for the simple rotate by 90 case that occurs most often.")

    1])

(\DRAWPOINT.PSC
  [LAMBDA (STREAM X Y BRUSH OPERATION)                   (* ; "Edited 22-Feb-89 15:24 by snow")

    (* ;; "draw a point on the stream ")

    (IF (BITMAPP BRUSH)
        THEN (LET ((WIDTH (BITMAPWIDTH BRUSH))
                       (HEIGHT (BITMAPHEIGHT BRUSH)))
                      (BITBLT BRUSH 0 0 STREAM (- X (IQUOTIENT WIDTH 2))
                             (- Y (IQUOTIENT HEIGHT 2))
                             WIDTH HEIGHT OPERATION))
      ELSE (\DRAWLINE.PSC STREAM X Y X Y BRUSH OPERATION])
)

(RPAQ \POSTSCRIPT.ORIENTATION.MENU (create MENU ITEMS _ '(("Landscape" T 
                                            "Print this file/document/image in Landscape Orientation"
                                                                     )
                                                              ("Portrait" 'NIL 
                                             "Print this file/document/image in Portrait Orientation"
                                                                     ))
                                              TITLE _ "Orientation" CENTERFLG _ T MENUOFFSET _
                                              (create POSITION XCOORD _ -1 YCOORD _ 0)
                                              CHANGEOFFSETFLG _ 'Y))

(RPAQ PS.BITMAPARRAY (READARRAY-FROM-LIST 16 (QUOTE BYTE) 0 (QUOTE (48 49 50 51 52 53 54 55 56 57 65 
66 67 68 69 70 NIL))))


(RPAQQ \POSTSCRIPT.JOB.SETUP 
       ("/s /show load def" "/mto /moveto load def" "/ellipsedict 9 dict def" 
              "ellipsedict /mtrx matrix put" "/ellipse" " { ellipsedict begin" "  /endangle exch def"
              "  /startangle exch def" "  /orientation exch def" "  /minorrad exch def" 
              "  /majorrad exch def" "  /y exch def" "  /x exch def" 
              "  /savematrix mtrx currentmatrix def" "  x y translate" "  orientation rotate" 
              "  majorrad minorrad scale" "  0 0 1 startangle endangle arc" "  savematrix setmatrix"
              " end } bind def" "/concatprocs" " {/proc2 exch cvlit def" "  /proc1 exch cvlit def" 
              "  /newproc proc1 length proc2 length add array def" "  newproc 0 proc1 putinterval" 
              "  newproc proc1 length proc2 putinterval" "  newproc cvx" " } bind def" 
              "/resmatrix matrix def" "/findresolution" " {72 0 resmatrix defaultmatrix dtransform" 
              "  /yres exch def /xres exch def" "  xres dup mul yres dup mul add sqrt" " } bind def"
              "/thebitimage" " {/maskp exch def" "  /bihgt exch def" "  /biwid exch def" 
              "  /strbuf biwid 8 div ceiling cvi string def" 
              "  {1 exch sub} currenttransfer concatprocs settransfer" "  biwid bihgt" 
              "  maskp { false } { 1 } ifelse" "  [biwid 0 0 bihgt 0 0]" 
              "  { currentfile strbuf readhexstring pop }" "  maskp { imagemask } { image } ifelse" 
              " } bind def" "/setuserscreendict 22 dict def" "setuserscreendict begin" 
              " /tempctm matrix def" " /temprot matrix def" " /tempscale matrix def" "end" 
              "/setuserscreen" " {setuserscreendict begin" "   /spotfunction exch def" 
              "   /screenangle exch def" "   /cellsize exch def" "   /m tempctm currentmatrix def" 
              "   /rm screenangle temprot rotate def" "   /sm cellsize dup tempscale scale def" 
              "   sm rm m m concatmatrix m concatmatrix pop" 
              "   1 0 m dtransform /y1 exch def /x1 exch def" 
              "   /veclength x1 dup mul y1 dup mul add sqrt def" 
              "   /frequency findresolution veclength div def" "   /newscreenangle y1 x1 atan def" 
              "   m 2 get m 1 get mul m 0 get m 3 get mul sub" 
              "   0 gt { { neg } /spotfunction load concatprocs" 
              "          /spotfunction exch def } if" 
              "   frequency newscreenangle /spotfunction load setscreen" "  end" " } bind def" 
              "/setpatterndict 18 dict def" "setpatterndict begin" " /bitison" 
              "  {/ybit exch def /xbit exch def" 
              "   /bytevalue bstring ybit bwidth mul xbit 8 idiv add get def" 
              "   /mask 1 7 xbit 8 mod sub bitshift def" "   bytevalue mask and 0 ne" "  } bind def"
              "end" "/bitpatternspotfunction" " {setpatterndict begin" "   /y exch def /x exch def" 
              "   /xindex x 1 add 2 div bpside mul cvi def" 
              "   /yindex y 1 add 2 div bpside mul cvi def" "   xindex yindex bitison" 
              "    {/onbits onbits 1 add def 1}" "    {/offbits offbits 1 add def 0} ifelse" "  end"
              " } bind def" "/setpattern" " {setpatterndict begin" "   /cellsz exch def" 
              "   /angle exch def" "   /bwidth exch def" "   /bpside exch def" "   /bstring exch def"
              "   /onbits 0 def /offbits 0 def" 
              "   cellsz angle /bitpatternspotfunction load setuserscreen" "   {} settransfer" 
              "   offbits offbits onbits add div setgray" "  end" " } bind def" "%%%%EndProlog" 
              "%%%%BeginSetup" "clippath pathbbox" 
              "/ymax exch def /xmax exch def /ymin exch def /xmin exch def"))

(RPAQQ SlopeMenuItems ((Italic 'ITALIC "This is an Italic Slope font")
                           (Regular 'REGULAR "This is a Regular Slope font")))

(RPAQQ WeightMenuItems ((Bold 'BOLD "This is a Bold Weight font")
                            (Medium 'MEDIUM "This is a Medium Weight font")
                            (Light 'LIGHT "This is a Light Weight font")))
(DECLARE%: EVAL@COMPILE 

(RPAQQ GOLDEN.RATIO 1.618034)


(CONSTANTS (GOLDEN.RATIO 1.618034))
)

(RPAQ? POSTSCRIPT.BITMAP.SCALE 1)

(RPAQ? POSTSCRIPT.IMAGESIZEFACTOR 1.0)

(RPAQ? POSTSCRIPT.PREFER.LANDSCAPE NIL)

(RPAQ? POSTSCRIPT.TEXTFILE.LANDSCAPE NIL)

(RPAQ? POSTSCRIPT.TEXTURE.SCALE 4)

(RPAQ? POSTSCRIPTFONTDIRECTORIES '("{DSK}<LISPFILES>FONTS>PSC>"))

(RPAQ? \POSTSCRIPT.LONGEDGE.SHIFT 0)

(RPAQ? \POSTSCRIPT.SHORTEDGE.SHIFT 0)

(RPAQ? \POSTSCRIPT.LONGEDGE.PTS (+ (TIMES 72 10.92)
                                       \POSTSCRIPT.SHORTEDGE.SHIFT))

(RPAQ? \POSTSCRIPT.SHORTEDGE.PTS (+ (TIMES 72 8.0)
                                        \POSTSCRIPT.LONGEDGE.SHIFT))

(RPAQ? \POSTSCRIPT.MAX.WILD.FONTSIZE 72)

(ADDTOVAR POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA)
                                    (TIMESROMAN . TIMES)
                                    (TIMESROMAND . TIMES)
                                    (COURIER . COURIER)
                                    (GACHA . COURIER)
                                    (CLASSIC . TIMES)
                                    (MODERN . HELVETICA)
                                    (CREAM . HELVETICA)
                                    (TERMINAL . COURIER)
                                    (LOGO . HELVETICA))

(ADDTOVAR PRINTERTYPES ((POSTSCRIPT)
                            (CANPRINT (POSTSCRIPT))
                            (STATUS TRUE)
                            (PROPERTIES NILL)
                            (SEND POSTSCRIPT.SEND)
                            (BITMAPSCALE POSTSCRIPT.BITMAPSCALE)
                            (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION
                                               TITLE))))

(ADDTOVAR PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP)
                                    (EXTENSION (PS PSC))
                                    (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT))))

(ADDTOVAR IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM)
                                      (FONTCREATE POSTSCRIPT.FONTCREATE)
                                      (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE)
                                      (CREATECHARSET NILL)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.FONT.ALIST 
       POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE 
       POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.LONGEDGE.PTS 
       \POSTSCRIPT.LONGEDGE.SHIFT \POSTSCRIPT.MAX.WILD.FONTSIZE \POSTSCRIPT.ORIENTATION.MENU 
       \POSTSCRIPT.SHORTEDGE.PTS \POSTSCRIPT.SHORTEDGE.SHIFT \POSTSCRIPTIMAGEOPS)
)

(FILESLOAD PS-SEND)

(POSTSCRIPT.INIT)

(PUTPROPS POSTSCRIPT FILETYPE :TCOMPL)

(PUTPROPS POSTSCRIPT MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP"))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA POSTSCRIPT.PUTCOMMAND)
)
(PUTPROPS POSTSCRIPT COPYRIGHT ("Beckman Instruments, Inc" 1986 1987 1988 1989))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (9155 101635 (CLOSEPOSTSCRIPTSTREAM 9165 . 9380) (OPENPOSTSCRIPTSTREAM 9382 . 14794) (
POSTSCRIPT.BITMAPSCALE 14796 . 17008) (POSTSCRIPT.CLOSESTRING 17010 . 17459) (POSTSCRIPT.FONTCREATE 
17461 . 25278) (POSTSCRIPT.FONTSAVAILABLE 25280 . 29046) (POSTSCRIPT.GETFONTID 29048 . 30328) (
POSTSCRIPT.HARDCOPYW 30330 . 33031) (POSTSCRIPT.INIT 33033 . 38121) (POSTSCRIPT.OUTSTR 38123 . 38620) 
(POSTSCRIPT.PUTBITMAPBYTES 38622 . 40679) (POSTSCRIPT.PUTCOMMAND 40681 . 41085) (POSTSCRIPT.SHOWACCUM 
41087 . 42341) (POSTSCRIPT.STARTPAGE 42343 . 45870) (POSTSCRIPT.TEDIT 45872 . 46132) (POSTSCRIPT.TEXT 
46134 . 46609) (POSTSCRIPTFILEP 46611 . 47160) (PSCFONT.READFONT 47162 . 48234) (PSCFONT.SPELLFILE 
48236 . 48663) (PSCFONT.WRITEFONT 48665 . 49497) (READ-AFM-FILE 49499 . 53395) (\BITBLT.PSC 53397 . 
56573) (\BLTSHADE.PSC 56575 . 61298) (\CHARWIDTH.PSC 61300 . 62051) (\DRAWARC.PSC 62053 . 64572) (
\DRAWCIRCLE.PSC 64574 . 66993) (\DRAWCURVE.PSC 66995 . 70820) (\DRAWELLIPSE.PSC 70822 . 73341) (
\DRAWLINE.PSC 73343 . 75058) (\DRAWPOLYGON.PSC 75060 . 78208) (\DSPBOTTOMMARGIN.PSC 78210 . 78603) (
\DSPCLIPPINGREGION.PSC 78605 . 80921) (\DSPFONT.PSC 80923 . 84170) (\DSPLEFTMARGIN.PSC 84172 . 84559) 
(\DSPLINEFEED.PSC 84561 . 84952) (\DSPRESET.PSC 84954 . 85413) (\DSPRIGHTMARGIN.PSC 85415 . 85805) (
\DSPSCALE.PSC 85807 . 86661) (\DSPSPACEFACTOR.PSC 86663 . 87102) (\DSPTOPMARGIN.PSC 87104 . 87488) (
\DSPXPOSITION.PSC 87490 . 87953) (\DSPYPOSITION.PSC 87955 . 88430) (\FILLCIRCLE.PSC 88432 . 91049) (
\FILLPOLYGON.PSC 91051 . 94736) (\MOVETO.PSC 94738 . 95086) (\NEWPAGE.PSC 95088 . 95318) (
\POSTSCRIPT.OUTCHARFN 95320 . 96082) (\POSTSCRIPT.PUTCHAR 96084 . 98010) (\STRINGWIDTH.PSC 98012 . 
99148) (\TERPRI.PSC 99150 . 100132) (\DSPROTATE.PSC 100134 . 100753) (\DSPTRANSLATE.PSC 100755 . 
101078) (\DRAWPOINT.PSC 101080 . 101633)))))
STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT.PS b/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT.PS
deleted file mode 100644
index accfdb48..00000000
--- a/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT.PS
+++ /dev/null
@@ -1 +0,0 @@
-%!PS-Adobe-2.0
%%Title: POSTSCRIPT.PS
%%Creator: PostScript ImageStream Driver by Matt Heffron of Beckman Instruments
%%CreationDate:  9-Feb-88 14:19:16
%%For: Matt Heffron
%%EndComments
/s /show load def
/mto /moveto load def
/ellipsedict 9 dict def
ellipsedict /mtrx matrix put
/ellipse
 { ellipsedict begin
  /endangle exch def
  /startangle exch def
  /orientation exch def
  /minorrad exch def
  /majorrad exch def
  /y exch def
  /x exch def
  /savematrix mtrx currentmatrix def
  x y translate
  orientation rotate
  majorrad minorrad scale
  0 0 1 startangle endangle arc
  savematrix setmatrix
 end } bind def
/concatprocs
 {/proc2 exch cvlit def
  /proc1 exch cvlit def
  /newproc proc1 length proc2 length add array def
  newproc 0 proc1 putinterval
  newproc proc1 length proc2 putinterval
  newproc cvx
 } bind def
/resmatrix matrix def
/findresolution
 {72 0 resmatrix defaultmatrix dtransform
  /yres exch def /xres exch def
  xres dup mul yres dup mul add sqrt
 } bind def
/thebitimage
 {/maskp exch def
  /bihgt exch def
  /biwid exch def
  /strbuf biwid 8 div ceiling cvi string def
  {1 exch sub} currenttransfer concatprocs settransfer
  biwid bihgt
  maskp { false } { 1 } ifelse
  [biwid 0 0 bihgt 0 0]
  { currentfile strbuf readhexstring pop }
  maskp { imagemask } { image } ifelse
 } bind def
/setuserscreendict 22 dict def
setuserscreendict begin
 /tempctm matrix def
 /temprot matrix def
 /tempscale matrix def
end
/setuserscreen
 {setuserscreendict begin
   /spotfunction exch def
   /screenangle exch def
   /cellsize exch def
   /m tempctm currentmatrix def
   /rm screenangle temprot rotate def
   /sm cellsize dup tempscale scale def
   sm rm m m concatmatrix m concatmatrix pop
   1 0 m dtransform /y1 exch def /x1 exch def
   /veclength x1 dup mul y1 dup mul add sqrt def
   /frequency findresolution veclength div def
   /newscreenangle y1 x1 atan def
   m 2 get m 1 get mul m 0 get m 3 get mul sub
   0 gt { { neg } /spotfunction load concatprocs
          /spotfunction exch def } if
   frequency newscreenangle /spotfunction load setscreen
  end
 } bind def
/setpatterndict 18 dict def
setpatterndict begin
 /bitison
  {/ybit exch def /xbit exch def
   /bytevalue bstring ybit bwidth mul xbit 8 idiv add get def
   /mask 1 7 xbit 8 mod sub bitshift def
   bytevalue mask and 0 ne
  } bind def
end
/bitpatternspotfunction
 {setpatterndict begin
   /y exch def /x exch def
   /xindex x 1 add 2 div bpside mul cvi def
   /yindex y 1 add 2 div bpside mul cvi def
   xindex yindex bitison
    {/onbits onbits 1 add def 1}
    {/offbits offbits 1 add def 0} ifelse
  end
 } bind def
/setpattern
 {setpatterndict begin
   /cellsz exch def
   /angle exch def
   /bwidth exch def
   /bpside exch def
   /bstring exch def
   /onbits 0 def /offbits 0 def
   cellsz angle /bitpatternspotfunction load setuserscreen
   {} settransfer
   offbits offbits onbits add div setgray
  end
 } bind def
%%EndProlog
%%BeginSetup
clippath pathbbox
/ymax exch def /xmax exch def /ymin exch def /xmin exch def
/imagesizefactor 1.0 def
%%EndSetup

/Courier findfont 800 scalefont setfont

%%BeginPageSetup
xmin -5 add ymin 0 add translate
0.01 imagesizefactor mul 0.01 imagesizefactor mul scale
%%EndPageSetup
/savepage save def
newpath 0.0 0.0 mto 57100.0 0 rlineto 0 78624.0 rlineto -57100 0 rlineto closepath
 clip newpath

/Courier findfont 800 scalefont setfont
 0 77940 mto
 initclip newpath 0 0 moveto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath
 clip newpath 7200 73200 mto

/Helvetica findfont 2400 scalefont setfont
 (XEROX) show  15603 73200 mto

/Helvetica findfont 600 scalefont setfont
 46410 73200 mto
 46410 73200 mto

/Helvetica findfont 1000 scalefont setfont
 (POSTSCRIPT) show  52800 73200 mto
 7200 72470 mto

gsave newpath 200 setlinewidth 0 setlinecap 7200 72570 mto 52800 72570 lineto stroke
grestore 52800 72570 mto  52800 72470 mto
 52800 72470 mto
 21000 71599 mto

gsave newpath 400 setlinewidth 0 setlinecap 21000 71799 mto 38400 71799 lineto stroke
grestore 38400 71799 mto  38400 71599 mto
 38400 71599 mto
 21000 71099 mto

gsave newpath 100 setlinewidth 0 setlinecap 21000 71149 mto 38400 71149 lineto stroke
grestore 38400 71149 mto  38400 71099 mto
 38400 71099 mto
 25867 68971 mto

/Helvetica-Bold findfont 1200 scalefont setfont
 (POSTSCRIPT) show  33533 68971 mto
 21000 67606 mto

gsave newpath 100 setlinewidth 0 setlinecap 21000 67656 mto 38400 67656 lineto stroke
grestore 38400 67656 mto  38400 67606 mto
 38400 67606 mto
 21000 66806 mto

gsave newpath 400 setlinewidth 0 setlinecap 21000 67006 mto 38400 67006 lineto stroke
grestore 38400 67006 mto  38400 66806 mto
 38400 66806 mto
 17990 63766 mto

/Helvetica findfont 1000 scalefont setfont
 (By:  Matt Heffron \(BEC.HEFFRON@ECLA.USC.EDU\)) show  42009 63766 mto
 7200 61105 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (INTRODUCTION) show  14866 61105 mto

/Helvetica findfont 1000 scalefont setfont
 14866 61105 mto
 7200 58444 mto
 (The PostScript package defines a set of imageops for printers which understand the PostScript page) 81.00001 0 32 4 -1 roll widthshow  52800 58444 mto
 7200 56883 mto
 (description language by Adobe.  At Beckman we have successfully used TEdit, Sketch, and) 390.76923 0 32 4 -1 roll widthshow  52799 56883 mto
 7200 55322 mto
 (HARDCOPYW to an Apple LaserWriter and an AST TurboLaser PS.  \(Actually, the PostScript) 322.7692 0 32 4 -1 roll widthshow  52799 55322 mto
 7200 53761 mto
 (imagestream output was directed to a file, which was then moved to a PC which actually) 438.93338 0 32 4 -1 roll widthshow  52799 53761 mto
 7200 52200 mto
 (communicated with the laser printer.\)   The PostScript imagestream driver installs itself when it is) 191.0 0 32 4 -1 roll widthshow  52800 52200 mto
 7200 50639 mto
 (loaded.  All symbols in the PostScript driver are located in the INTERLISP: package.) show  44438 50639 mto
 7200 47978 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (VARIABLES) show  12978 47978 mto
 7200 45317 mto

/Helvetica findfont 1000 scalefont setfont
 (POSTSCRIPT.FONT.ALIST) show  19647 45317 mto

/Helvetica findfont 1000 scalefont setfont
 47242 45317 mto
 47242 45317 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 45317 mto
 7200 42656 mto
 (POSTSCRIPT.FONT.ALIST is an ALIST mapping Xerox Lisp font names intothe root names of) 307.8333 0 32 4 -1 roll widthshow  52799 42656 mto
 7200 41095 mto
 (PostScript font files.  It is also used for font family coercions.  The default value should be acceptable) 56.833324 0 32 4 -1 roll widthshow  52799 41095 mto
 7200 39534 mto
 (for any of the fonts which are built into the Apple Laserwriter.) show  34046 39534 mto
 7200 36873 mto
 (POSTSCRIPTFONTDIRECTORIES) show  23146 36873 mto

/Helvetica findfont 1000 scalefont setfont
 47242 36873 mto
 47242 36873 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 36873 mto
 7200 34212 mto
 (POSTSCRIPTFONTDIRECTORIES is the list of directories where the PostScript .PSCFONT font files) 58.54545 0 32 4 -1 roll widthshow  52799 34212 mto
 7200 32651 mto
 (can be found.  The default value is:  \("{DSK}<LISPFILES>FONTS>PSC>"\).) show  40427 32651 mto
 7200 29990 mto
 (\\POSTSCRIPT.SHORTEDGE.SHIFT) show  23647 29990 mto

/Helvetica findfont 1000 scalefont setfont
 47242 29990 mto
 47242 29990 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 29990 mto
 7200 27329 mto
 (\\POSTSCRIPT.SHORTEDGE.SHIFT is the distance \(in points\) to shift the image perpendicular to the) 67.166664 0 32 4 -1 roll widthshow  52799 27329 mto
 7200 25768 mto
 (short edge of the paper.  A positive value gives a shift upward in portrait mode, and to the right in) 140.0 0 32 4 -1 roll widthshow  52800 25768 mto
 7200 24207 mto
 (landscape mode.  The default value is: 0.) show  25432 24207 mto
 7200 21546 mto
 (\\POSTSCRIPT.LONGEDGE.SHIFT) show  22981 21546 mto

/Helvetica findfont 1000 scalefont setfont
 47242 21546 mto
 47242 21546 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 21546 mto
 7200 18885 mto
 (\\POSTSCRIPT.LONGEDGE.SHIFT is the corresponding variable for shifts perpendicular to the long) 141.7 0 32 4 -1 roll widthshow  52799 18885 mto
 7200 17324 mto
 (edge of the paper.  A positive value here gives a shift to the right in portrait mode and downward in) 101.09999 0 32 4 -1 roll widthshow  52799 17324 mto
 7200 15763 mto
 (landscape mode.  The default value is: 0.) show  25432 15763 mto
 7200 13102 mto
 (\\POSTSCRIPT.SHORTEDGE.PTS) show  22703 13102 mto

/Helvetica findfont 1000 scalefont setfont
 47242 13102 mto
 47242 13102 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 13102 mto

 savepage restore
showpage
%%BeginPageSetup
xmin -5 add ymin 0 add translate
0.01 imagesizefactor mul 0.01 imagesizefactor mul scale
%%EndPageSetup
/savepage save def
newpath 0 0 mto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath
 clip newpath

/Helvetica findfont 1000 scalefont setfont
 0 77684 mto
 initclip newpath 0 0 moveto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath
 clip newpath 30322 5021 mto
 (2) show  30878 5021 mto
 7200 73200 mto

/Helvetica findfont 2400 scalefont setfont
 (XEROX) show  15603 73200 mto

/Helvetica findfont 600 scalefont setfont
 46410 73200 mto
 46410 73200 mto

/Helvetica findfont 1000 scalefont setfont
 (POSTSCRIPT) show  52800 73200 mto
 7200 72470 mto

gsave newpath 200 setlinewidth 0 setlinecap 7200 72570 mto 52800 72570 lineto stroke
grestore 52800 72570 mto  52800 72470 mto
 52800 72470 mto
 7200 71059 mto
 (\\POSTSCRIPT.SHORTEDGE.PTS indicates the printable region of the page \(in points\) along the short) 16.000013 0 32 4 -1 roll widthshow  52800 71059 mto
 7200 69498 mto
 (edge of the paper.  It should be adjusted to allow for any shifts of the image \(see above\).  The default) 43.238094 0 32 4 -1 roll widthshow  52799 69498 mto
 7200 67937 mto
 (value is: 576 \(= 8 inches\).) show  18622 67937 mto
 7200 65276 mto
 (\\POSTSCRIPT.LONGEDGE.PTS) show  22037 65276 mto

/Helvetica findfont 1000 scalefont setfont
 47242 65276 mto
 47242 65276 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 65276 mto
 7200 62615 mto
 (\\POSTSCRIPT.LONGEDGE.PTS indicates the printable region of the page \(in points\) along the long) 99.25001 0 32 4 -1 roll widthshow  52800 62615 mto
 7200 61054 mto
 (edge of the paper.  It should be adjusted to allow for any shifts of the image \(see above\).  The default) 43.238094 0 32 4 -1 roll widthshow  52799 61054 mto
 7200 59493 mto
 (value is: 786.24 \(= 10.92 inches\).) show  21958 59493 mto
 7200 56832 mto
 (\\POSTSCRIPT.MAX.WILD.FONTSIZE) show  24314 56832 mto

/Helvetica findfont 1000 scalefont setfont
 47242 56832 mto
 47242 56832 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 56832 mto
 7200 54171 mto
 (\\POSTSCRIPT.MAX.WILD.FONTSIZE indicates the maximum point size that should be returned from) 64.100006 0 32 4 -1 roll widthshow  52799 54171 mto
 7200 52610 mto
 (FONTSAVAILABLE when the SIZE argument is wild \(i.e. *\).  All integer pointsizes from 1 to) 353.80002 0 32 4 -1 roll widthshow  52799 52610 mto
 7200 51049 mto
 (\\POSTSCRIPT.MAX.WILD.FONTSIZE will be indicated as available.  The default value is: 72.) show  48659 51049 mto
 7200 48388 mto
 (POSTSCRIPT.PREFER.LANDSCAPE) show  24259 48388 mto

/Helvetica findfont 1000 scalefont setfont
 47242 48388 mto
 47242 48388 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 48388 mto
 7200 45727 mto
 (POSTSCRIPT.PREFER.LANDSCAPE indicates if the OPENIMAGESTREAM method should default) 178.85713 0 32 4 -1 roll widthshow  52799 45727 mto
 7200 44166 mto
 (the orientation of output files to LANDSCAPE.  The default value is: NIL.) show  39105 44166 mto
 7200 41505 mto
 (POSTSCRIPT.TEXTFILE.LANDSCAPE) show  24871 41505 mto

/Helvetica findfont 1000 scalefont setfont
 47242 41505 mto
 47242 41505 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 41505 mto
 7200 38844 mto
 (POSTSCRIPT.TEXTFILE.LANDSCAPE indicates if the printing of TEXT files \(e.g. LISTFILES, ...\)) 252.9 0 32 4 -1 roll widthshow  52799 38844 mto
 7200 37283 mto
 (should force the orientation of output files to LANDSCAPE.  The default value is: T.) show  43885 37283 mto
 7200 34622 mto
 (POSTSCRIPT.BITMAP.SCALE) show  21148 34622 mto

/Helvetica findfont 1000 scalefont setfont
 47242 34622 mto
 47242 34622 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 34622 mto
 7200 31961 mto
 (POSTSCRIPT.BITMAP.SCALE specifies an independent scale factor for display of bitmap images) 219.40001 0 32 4 -1 roll widthshow  52799 31961 mto
 7200 30400 mto
 (\(e.g. window hardcopies\).  Values less than 1 will reduce the image size. \(I.e. a value of 0.5 will give a) 29.049988 0 32 4 -1 roll widthshow  52799 30400 mto
 7200 28839 mto
 (half size bitmap image.\)  The position of the scaled bitmap will still have the SAME lower-left corner) 102.999985 0 32 4 -1 roll widthshow  52800 28839 mto
 7200 27278 mto
 (\(i.e. the scaled bitmap is not centered in the region of the full size bitmap image\).  The default value is:) 20.600004 0 32 4 -1 roll widthshow  52799 27278 mto
 7200 25717 mto
 (1.) show  8034 25717 mto
 28833 23656 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (HINT) show  31166 23656 mto

/Helvetica findfont 1000 scalefont setfont
 31166 23656 mto
 10800 21595 mto
 (Setting POSTSCRIPT.BITMAP.SCALE to 0.96, instead of 1, will give cleaner BITMAP) 38.50001 0 32 4 -1 roll widthshow  49200 21595 mto
 10800 20034 mto
 (images on a 300 dpi printer.  \(This corrects for the 72 ppi imagestream ) 58.529408 0 32 4 -1 roll widthshow  43076 20034 mto

/Helvetica-Oblique findfont 1000 scalefont setfont
 (vs) 58.529408 0 32 4 -1 roll widthshow  44076 20034 mto

/Helvetica findfont 1000 scalefont setfont
 (. the 75 dpi) 58.529408 0 32 4 -1 roll widthshow  49199 20034 mto
 10800 18473 mto
 (printer, using 4x4 device dots per bitmap pixel.\)  Also, values of 0.24, 0.48 and 0.72,) 80.93333 0 32 4 -1 roll widthshow  49199 18473 mto
 10800 16912 mto
 (instead of 0.25, 0.5 and 0.75, will also give cleaner images for reduced size output.  In) 23.750011 0 32 4 -1 roll widthshow  49200 16912 mto
 10800 15351 mto
 (general, use integer multiples of 0.24 for a 300 dpi printer.) show  36424 15351 mto
 7200 12690 mto
 (POSTSCRIPT.TEXTURE.SCALE) show  22092 12690 mto

/Helvetica findfont 1000 scalefont setfont
 47242 12690 mto
 47242 12690 mto

/Helvetica findfont 1000 scalefont setfont
 ([InitVariable]) show  52800 12690 mto
 7200 10029 mto
 (POSTSCRIPT.TEXTURE.SCALE specifies an independent scale for the display of bitmap textures.) 174.9 0 32 4 -1 roll widthshow  52799 10029 mto
 7200 8468 mto
 (The value represents the number of device space units per texture unit \(bitmap bit\). The default value) 50.06249 0 32 4 -1 roll widthshow  52800 8468 mto

 savepage restore
showpage
%%BeginPageSetup
xmin -5 add ymin 0 add translate
0.01 imagesizefactor mul 0.01 imagesizefactor mul scale
%%EndPageSetup
/savepage save def
newpath 0 0 mto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath
 clip newpath

/Helvetica findfont 1000 scalefont setfont
 0 77684 mto
 initclip newpath 0 0 moveto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath
 clip newpath 30322 5021 mto
 (3) show  30878 5021 mto
 7200 73200 mto

/Helvetica findfont 2400 scalefont setfont
 (XEROX) show  15603 73200 mto

/Helvetica findfont 600 scalefont setfont
 46410 73200 mto
 46410 73200 mto

/Helvetica findfont 1000 scalefont setfont
 (POSTSCRIPT) show  52800 73200 mto
 7200 72470 mto

gsave newpath 200 setlinewidth 0 setlinecap 7200 72570 mto 52800 72570 lineto stroke
grestore 52800 72570 mto  52800 72470 mto
 52800 72470 mto
 7200 71059 mto
 (is 4, which represents each bit of the texture as a 4x4 block, so that textures are approximately the) 115.5 0 32 4 -1 roll widthshow  52800 71059 mto
 7200 69498 mto
 (same resolution as on the screen \(for 300 dpi output devices, such as the Apple Laserwriter\).  ) show  48886 69498 mto
 7200 66837 mto
 (The PostScript package extends the allowed representations of a texture, beyond 16-bit FIXP and) 181.15385 0 32 4 -1 roll widthshow  52799 66837 mto
 7200 65276 mto
 (16x16 bitmap, to ANY square bitmap.  \(If the bitmap is not square, its longer edge is truncated from the) 4.1052732 0 32 4 -1 roll widthshow  52799 65276 mto
 7200 63715 mto
 (top or right to make it square.\)  Use this feature with caution, as large bitmap textures, or sizes other) 71.52632 0 32 4 -1 roll widthshow  52799 63715 mto
 7200 62154 mto
 (than multiples of 16 bits square, require large amounts of storage in the PostScript interpreter \(in the) 81.37499 0 32 4 -1 roll widthshow  52800 62154 mto
 7200 60593 mto
 (printer controller\), and can cause limitcheck errors when actually printing.) show  39544 60593 mto
 7200 57932 mto
 (Anywhere that a texture or color can be used on an imagestream or in the specification of a BRUSH,) 66.166664 0 32 4 -1 roll widthshow  52799 57932 mto
 7200 56371 mto
 (you can instead give a FLOATP between 0.0 and 1.0 \(inclusive\) to represent a PostScript halftone gray) 1.3749862 0 32 4 -1 roll widthshow  52800 56371 mto
 7200 54810 mto
 (shade.  \(0.0 is black and 1.0 is white.  Specifically, the value sets the brightness of the shade.\)  The) 84.45 0 32 4 -1 roll widthshow  52799 54810 mto
 7200 53249 mto
 (value you specify will not be range checked, and will be passed directly through to the PostScript) 178.62498 0 32 4 -1 roll widthshow  52800 53249 mto
 7200 51688 mto
 (setgray operator.  \(E.g. you can pass 0.33 as the color to DRAWLINE to get a dark gray line with) 153.36842 0 32 4 -1 roll widthshow  52799 51688 mto
 7200 50127 mto
 (approximately 67% of the pixels in the line black.\)) show  29098 50127 mto
 7200 47466 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (MISCELLANEOUS) show  15867 47466 mto
 7200 44805 mto

/Helvetica findfont 1000 scalefont setfont
 (The SCALE of a PostScript imagestream is 100.  This is to allow enough resolution in the width) 210.70587 0 32 4 -1 roll widthshow  52799 44805 mto
 7200 43244 mto
 (information for fonts to enable TEdit to correctly fill and justify text.) show  36379 43244 mto
 7200 40583 mto
 (The first time any PostScript imagestream is created \(even if only to hardcopy a bitmap or window\) the) 21.235302 0 32 4 -1 roll widthshow  52799 40583 mto
 7200 39022 mto
 (DEFAULTFONT is instantiated \(unless a FONTS option was given to the OPENIMAGESTREAM, in) 132.16666 0 32 4 -1 roll widthshow  52799 39022 mto
 7200 37461 mto
 (which case the initial font for the imagestream will be set to that font, or to the CAR if a list\).) show  47495 37461 mto
 7200 34800 mto
 (The PostScript imagestream method for FILLPOLYGON uses the global variable FILL.WRULE as the) 62.41665 0 32 4 -1 roll widthshow  52799 34800 mto
 7200 33239 mto
 (default value for the WINDINGNUMBER argument.  \(This is the same variable which is used by the) 109.5 0 32 4 -1 roll widthshow  52800 33239 mto
 7200 31678 mto
 (DISPLAY imagestream method for FILLPOLYGON.\)) show  30375 31678 mto
 7200 29017 mto
 (The PostScript imagestream methods for OPENIMAGESTREAM and SEND.FILE.TO.PRINTER) 457.0 0 32 4 -1 roll widthshow  52800 29017 mto
 7200 27456 mto
 (\(OPENPOSTSCRIPTSTREAM and POSTSCRIPT.SEND, respectively\), support an) 1751.4 0 32 4 -1 roll widthshow  52799 27456 mto
 7200 25895 mto
 (IMAGESIZEFACTOR option to change the overall size of the printed image.  The) 812.5834 0 32 4 -1 roll widthshow  52799 25895 mto
 7200 24334 mto
 (IMAGESIZEFACTOR re-sizing affects the entire printed output \(specifically, it superimposes its effects) 37.999992 0 32 4 -1 roll widthshow  52800 24334 mto
 7200 22773 mto
 (upon those of POSTSCRIPT.BITMAP.SCALE and POSTSCRIPT.TEXTURE.SCALE\).  Values greater) 66.0 0 32 4 -1 roll widthshow  52800 22773 mto
 7200 21212 mto
 (than 1 enlarge the printed image, and values less than 1 reduce it.  \(Specifying an) 627.60004 0 32 4 -1 roll widthshow  52799 21212 mto
 7200 19651 mto
 (IMAGESIZEFACTOR of 0 will cause a divide by zero error!\)  ) show  34152 19651 mto
 7200 16990 mto
 (The PostScript package is contained in the files: POSTSCRIPT.LCOM & PS-SEND.LCOM, with the) 136.66667 0 32 4 -1 roll widthshow  52799 16990 mto
 7200 15429 mto
 (source in the files:  POSTSCRIPT & PS-SEND.  The module PS-SEND.LCOM is required and will be) 60.937504 0 32 4 -1 roll widthshow  52800 15429 mto
 7200 13868 mto
 (loaded automatically when POSTSCRIPT.LCOM is loaded.  It contains the function which is called by) 57.428555 0 32 4 -1 roll widthshow  52799 13868 mto
 7200 12307 mto
 (SEND.FILE.TO.PRINTER to actually transmit the file to the printer.  It is, by its nature, quite site) 213.5625 0 32 4 -1 roll widthshow  52800 12307 mto
 7200 10746 mto
 (specific, so it is in a separate file to make modifying it for any site relatively simple.  System record) 118.52633 0 32 4 -1 roll widthshow  52799 10746 mto
 7200 9185 mto
 (declarations required to compile POSTSCRIPT can be found in EXPORTS.ALL. ) show  42826 9185 mto

 savepage restore
showpage
%%BeginPageSetup
xmin -5 add ymin 0 add translate
0.01 imagesizefactor mul 0.01 imagesizefactor mul scale
%%EndPageSetup
/savepage save def
newpath 0 0 mto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath
 clip newpath

/Helvetica findfont 1000 scalefont setfont
 0 77684 mto
 initclip newpath 0 0 moveto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath
 clip newpath 30322 5021 mto
 (4) show  30878 5021 mto
 7200 73200 mto

/Helvetica findfont 2400 scalefont setfont
 (XEROX) show  15603 73200 mto

/Helvetica findfont 600 scalefont setfont
 46410 73200 mto
 46410 73200 mto

/Helvetica findfont 1000 scalefont setfont
 (POSTSCRIPT) show  52800 73200 mto
 7200 72470 mto

gsave newpath 200 setlinewidth 0 setlinecap 7200 72570 mto 52800 72570 lineto stroke
grestore 52800 72570 mto  52800 72470 mto
 52800 72470 mto
 7200 71059 mto
 (I'm pretty sure that  the output generated by the PostScript imageops fully conforms to the Adobe) 168.06252 0 32 4 -1 roll widthshow  52800 71059 mto
 7200 69498 mto
 (Systems Document Structuring Conventions, Version 2.0, January 31, 1987.) show  40993 69498 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 40993 69498 mto
 7200 66837 mto
 (Including Other PostScript Operations) show  25426 66837 mto
 7200 64176 mto

/Helvetica findfont 1000 scalefont setfont
 (If you wish to insert your own specific PostScript operations into a PostScript imagestream, you can do) 15.499995 0 32 4 -1 roll widthshow  52800 64176 mto
 7200 62615 mto
 (so with either POSTSCRIPT.OUTSTR or POSTSCRIPT.PUTCOMMAND.) show  39816 62615 mto
 7200 59954 mto
 (\(POSTSCRIPT.OUTSTR  ) show  18868 59954 mto

/Helvetica-Oblique findfont 1000 scalefont setfont
 (STREAM STRING) show  27091 59954 mto

/Helvetica findfont 1000 scalefont setfont
 (\)) show  27424 59954 mto

/Helvetica findfont 1000 scalefont setfont
 48409 59954 mto
 48409 59954 mto

/Helvetica findfont 1000 scalefont setfont
 ([Function]) show  52800 59954 mto
 7200 57293 mto
 (POSTSCRIPT.OUTSTR outputs a string or value to the imagestream.  ) 164.7143 0 32 4 -1 roll widthshow  40247 57293 mto

/Helvetica-Oblique findfont 1000 scalefont setfont
 (STREAM) 164.7143 0 32 4 -1 roll widthshow  44414 57293 mto

/Helvetica findfont 1000 scalefont setfont
 ( must be an open) 164.7143 0 32 4 -1 roll widthshow  52799 57293 mto
 7200 55732 mto
 (PostScript imagestream.  ) 77.42856 0 32 4 -1 roll widthshow  18880 55732 mto

/Helvetica-Oblique findfont 1000 scalefont setfont
 (STRING) 77.42856 0 32 4 -1 roll widthshow  22658 55732 mto

/Helvetica findfont 1000 scalefont setfont
 ( is the value to output \(STRINGP and LITATOM are most efficient,) 77.42856 0 32 4 -1 roll widthshow  52799 55732 mto
 7200 54171 mto
 (but any value can be output \(its PRIN1 pname is used\)\).) show  32045 54171 mto
 7200 51510 mto
 (\(POSTSCRIPT.PUTCOMMAND  ) show  22034 51510 mto

/Helvetica-Oblique findfont 1000 scalefont setfont
 (STREAM STRING) show  30257 51510 mto
 30257 51310 mto
 (1) show  30813 51510 mto
 ( ... STRING) show  35981 51510 mto
 35981 51310 mto
 (n) show  36537 51510 mto

/Helvetica findfont 1000 scalefont setfont
 (\)) show  36870 51510 mto

/Helvetica findfont 1000 scalefont setfont
 43629 51510 mto
 43629 51510 mto

/Helvetica findfont 1000 scalefont setfont
 ([NoSpread Function]) show  52800 51510 mto
 7200 48649 mto
 (POSTSCRIPT.PUTCOMMAND is more general for sequences of commands and values.  It calls) 238.75 0 32 4 -1 roll widthshow  52800 48649 mto
 7200 47088 mto
 (POSTSCRIPT.OUTSTR repeatedly to output each of the ) show  32600 47088 mto

/Helvetica-Oblique findfont 1000 scalefont setfont
 (STRING) show  36378 47088 mto
 36378 46888 mto
 (i) show  36600 47088 mto

/Helvetica findfont 1000 scalefont setfont
 ( arguments to ) show  42992 47088 mto

/Helvetica-Oblique findfont 1000 scalefont setfont
 (STREAM) show  47159 47088 mto

/Helvetica findfont 1000 scalefont setfont
 (.) show  47437 47088 mto
 7200 44227 mto
 (\(\\POSTSCRIPT.OUTCHARFN  ) show  21312 44227 mto

/Helvetica-Oblique findfont 1000 scalefont setfont
 (STREAM CHAR) show  28590 44227 mto

/Helvetica findfont 1000 scalefont setfont
 (\)) show  28923 44227 mto

/Helvetica findfont 1000 scalefont setfont
 48409 44227 mto
 48409 44227 mto

/Helvetica findfont 1000 scalefont setfont
 ([Function]) show  52800 44227 mto
 7200 41566 mto
 (\\POSTSCRIPT.OUTCHARFN is used to output the characters forming the text of a PostScript string) 113.30768 0 32 4 -1 roll widthshow  52799 41566 mto
 7200 40005 mto
 (\(e.g. the argument to a show or charpath operator\).  ) 64.06249 0 32 4 -1 roll widthshow  31075 40005 mto

/Helvetica-Oblique findfont 1000 scalefont setfont
 (STREAM) 64.06249 0 32 4 -1 roll widthshow  35242 40005 mto

/Helvetica findfont 1000 scalefont setfont
 ( is the open PostScript imagestream to) 64.06249 0 32 4 -1 roll widthshow  52800 40005 mto
 7200 38444 mto
 (output to, and ) 18.894743 0 32 4 -1 roll widthshow  13650 38444 mto

/Helvetica-Oblique findfont 1000 scalefont setfont
 (CHAR) 18.894743 0 32 4 -1 roll widthshow  16483 38444 mto

/Helvetica findfont 1000 scalefont setfont
 ( is the CHARCODE of the character to output.  The ) 18.894743 0 32 4 -1 roll widthshow  39590 38444 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (/) 18.894743 0 32 4 -1 roll widthshow  39868 38444 mto

/Helvetica findfont 1000 scalefont setfont
 ( \(slash\), ) 18.894743 0 32 4 -1 roll widthshow  43740 38444 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (\() 18.894743 0 32 4 -1 roll widthshow  44073 38444 mto

/Helvetica findfont 1000 scalefont setfont
 ( and ) 18.894743 0 32 4 -1 roll widthshow  46335 38444 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (\)) 18.894743 0 32 4 -1 roll widthshow  46668 38444 mto

/Helvetica findfont 1000 scalefont setfont
 ( \(parenthesis\)) 18.894743 0 32 4 -1 roll widthshow  52799 38444 mto
 7200 36883 mto
 (characters will be quoted with) 30.882341 0 32 4 -1 roll widthshow  20439 36883 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 ( /) 30.882341 0 32 4 -1 roll widthshow  21026 36883 mto

/Helvetica findfont 1000 scalefont setfont
 (, and characters with ASCII values less than 32 \(space\) or greater than) 30.882341 0 32 4 -1 roll widthshow  52799 36883 mto
 7200 35322 mto
 (126 \(tilde\) will be output as ) 36.687508 0 32 4 -1 roll widthshow  19593 35322 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (/nnn) 36.687508 0 32 4 -1 roll widthshow  21704 35322 mto

/Helvetica findfont 1000 scalefont setfont
 ( \(in octal\).  \\POSTSCRIPT.OUTCHARFN will output the ) 36.687508 0 32 4 -1 roll widthshow  46836 35322 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (\() 36.687508 0 32 4 -1 roll widthshow  47169 35322 mto

/Helvetica findfont 1000 scalefont setfont
 ( character to) 36.687508 0 32 4 -1 roll widthshow  52800 35322 mto
 7200 33761 mto
 (open the string if necessary. It is important to use POSTSCRIPT.CLOSESTRING to output the ) 232.07143 0 32 4 -1 roll widthshow  52466 33761 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (\)) 232.07143 0 32 4 -1 roll widthshow  52799 33761 mto

/Helvetica findfont 1000 scalefont setfont
 52799 33761 mto
 7200 32200 mto
 (character to close the string, because it also clears the stream state flag that indicates that a string is in) 4.1579 0 32 4 -1 roll widthshow  52799 32200 mto
 7200 30639 mto
 (progress \(otherwise, the next  POSTSCRIPT.PUTCOMMAND would output the commands to close the) 2.4166815 0 32 4 -1 roll widthshow  52799 30639 mto
 7200 29078 mto
 (string and show it\).) show  15592 29078 mto
 7200 26417 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (Warning) show  11200 26417 mto
 7200 23756 mto

/Helvetica findfont 1000 scalefont setfont
 (Do not attempt to create a PostScript font larger than about 600 points, as much of Interlisp's font) 154.88237 0 32 4 -1 roll widthshow  52799 23756 mto
 7200 22195 mto
 (information is stored in SMALLP integers, and too large a font would overflow the font's height, or the) 56.88234 0 32 4 -1 roll widthshow  52799 22195 mto
 7200 20634 mto
 (width for any of the wider characters.  \(I know that 600 points is a rediculously large limit \(about 8.3) 100.78947 0 32 4 -1 roll widthshow  52799 20634 mto
 7200 19073 mto
 (inches\), but I thought I'd better mention it, or someone might try it!\)) show  36658 19073 mto
 7200 16412 mto

/Helvetica-Bold findfont 1000 scalefont setfont
 (Known Problems/Limitations) show  20980 16412 mto
 7200 13751 mto

/Helvetica findfont 1000 scalefont setfont
 (The output generated for a PostScript imagestream is rather brute force.  It isn't particularly careful to) 60.624992 0 32 4 -1 roll widthshow  52800 13751 mto
 7200 12190 mto
 (generate the smallest output file for a given sequence of operations.  Specifically, it often generates) 112.533325 0 32 4 -1 roll widthshow  52799 12190 mto
 7200 10629 mto
 (extra end-of-lines between PostScript operator sequences \(this has no effect on the printed output,) 151.23079 0 32 4 -1 roll widthshow  52799 10629 mto
 7200 9068 mto
 (only on the file size\).) show  16315 9068 mto

 savepage restore
showpage
%%BeginPageSetup
xmin -5 add ymin 0 add translate
0.01 imagesizefactor mul 0.01 imagesizefactor mul scale
%%EndPageSetup
/savepage save def
newpath 0 0 mto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath
 clip newpath

/Helvetica findfont 1000 scalefont setfont
 0 77684 mto
 initclip newpath 0 0 moveto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath
 clip newpath 30322 5021 mto
 (5) show  30878 5021 mto
 7200 73200 mto

/Helvetica findfont 2400 scalefont setfont
 (XEROX) show  15603 73200 mto

/Helvetica findfont 600 scalefont setfont
 46410 73200 mto
 46410 73200 mto

/Helvetica findfont 1000 scalefont setfont
 (POSTSCRIPT) show  52800 73200 mto
 7200 72470 mto

gsave newpath 200 setlinewidth 0 setlinecap 7200 72570 mto 52800 72570 lineto stroke
grestore 52800 72570 mto  52800 72470 mto
 52800 72470 mto
 7200 71059 mto
 (Using BITMAPs or Functions as BRUSH arguments to the curve drawing functions is not supported,) 101.142845 0 32 4 -1 roll widthshow  52799 71059 mto
 7200 69498 mto
 (nor is using a non-ROUND BRUSH with DRAWCIRCLE or DRAWELLIPSE.) show  40762 69498 mto
 7200 66837 mto
 (There is no support for NS character sets other than 0, and there is no translation of the character) 134.00002 0 32 4 -1 roll widthshow  52800 66837 mto
 7200 65276 mto
 (code values from NS encoding to PostScript encoding.) show  31378 65276 mto
 7200 62615 mto
 (There is no support for color.) show  19983 62615 mto
 7200 59954 mto
 (\\POSTSCRIPT.OUTCHARFN is pretty wimpy in its handling of TAB characters.  It just outputs 8) 228.42859 0 32 4 -1 roll widthshow  52799 59954 mto
 7200 58393 mto
 (SPACEs for the TAB.) show  16704 58393 mto
 7200 55732 mto
 (I haven't yet documented how to build the .PSCFONT files for any new fonts that become available, I'll) 21.000006 0 32 4 -1 roll widthshow  52800 55732 mto
 7200 54171 mto
 (do that eventually.) show  15316 54171 mto

 savepage restore
showpage
%%Trailer
\ No newline at end of file
diff --git a/obsolete/lispusers/POSTSCRIPT-old/PostScript.TEDIT b/obsolete/lispusers/POSTSCRIPT-old/PostScript.TEDIT
deleted file mode 100644
index 83a128d2..00000000
--- a/obsolete/lispusers/POSTSCRIPT-old/PostScript.TEDIT
+++ /dev/null
@@ -1,14 +0,0 @@
-en·vÅos	POSTSCRIPT
2

4

1

POSTSCRIPT
1

4

By:  Matt Heffron (BEC.HEFFRON@ECLA.USC.EDU)
INTRODUCTION
The PostScript package defines a set of imageops for printers which understand the PostScript page description language by Adobe.  At Beckman we have successfully used TEdit, Sketch, LISTFILES, and HARDCOPYW to an Apple LaserWriter and an AST TurboLaser PS.  The PostScript imagestream driver installs itself when it is loaded.  All symbols in the PostScript driver are located in the INTERLISP: package.
VARIABLES
POSTSCRIPT.FONT.ALIST	[InitVariable]
POSTSCRIPT.FONT.ALIST is an ALIST mapping Xerox Lisp font names into the root names of PostScript font files.  It is also used for font family coercions.  The default value should be acceptable for any of the fonts which are built into the Apple Laserwriter.
POSTSCRIPTFONTDIRECTORIES	[InitVariable]
POSTSCRIPTFONTDIRECTORIES is the list of directories where the PostScript .PSCFONT font files can be found.  The default value is:  ("{DSK}<LISPFILES>FONTS>PSC>").
\POSTSCRIPT.SHORTEDGE.SHIFT	[InitVariable]
\POSTSCRIPT.SHORTEDGE.SHIFT is the distance (in points) to shift the image perpendicular to the short edge of the paper.  A positive value gives a shift upward in portrait mode, and to the right in landscape mode.  The default value is: 0.
\POSTSCRIPT.LONGEDGE.SHIFT	[InitVariable]
\POSTSCRIPT.LONGEDGE.SHIFT is the corresponding variable for shifts perpendicular to the long edge of the paper.  A positive value here gives a shift to the right in portrait mode and downward in landscape mode.  The default value is: 0.
\POSTSCRIPT.SHORTEDGE.PTS	[InitVariable]
\POSTSCRIPT.SHORTEDGE.PTS indicates the printable region of the page (in points) along the short edge of the paper.  It should be adjusted to allow for any shifts of the image (see above).  The default value is: 576 (= 8 inches).
\POSTSCRIPT.LONGEDGE.PTS	[InitVariable]
\POSTSCRIPT.LONGEDGE.PTS indicates the printable region of the page (in points) along the long edge of the paper.  It should be adjusted to allow for any shifts of the image (see above).  The default value is: 786.24 (= 10.92 inches).
HINT
The AST TurboLaser PS has an imageable area on the page which is a different size than that of the Apple LaserWriter.  The values of \POSTSCRIPT.SHORTEDGE.PTS and \POSTSCRIPT.LONGEDGE.PTS for the AST are 575.76 and 767.76, respectively.
\POSTSCRIPT.MAX.WILD.FONTSIZE	[InitVariable]
\POSTSCRIPT.MAX.WILD.FONTSIZE indicates the maximum point size that should be returned from FONTSAVAILABLE when the SIZE argument is wild (i.e. *).  All integer pointsizes from 1 to \POSTSCRIPT.MAX.WILD.FONTSIZE will be indicated as available.  The default value is: 72.
POSTSCRIPT.PREFER.LANDSCAPE	[InitVariable]
POSTSCRIPT.PREFER.LANDSCAPE indicates if the OPENIMAGESTREAM method should default the orientation of output files to LANDSCAPE.  It can have one of three values: NIL, T, or ASK.  NIL means prefer portrait orientation output, T means prefer landscape, and ASK says to bring up a menu to ask the preferred orientation if it wasn't explicitly indicated in the OPENIMAGESTREAM call (with the ROTATION option).  The default value is: NIL.
POSTSCRIPT.TEXTFILE.LANDSCAPE	[InitVariable]
POSTSCRIPT.TEXTFILE.LANDSCAPE indicates if the printing of TEXT files (e.g. LISTFILES, ...) should force the orientation of output files to LANDSCAPE.  The default value is: NIL.
POSTSCRIPT.BITMAP.SCALE	[InitVariable]
POSTSCRIPT.BITMAP.SCALE specifies an independent scale factor for display of bitmap images (e.g. window hardcopies).  Values less than 1 will reduce the image size. (I.e. a value of 0.5 will give a half size bitmap image.)  The position of the scaled bitmap will still have the SAME lower-left corner (i.e. the scaled bitmap is not centered in the region of the full size bitmap image).  The default value is: 1.
HINT
Setting POSTSCRIPT.BITMAP.SCALE to 0.96, instead of 1, will give cleaner BITMAP images on a 300 dpi printer.  (This corrects for the 72 ppi imagestream vs. the 75 dpi printer, using 4x4 device dots per bitmap pixel.)  Also, values of 0.24, 0.48 and 0.72, instead of 0.25, 0.5 and 0.75, will also give cleaner images for reduced size output.  In general, use integer multiples of 0.24 for a 300 dpi printer.
POSTSCRIPT.TEXTURE.SCALE	[InitVariable]
POSTSCRIPT.TEXTURE.SCALE specifies an independent scale for the display of bitmap textures.  The value represents the number of device space units per texture unit (bitmap bit). The default value is 4, which represents each bit of the texture as a 4x4 block, so that textures are approximately the same resolution as on the screen (for 300 dpi output devices, such as the Apple Laserwriter).  
The PostScript package extends the allowed representations of a texture, beyond 16-bit FIXP and 16x16 bitmap, to ANY square bitmap.  (If the bitmap is not square, its longer edge is truncated from the top or right to make it square.)  Use this feature with caution, as large bitmap textures, or sizes other than multiples of 16 bits square, require large amounts of storage in the PostScript interpreter (in the printer controller), and can cause limitcheck errors when actually printing.
Anywhere that a texture or color can be used on an imagestream or in the specification of a BRUSH, you can instead give a FLOATP between 0.0 and 1.0 (inclusive) to represent a PostScript halftone gray shade.  (0.0 is black and 1.0 is white.  Specifically, the value sets the brightness of the shade.)  The value you specify will not be range checked, and will be passed directly through to the PostScript setgray operator.  (E.g. you can pass 0.33 as the color to DRAWLINE to get a dark gray line with approximately 67% of the pixels in the line black.)
POSTSCRIPT.IMAGESIZEFACTOR	[InitVariable]
POSTSCRIPT.IMAGESIZEFACTOR specifies an independent factor to change the overall size of the printed image.  This re-sizing affects the entire printed output (specifically, it superimposes its effects upon those of POSTSCRIPT.BITMAP.SCALE and POSTSCRIPT.TEXTURE.SCALE).  Values greater than 1 enlarge the printed image, and values less than 1 reduce it.  An invalid POSTSCRIPT.IMAGESIZEFACTOR (i.e. not a positive, non-zero number)  will use a value of 1.  The BITMAPSCALE function for the POSTSCRIPT printer type does NOT consider the POSTSCRIPT.IMAGESIZEFACTOR when determining the scale factor for a bitmap.  
MISCELLANEOUS
The SCALE of a PostScript imagestream is 100.  This is to allow enough resolution in the width information for fonts to enable TEdit to correctly fill and justify text.
The first time any PostScript imagestream is created (even if only to hardcopy a bitmap or window) the DEFAULTFONT is instantiated (unless a FONTS option was given to the OPENIMAGESTREAM, in which case the initial font for the imagestream will be set to that font, or to the CAR if a list).
The PostScript imagestream method for FILLPOLYGON uses the global variable FILL.WRULE as the default value for the WINDINGNUMBER argument.  (This is the same variable which is used by the DISPLAY imagestream method for FILLPOLYGON.)
The PostScript imagestream method for OPENIMAGESTREAM (and, therefore,  SEND.FILE.TO.PRINTER), supports an IMAGESIZEFACTOR option to change the size of the printed image.  The IMAGESIZEFACTOR re-sizing is combined with the POSTSCRIPT.IMAGESIZEFACTOR to produce an overall re-sizing of the printed image.  A HEADING option is also supported to give a running header on each page of output.  The value of the HEADING option is printed at the top left of the page, followed by "Page " and the appropriate page number.  They are printed in the DEFAULTFONT (unless a FONTS option was given to the OPENIMAGESTREAM, in which case it will be that font, or to the CAR if a list).   
The PostScript package is contained in the files: POSTSCRIPT.LCOM & PS-SEND.LCOM, with the source in the files:  POSTSCRIPT & PS-SEND.  The module PS-SEND.LCOM is required and will be loaded automatically when POSTSCRIPT.LCOM is loaded.  It contains the function which is called by SEND.FILE.TO.PRINTER to actually transmit the file to the printer.  It is, by its nature, quite site specific, so it is in a separate file to make modifying it for any site relatively simple.  System record declarations required to compile POSTSCRIPT can be found in EXPORTS.ALL. 
I'm pretty sure that the output generated by the PostScript imageops fully conforms to the Adobe Systems Document Structuring Conventions, Version 2.0, January 31, 1987.
Including Other PostScript Operations
If you wish to insert your own specific PostScript operations into a PostScript imagestream, you can do so with the following functions:
(POSTSCRIPT.OUTSTR  STREAM STRING)	[Function]
POSTSCRIPT.OUTSTR outputs a string or value to the imagestream.  STREAM must be an open PostScript imagestream.  STRING is the value to output (STRINGP and LITATOM are most efficient, but any value can be output (its PRIN1 pname is used)).
(POSTSCRIPT.PUTCOMMAND  STREAM STRING1 ... STRINGn)	[NoSpread Function]
POSTSCRIPT.PUTCOMMAND is more general for sequences of commands and values.  It calls POSTSCRIPT.OUTSTR repeatedly to output each of the STRINGi arguments to STREAM.
(\POSTSCRIPT.OUTCHARFN  STREAM CHAR)	[Function]
\POSTSCRIPT.OUTCHARFN is used to output the characters forming the text of a PostScript string (e.g. the argument to a show or charpath operator).  STREAM is the open PostScript imagestream to output to, and CHAR is the CHARCODE of the character to output.  The / (slash), ( and ) (parenthesis) characters will be quoted with /, and characters with ASCII values less than 32 (space) or greater than 126 (tilde) will be output as /nnn (in octal).  \POSTSCRIPT.OUTCHARFN will output the ( character to open the string, if necessary.  Use POSTSCRIPT.CLOSESTRING (below) to close the string.
(POSTSCRIPT.CLOSESTRING  STREAM)	[Function]
POSTSCRIPT.CLOSESTRING closes a PostScript string (e.g. the argument to a show or charpath operator).  STREAM is the open PostScript imagestream.  It is important to use POSTSCRIPT.CLOSESTRING to output the ) character to close the string, because it also clears the stream state flag that indicates that a string is in progress (otherwise, the next  POSTSCRIPT.PUTCOMMAND would output the commands to close the string and show it).
Warning
Do not attempt to create a PostScript font larger than about 600 points, as much of Interlisp's font information is stored in SMALLP integers, and too large a font would overflow the font's height, or the width for any of the wider characters.  (I know that 600 points is a ridiculously large limit (about 8.3 inches), but I thought I'd better mention it, or someone might try it!)
Changes from the Lyric Release
The Medley release of this PostScript imagestream driver changed the default value of POSTSCRIPT.TEXTFILE.LANDSCAPE from T to NIL.  It also added the support for the HEADING option.
Known Problems/Limitations
The output generated for a PostScript imagestream is rather brute force.  It isn't particularly careful to generate the smallest output file for a given sequence of operations.  Specifically, it often generates extra end-of-lines between PostScript operator sequences (this has no effect on the printed output, only on the file size).
Using BITMAPs or Functions as BRUSH arguments to the curve drawing functions is not supported, nor is using a non-ROUND BRUSH with DRAWCIRCLE or DRAWELLIPSE.
There is no support for NS character sets other than 0, and there is no translation of the character code values from NS encoding to PostScript encoding.
There is no support for color.
\POSTSCRIPT.OUTCHARFN is pretty wimpy in its handling of TAB characters.  It just outputs 8 SPACEs for the TAB.
I haven't yet documented how to build the .PSCFONT files for any new fonts that become available, I'll do that eventually.(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (162 48 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (162 48 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL)))))
-5È
ÈHÈ
-ÈPAGEHEADINGRUNNINGHEAD,66’,È5ÈÈ,È,È,ŠŠ8,ŠŠ8HÈÈPAGEHEADINGRUNNINGHEAD	CLASSICCLASSICMODERN
-ÿþ	HELVETICA
-MODERN
-MODERN
-MODERNMODERN
-MODERN
-	HRULE.GETFNMODERN
-	HRULE.GETFNMODERN
-	HRULE.GETFNMODERN
-HRULE.GETFNMODERN	HRULE.GETFNMODERN-•
-¤ðîæëí³³�˜ýŠé*e©#é¢3©&‰
A*y
‰”62
--f4fgbá~¶Ožšpz.Lâzº
\ No newline at end of file
diff --git a/obsolete/lispusers/PRESSFROMNS b/obsolete/lispusers/PRESSFROMNS
deleted file mode 100644
index 9817f18d..00000000
--- a/obsolete/lispusers/PRESSFROMNS
+++ /dev/null
@@ -1,1387 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
-(FILECREATED "14-Jul-2025 23:24:28" 
-{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>PRESSFROMNS.;3 80159  
-
-      :EDIT-BY rmk
-
-      :CHANGES-TO (FNS GETCHARPRESSTRANSLATION PUTCHARPRESSTRANSLATION)
-
-      :PREVIOUS-DATE " 5-Jul-2025 18:52:47" 
-{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>PRESSFROMNS.;2)
-
-
-(PRETTYCOMPRINT PRESSFROMNSCOMS)
-
-(RPAQQ PRESSFROMNSCOMS
-       [(* This file uses CONSTANTS defined in PRESS, so it is necessary to LOADFROM PRESS before 
-           changing this file.)
-        (FNS \SMASHPRESSFONTS)
-        (FNS GETCHARPRESSTRANSLATION PRESS.NSARRAY PUTCHARPRESSTRANSLATION)
-        (FNS \DSPFONT.PRESS \DSPSPACEFACTOR.PRESS \ENTITYSTART.PRESS \SETSPACE.PRESS \STARTPAGE.PRESS
-             \PRESS.COERCEFONT \DSPFONT.PRESSFONT SETUPFONTS.PRESS)
-        (FNS \CREATEPRESSFONT \CREATECHARSET.PRESS \CREATECHARSETZERO.PRESS)
-        (FNS \PRESSCURVE2)
-        (COMS (* Generic utility for coercing fonts, could be used by other devices)
-              (FNS \COERCEFONT))
-        (ALISTS (FONTCOERCIONS PRESS)
-               (MISSINGFONTCOERCIONS PRESS))
-        (GLOBALVARS FONTCOERCIONS MISSINGFONTCOERCIONS)
-        (FNS \STRINGWIDTH.PRESS \CHARWIDTH.PRESS \OUTCHARFN.PRESS)
-        (* * new declaration for PRESSDATA)
-        (DECLARE%: DONTCOPY (RECORDS PRESSDATA))
-        (INITRECORDS PRESSDATA)
-        (* * NSTOASCIITRANSLATIONS is a list with elements of the form (charset translationArrayName)
-           %, where translationArrayName is bound to a translation array for charset which contains
-           (fontFamily charcode)
-           lists)
-        (FNS \NSTOASCIIARRAY \NSTOASCIITRANSLATION)
-        (GLOBALVARS NSTOASCIITRANSLATIONS PRESSFONTFAMILIES)
-        [INITVARS (PRESSFONTFAMILIES '((GACHA)
-                                       (TIMESROMAN)
-                                       (HELVETICA)
-                                       (SYMBOL)
-                                       (MATH)
-                                       (HIPPO)
-                                       (CYRILLIC)
-                                       (NEWVEC)
-                                       (SNEWVEC)
-                                       (HNEWVEC)
-                                       (VNEWVEC]
-        (INITVARS (NSTOASCIITRANSLATIONS))
-        (ADDVARS (NSTOASCIITRANSLATIONS (0 ASCIIFROM0ARRAY)
-                        (38 ASCIIFROM38ARRAY)
-                        (39 ASCIIFROM39ARRAY)
-                        (239 ASCIIFROM239ARRAY)))
-        (UGLYVARS ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY ASCIIFROM239ARRAY)
-        (P (\SMASHPRESSFONTS))
-        (DECLARE%: DONTCOPY (CONSTANTS (unknownCharTranslation '(MATH 59])
-
-
-
-(* This file uses CONSTANTS defined in PRESS, so it is necessary to LOADFROM PRESS before changing 
-this file.)
-
-(DEFINEQ
-
-(\SMASHPRESSFONTS
-  [LAMBDA NIL                                            (* ; "Edited 29-Feb-88 10:21 by thh:")
-          
-          (* ;; "Executed after all patchfns have been loaded, coerces existing Koto press fonts into NS-type press fonts")
-
-    (for F in (FONTSAVAILABLE '* '* '* '* 'PRESS) do (\CREATECHARSET 0 (FONTCREATE F])
-)
-(DEFINEQ
-
-(GETCHARPRESSTRANSLATION
-  [LAMBDA (CHARCODE FONT)                                    (* ; "Edited 14-Jul-2025 23:23 by rmk")
-                                                             (* ; "Edited  5-Jul-2025 18:51 by rmk")
-                                                             (* thh%: "28-Feb-86 12:03")
-                                                             (* ; 
-                                            "returns the Press translation for a character in a font")
-    (COND
-       ((OR (CHARCODEP CHARCODE)
-            (EQ CHARCODE 256))                               (* ; 
-                                         "bitmap for char 256 is what gets printed if char not found")
-        )
-       ((OR (STRINGP CHARCODE)
-            (LITATOM CHARCODE))
-        (SETQ CHARCODE (CHCON1 CHARCODE)))
-       (T (\ILLEGAL.ARG CHARCODE)))
-    (LET [TR CSINFO (FONTDESC (FONTCOPY FONT NIL NIL NIL 'PRESS]
-                                                             (* ; 
-                                          "fetch the csinfo for the character set of this character.")
-         (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
-                             FONTDESC))
-         (SETQ TR (\GETBASEPTR (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
-                         (UNFOLD (\CHAR8CODE CHARCODE)
-                                2)))                         (* ; "Return a copy")
-         (LIST (CAR TR)
-               (CDR TR])
-
-(PRESS.NSARRAY
-  [LAMBDA (CHARSET FAMILY ASCIIARRAY)                    (* thh%: "28-Feb-86 12:08")
-          
-          (* using info in ASCIIARRAY or ASCIITONSTRANSLATIONS, creates an array of
-        (pressFont charcode) lists)
-
-    (LET* ((min (TIMES 256 CHARSET))
-           (max (PLUS min 255))
-           (array (ARRAY 256 NIL NIL 0)))
-          [for item in (COND
-                                  [ASCIIARRAY `((%, FAMILY ASCIIARRAY]
-                                  (T ASCIITONSTRANSLATIONS)) bind asciiArray
-             do 
-          
-          (* * item is of the form (PressFont TranslationArray NSFont))
-
-                   (SETQ asciiArray (EVAL (CADR item)))
-                   (COND
-                      (asciiArray (for i from 0 to 255
-                                     do (SETA array (REMAINDER (ELT asciiArray i)
-                                                               256)
-                                                  (LIST (CAR item)
-                                                        i))
-                                     when (AND (LEQ min (ELT asciiArray i))
-                                                   (LEQ (ELT asciiArray i)
-                                                        max]
-          array])
-
-(PUTCHARPRESSTRANSLATION
-  [LAMBDA (CHARCODE FONT NEWTRANSLATION)                     (* ; "Edited 14-Jul-2025 23:24 by rmk")
-                                                             (* ; "Edited  5-Jul-2025 18:51 by rmk")
-                                                             (* ; "Edited 29-Feb-88 10:28 by thh:")
-                                                             (* ; 
-                                            "Changes the Press translation for a character in a font")
-    (COND
-       ((CHARCODEP CHARCODE))
-       ((OR (STRINGP CHARCODE)
-            (LITATOM CHARCODE))
-        (SETQ CHARCODE (CHCON1 CHARCODE)))
-       (T (\ILLEGAL.ARG CHARCODE)))
-    (PROG* ((FONTDESC (FONTCREATE FONT NIL NIL NIL 'PRESS))
-            (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
-                           FONTDESC))
-            (CHAR8CODE (\CHAR8CODE CHARCODE))
-            (TR (\NSTOASCIITRANSLATION NEWTRANSLATION NIL FONTDESC)))
-           (UNINTERRUPTABLY
-               (\RPLPTR (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
-                      (UNFOLD CHAR8CODE 2)
-                      TR)
-               (\PUTBASE (ffetch (CHARSETINFO WIDTHS) of CSINFO)
-                      CHAR8CODE
-                      (\FGETCHARWIDTH (CAR TR)
-                             (CDR TR)))
-               [change (ffetch CHARSETASCENT of CSINFO)
-                      (MAX DATUM (ffetch \SFAscent of (CAR TR]
-               [change (ffetch CHARSETDESCENT of CSINFO)
-                      (MAX DATUM (ffetch \SFDescent of (CAR TR]
-               [freplace \SFHeight of FONTDESC with (PLUS (change (ffetch \SFAscent of FONTDESC)
-                                                                 (MAX DATUM (ffetch CHARSETASCENT
-                                                                               of CSINFO)))
-                                                          (change (ffetch \SFDescent of FONTDESC)
-                                                                 (MAX DATUM (ffetch CHARSETDESCENT
-                                                                               of CSINFO])
-           (RETURN NEWTRANSLATION])
-)
-(DEFINEQ
-
-(\DSPFONT.PRESS
-  [LAMBDA (PRSTREAM FONT)                                (* rmk%: "25-Feb-86 11:05")
-          
-          (* * The DSPFONT method for PRESS-type image streams --
-        change the stream's current logical font to FONT;
-        the device font changes only when we print a character)
-
-    (PROG (OLDFONT FDENTRY (PRDATA (ffetch IMAGEDATA of PRSTREAM)))
-          (SETQ OLDFONT (ffetch PRLOGICALFONT of PRDATA))
-          (COND
-             ([OR (NULL FONT)
-                  (EQ OLDFONT (SETQ FONT (OR (\GETFONTDESC FONT 'PRESS T)
-                                             (FONTCOPY OLDFONT FONT]
-              (RETURN OLDFONT)))
-          (freplace PRLOGICALFONT of PRDATA with FONT)
-          (freplace PRLOGICALCHARSET of PRDATA with NIL)
-          [\SETSPACE.PRESS PRSTREAM (FIXR (TIMES (ffetch PRSPACEFACTOR of PRDATA)
-                                                     (\FGETCHARWIDTH FONT (CHARCODE SPACE]
-          [freplace PRLINEFEED of PRDATA with (IDIFFERENCE (CONSTANT (IMINUS 
-                                                                                        MicasPerPoint
-                                                                                        ))
-                                                                 (FONTPROP FONT 'HEIGHT]
-          (\FIXLINELENGTH.PRESS PRSTREAM)
-          (RETURN OLDFONT])
-
-(\DSPSPACEFACTOR.PRESS
-  [LAMBDA (STREAM FACTOR)                                (* rmk%: "24-Feb-86 09:49")
-    (LET ((PRDATA (ffetch IMAGEDATA of STREAM)))
-         (PROG1 (ffetch PRSPACEFACTOR of PRDATA)
-                (COND
-                   (FACTOR (SHOW.PRESS STREAM)
-                          (freplace PRSPACEFACTOR of PRDATA with FACTOR)
-                          (\SETSPACE.PRESS STREAM (FIXR (TIMES FACTOR
-                                                                   (\FGETCHARWIDTH (ffetch 
-                                                                                        PRLOGICALFONT
-                                                                                      of PRDATA)
-                                                                          (CHARCODE SPACE])
-
-(\ENTITYSTART.PRESS
-  [LAMBDA (PRSTREAM)                                     (* thh%: "10-Dec-86 08:33")
-    (PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM)))
-          (freplace PRSPACEWIDTH of PRDATA with NIL)
-          
-          (* This really should be the spacewidth of the current font.
-        But then, if we switch fonts to one whose space*spacefactor comes out the 
-        same, we won't know to put out a setspace command.
-        So when we actually set up the first font in this entity, we will end up 
-        putting out an explicit setspace (even if the space factor is 1))
-
-          (freplace PRFONT of PRDATA with NIL)
-          (freplace PRLOGICALFONT of PRDATA with NIL)
-          
-          (* We set the font to NIL, knowing that the current font can be recoverd from 
-        the PRCURRFDE. This font will be set in the press file before the first show, 
-        if no explicit dspfont intervenes. Note, however, that up until the first 
-        dspfont, the widthscache still corresponds to what was the PRLOGICALFONT)
-
-          (freplace DLSTARTBYTE of PRDATA with (\GETFILEPTR PRSTREAM))
-          (freplace ELSTARTBYTE of PRDATA with (\GETFILEPTR (fetch ELSTREAM
-                                                                           of PRDATA)))
-          (freplace STARTCHARBYTE of PRDATA with (\GETFILEPTR PRSTREAM))
-          
-          (* Entity starts with position at 0,0 so must re-establish current position
-        (?))
-
-          (SETXY.PRESS PRSTREAM (fetch PRXPOS of PRDATA)
-                 (fetch PRYPOS of PRDATA])
-
-(\SETSPACE.PRESS
-  [LAMBDA (PRSTREAM S)                                   (* rmk%: "31-Mar-86 16:08")
-    (PROG (ELSTREAM (PRDATA (fetch IMAGEDATA of PRSTREAM)))
-          (AND (EQ S (ffetch PRSPACEWIDTH of PRDATA))
-               (RETURN))
-          (SHOW.PRESS PRSTREAM)
-          (SETQ ELSTREAM (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM)))
-          (if (ILEQ S 2047)
-              then (\WOUT ELSTREAM (IPLUS (LLSH SetSpaceXShortCode 8)
-                                              S))
-            else (\BOUT ELSTREAM SetSpaceXCode)
-                  (\WOUT ELSTREAM S))
-          (freplace PRSPACEWIDTH of PRDATA with S])
-
-(\STARTPAGE.PRESS
-  [LAMBDA (PRSTREAM)                                     (* rmk%: "25-Feb-86 11:36")
-          
-          (* Should be called only when no previous page is open)
-
-    (PROG (CFONT HFONT SPACEFACTOR (PRDATA (ffetch IMAGEDATA of PRSTREAM)))
-          (SETQ CFONT (ffetch PRLOGICALFONT of PRDATA))
-          
-          (* Save current font so that \ENTITYSTART.PRESS can make PRLOGICALFONT be 
-        NIL, indicating that there is no actual font at the beginning of a page)
-
-          (\ENTITYSTART.PRESS PRSTREAM)
-          [COND
-             ((ffetch PRHEADING of PRDATA)
-              (SETQ SPACEFACTOR (ffetch PRSPACEFACTOR of PRDATA))
-              (freplace PRSPACEFACTOR of PRDATA with 1)
-              (SETQ HFONT (ffetch PRHEADINGFONT of PRDATA))
-              (\DSPFONT.PRESS PRSTREAM HFONT)            (* Set up heading font)
-              [SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA)
-                     (IDIFFERENCE (ffetch PRTOP of PRDATA)
-                            (FONTPROP HFONT 'ASCENT]
-              (PRIN3 (ffetch PRHEADING of PRDATA)
-                     PRSTREAM)                               (* Skip an inch before page number)
-              (SHOW.PRESS PRSTREAM)
-              (SETX.PRESS PRSTREAM (IPLUS MICASPERINCH (ffetch PRXPOS of PRDATA)))
-              (PRIN3 "Page " PRSTREAM)
-              (PRIN3 (add (ffetch PRPAGENUM of PRDATA)
-                            1)
-                     PRSTREAM)
-              (NEWLINE.PRESS PRSTREAM)                       (* Skip 2 lines)
-              (NEWLINE.PRESS PRSTREAM)
-              (freplace PRSPACEFACTOR of PRDATA with SPACEFACTOR))
-             (T (SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA)
-                       (IDIFFERENCE (ffetch PRTOP of PRDATA)
-                              (FONTPROP CFONT 'ASCENT]
-          
-          (* Now we set the font to our (previous) current font)
-
-          (\DSPFONT.PRESS PRSTREAM CFONT])
-
-(\PRESS.COERCEFONT
-  [LAMBDA (FONT FAMILY)                                  (* rmk%: "25-Mar-86 15:44")
-          
-          (* coerces FONT to be new FAMILY FAMILY, and caches result on 
-        \PRESS.COERCEDFONTS)
-
-    (DECLARE (GLOBALVARS \PRESS.COERCEDFONTS))
-    (COND
-       [[OR (NOT FAMILY)
-            (EQ FAMILY (FONTPROP FONT 'FAMILY]
-          
-          (* Don't call FONTCOPY if it's the same font.
-        This avoids circularity thru AVGCHARWIDTH and CHARWIDTH before the font has 
-        been stored in \FONTSINCORE.)
-
-        (COND
-           ((EQ 'PRESS (FONTPROP FONT 'DEVICE))              (* How could it not be PRESS? Ask 
-                                                           Tad.)
-            FONT)
-           (T (FONTCOPY FONT 'DEVICE 'PRESS]
-       ((OR (FONTP FAMILY)
-            (LISTP FAMILY))                                  (* FAMILY is a font specification)
-        (FONTCOPY FAMILY 'DEVICE 'PRESS))
-       [(FONTP (CADR (ASSOC FONT (CDR (ASSOC FAMILY \PRESS.COERCEDFONTS]
-       (T (LET [(pressFont (OR (FONTCOPY FONT 'FAMILY FAMILY 'DEVICE 'PRESS 'NOERROR T)
-                               (FONTCOPY FONT 'FAMILY FAMILY 'FACE 'STANDARD 'DEVICE 'PRESS]
-               (push [CDR (OR (ASSOC FAMILY \PRESS.COERCEDFONTS)
-                                  (CAR (push \PRESS.COERCEDFONTS (CONS FAMILY]
-                      (LIST FONT pressFont))
-               pressFont])
-
-(\DSPFONT.PRESSFONT
-  [LAMBDA (PRSTREAM PRFONT)                              (* thh%: "16-Jun-86 10:50")
-                                                             (* Changes the Pressfiles device 
-                                                           font)
-    (PROG (FDENTRY LFONT OLDFONT (PRDATA (ffetch IMAGEDATA of PRSTREAM)))
-          (SETQ OLDFONT (ffetch PRFONT of PRDATA))
-          (SHOW.PRESS PRSTREAM)
-          (SETQ FDENTRY (\DEFINEFONT.PRESS PRSTREAM PRFONT))
-          (COND
-             ((NEQ (ffetch FONTSET# of FDENTRY)
-                   (ffetch FONTSET# of (ffetch PRCURRFDE of PRDATA)))
-                                                             (* Swtich font sets)
-          
-          (* must save and restore current logical font since \ENTITYSTART.PRESS makes 
-        it NIL)
-
-              (SETQ LFONT (ffetch PRLOGICALFONT of PRDATA))
-              (\ENTITYEND.PRESS PRSTREAM)
-              (\ENTITYSTART.PRESS PRSTREAM)
-              (\DSPFONT.PRESS PRSTREAM LFONT)))
-          (freplace PRCURRFDE of PRDATA with FDENTRY)
-          (freplace PRFONT of PRDATA with PRFONT)
-          (\BOUT (ffetch ELSTREAM of PRDATA)
-                 (LOGOR FontCode (ffetch FONT# of FDENTRY)))
-          (RETURN OLDFONT])
-
-(SETUPFONTS.PRESS
-  [LAMBDA (PRSTREAM FONTS)                               (* thh%: "10-Dec-86 08:43")
-          
-          (* creates fonts in the initial fontset.
-        and sets heading font. Leaves PRFONT as NIL.
-        This means that \DSPFONT.PRESS of the heading font will establish that as the 
-        current font when the first page opens.)
-          
-          (* since FONTS are logical, not device, fonts, they are not added to the 
-        fontset here)
-
-    (for F FLG inside (OR FONTS DEFAULTFONT)
-       do (SETQ F (FONTCREATE F NIL NIL NIL 'PRESS))
-             (COND
-                (FLG NIL)
-                (T (\DSPFONT.PRESS PRSTREAM F)
-          
-          (* Install first font as current logical font and heading font.)
-
-                   (\ENTITYEND.PRESS PRSTREAM)
-                   (replace PRHEADINGFONT of (fetch IMAGEDATA of PRSTREAM)
-                      with F)
-                   (SETQ FLG T])
-)
-(DEFINEQ
-
-(\CREATEPRESSFONT
-  [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE)            (* ; "Edited  9-Mar-88 15:54 by thh:")
-          (* ;; "Widths array is fully allocated, with zeroes for characters with no information.  An array is not allocated for fixed WidthsY.  DEVICE is PRESS or INTERPRESS")
-
-    (DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES))
-    (RESETLST                                                (* ; 
-                                                   "RESETLST to make sure the fontfiles get closed")
-           (PROG ((FD (create FONTDESCRIPTOR
-                             FONTDEVICE _ DEVICE
-                             FONTFAMILY _ FAMILY
-                             FONTSIZE _ PSIZE
-                             FONTFACE _ FACE
-                             \SFFACECODE _ (\FACECODE FACE)
-                             ROTATION _ ROTATION
-                             FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72))
-                             \SFHeight _ 0
-                             \SFAscent _ 0
-                             \SFDescent _ 0)))
-                 (OR (\GETCHARSETINFO 0 FD T)
-                     (RETURN NIL))
-                 (RETURN FD])
-
-(\CREATECHARSET.PRESS
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC)
-                                                             (* ; "Edited  9-Mar-88 15:19 by thh:")
-(* ;;; "determines widths and translations to print the charset with Press fonts.  Note that we get widths from widths of font translated to, which should be original press values because translations are always to press fonts.")
-(* ;;; "NOTE: This code makes fonts that translate to themselves circular, and also gives fonts high reference counts. The translations should not be circular.")
-
-    (DECLARE (GLOBALVARS PRESSFONTFAMILIES))
-    (PROG ((CSETTRANSLATIONARRAY (\NSTOASCIIARRAY CHARSET))
-           CSINFO widths (translationArray (ARRAY 256 NIL NIL 0))
-           (ascent 0)
-           (descent 0)
-           CSETZEROTRANSLATIONS)
-          (* ;; "Determine translations for this charset")
-
-          [COND
-             [(ZEROP CHARSET)
-          (* ;; "set up charsetinfo -- includes any coercions to known press fonts")
-
-              (SETQ CSINFO (\CREATECHARSETZERO.PRESS FAMILY SIZE FACE ROTATION DEVICE FONTDESC))
-              (OR CSINFO (RETURN NIL))                       (* ; 
-                                                           "unable to coerce to a press font")
-          (* ;; "get translations for charset-0")
-
-              (COND
-                 [(SETQ CSETZEROTRANSLATIONS (ASSOC (FONTPROP FONTDESC 'FAMILY)
-                                                    PRESSFONTFAMILIES))
-                                                             (* ; "use identity transformation")
-                  (for i from 0 to 255 do (SETA translationArray i (CONS FONTDESC i))
-                         )                                   (* ; 
-                                                          "except for font-specific non-identities")
-                  (for X in (CDR CSETZEROTRANSLATIONS)
-                     do (SETA translationArray (CAR X)
-                                  (\NSTOASCIITRANSLATION (CADR X)
-                                         FAMILY FONTDESC]
-                 (T 
-          (* ;; "Not a press font: assume NS font which will be translated into a press font")
-
-                    (for i from 0 to 255
-                       do (SETA translationArray i
-                                    (\NSTOASCIITRANSLATION
-                                     (COND
-                                        ((AND CSETTRANSLATIONARRAY (ELT CSETTRANSLATIONARRAY i)))
-                                        (T (LIST (OR FAMILY (FONTPROP FONTDESC 'FAMILY))
-                                                 i)))
-                                     FAMILY FONTDESC]
-             (T 
-          (* ;; "CHARSET not zero, assume NS codes")
-
-                (for i from 0 to 255 do (SETA translationArray i
-                                                              (\NSTOASCIITRANSLATION
-                                                               (AND CSETTRANSLATIONARRAY
-                                                                    (ELT CSETTRANSLATIONARRAY i))
-                                                               FAMILY FONTDESC]
-          (* ;; "Set the widths array and install the translations in the CHARSETINFO")
-
-          (OR CSINFO (SETQ CSINFO (create CHARSETINFO)))
-          (SETQ widths (fetch (CHARSETINFO WIDTHS) of CSINFO))
-          (for i from 0 to 255 bind translation pressFont newAscent newDescent
-             do (SETQ translation (ELT translationArray i))
-                   (SETQ pressFont (CAR translation))
-                   [COND
-                      ((AND (ZEROP CHARSET)
-                            (EQ pressFont FONTDESC))         (* ; 
-                         "this is charset-0 font translating to itself, use widths already defined")
-                       (\FSETWIDTH widths i (\FGETWIDTH widths (CDR translation)))
-                       (SETQ newAscent (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
-                       (SETQ newDescent (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
-                      (T (\FSETWIDTH widths i (\FGETCHARWIDTH pressFont (CDR translation)))
-                         (SETQ newAscent (ffetch (FONTDESCRIPTOR \SFAscent) of pressFont))
-                         (SETQ newDescent (ffetch (FONTDESCRIPTOR \SFDescent) of pressFont]
-                   (SETQ ascent (MAX ascent newAscent))
-                   (SETQ descent (MAX descent newDescent)))
-          (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with (ffetch (ARRAYP BASE)
-                                                                             of translationArray)
-                 )
-          (replace (CHARSETINFO CHARSETASCENT) of CSINFO with ascent)
-          (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with descent)
-          (RETURN CSINFO])
-
-(\CREATECHARSETZERO.PRESS
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FD)          (* ; "Edited  9-Mar-88 15:27 by thh:")
-(* ;;; 
-"creates CSINFO for charset 0 of press fonts from info in widths file (without translations).")
-
-    (DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES FONTCOERCIONS MISSINGFONTCOERCIONS))
-    (RESETLST                                                (* ; 
-                                                   "RESETLST to make sure the fontfiles get closed")
-           (PROG* (WSTRM STRMCACHE FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY WIDTHS
-                         (PRESSMICASIZE (IQUOTIENT (ITIMES SIZE 2540)
-                                               72))
-                         (NSMICASIZE (FIXR (FQUOTIENT (ITIMES SIZE 2540)
-                                                  72)))
-                         (FACECODE (\FACECODE FACE))
-                         (CSINFO (create CHARSETINFO))
-                         CHARSETHEIGHT FOO FBBOX)
-(* ;;; "Go look for the fonts.widths file that has this font's info in it.")
-
-                  (OR [bind XLATEDNAME NEWFAMILY NEWNSMICASIZE NEWFACECODE for F inside
-                                                                                         
-                                                                                 PRESSFONTWIDTHSFILES
-                         when (INFILEP F)
-                         first (SETQ XLATEDNAME (\COERCEFONT FAMILY SIZE FACE ROTATION
-                                                           'PRESS FONTCOERCIONS))
-                               [COND
-                                  (XLATEDNAME (SETQ NEWFAMILY (CAR XLATEDNAME))
-                                         (SETQ NEWNSMICASIZE (FIXR (FQUOTIENT (ITIMES (CADR 
-                                                                                           XLATEDNAME
-                                                                                            )
-                                                                                     2540)
-                                                                          72)))
-                                         (SETQ NEWFACECODE (\FACECODE (CADDR XLATEDNAME]
-                         do                              (* ; 
-    "Look thru the candidate PRESSFONTWIDTHSFILES for a file that has a description for this font.")
-                               [COND
-                                  [(SETQ WSTRM (\GETSTREAM F 'INPUT T))
-                                   (COND
-                                      ((RANDACCESSP WSTRM)
-                                       (RESETSAVE NIL (LIST 'SETFILEPTR WSTRM (GETFILEPTR WSTRM)))
-                                       (SETFILEPTR WSTRM 0]
-                                  (T (RESETSAVE (SETQ WSTRM (OPENSTREAM F 'INPUT 'OLD 8))
-                                            '(PROGN (CLOSEF? OLDVALUE]
-                               [OR (RANDACCESSP WSTRM)
-                                   (COPYBYTES WSTRM (SETQ WSTRM (OPENSTREAM '{NODIRCORE} 'BOTH
-                                                                       'NEW]
-                               (push STRMCACHE WSTRM)    (* ; "Save for coercions below")
-                               (COND
-                                  ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM (OR NEWNSMICASIZE 
-                                                                              NSMICASIZE)
-                                                        FIRSTCHAR LASTCHAR (OR NEWFAMILY FAMILY)
-                                                        (OR NEWFACECODE FACECODE)))
-                                                             (* ; 
-                                                   "OK, we found this font described in this file.")
-                                   (COND
-                                      (XLATEDNAME (replace FONTDEVICESPEC of FD with
-                                                                                        XLATEDNAME)
-                                             (SETQ NSMICASIZE NEWNSMICASIZE)))
-                                   (RETURN T]
-                      [bind XLATEDNAME NEWFAMILY NEWNSMICASIZE NEWFACECODE XLATEDNAMES
-                         first (SETQ STRMCACHE (DREVERSE STRMCACHE))
-                         while (SETQ XLATEDNAME (\COERCEFONT FAMILY SIZE FACE ROTATION
-                                                           'PRESS MISSINGFONTCOERCIONS XLATEDNAMES))
-                         thereis (push XLATEDNAMES XLATEDNAME)
-                               (for old WSTRM in STRMCACHE
-                                  first (SETQ NEWFAMILY (CAR XLATEDNAME))
-                                        (SETQ NEWNSMICASIZE (FIXR (FQUOTIENT (ITIMES (CADR XLATEDNAME
-                                                                                           )
-                                                                                    2540)
-                                                                         72)))
-                                        (SETQ NEWFACECODE (\FACECODE (CADDR XLATEDNAME)))
-                                  do                     (* ; 
-                                                           "Now try coercing the family name")
-          (* ;; "We know the file was left open and is randaccessp from the previous loop, which must have run off the end of the file list")
-
-                                        (SETFILEPTR WSTRM 0)
-                                        (COND
-                                           ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM NEWNSMICASIZE 
-                                                                 FIRSTCHAR LASTCHAR NEWFAMILY 
-                                                                 NEWFACECODE))
-                                            (replace FONTDEVICESPEC of FD with XLATEDNAME
-                                                   )
-                                            (SETQ NSMICASIZE NEWNSMICASIZE)
-                                            (RETURN T]
-                      (RETURN NIL))
-(* ;;; "Having found the font-widths file, now read the width info from it.")
-
-                  (SETQ RELFLAG (ZEROP RELFLAG))             (* ; 
-"Actually, \POSITIONFONTFILE returns zero if the font metrics are size-relative and must be scaled.")
-                  (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
-                  (SETFILEPTR WSTRM (UNFOLD (\FIXPIN WSTRM)
-                                           BYTESPERWORD))
-          (* ;; "Read the location of the WD segment for this font (we're in the directory part of the file now), and go there.")
-
-                  (SETQ FBBOX (SIGNED (\WIN WSTRM)
-                                     BITSPERWORD))           (* ; 
-                      "replace (FONTDESCRIPTOR FBBOX) of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)")
-                                                             (* ; 
-                                                          "Get the max bounding width for the font")
-                  (replace (CHARSETINFO CHARSETDESCENT) of CSINFO
-                     with (IMINUS (SIGNED (\WIN WSTRM)
-                                             BITSPERWORD)))  (* ; "Descent is -FBBOY")
-                  (SETQ FOO (\WIN WSTRM))                    (* ; 
-                      "replace (FONTDESCRIPTOR FBBDX) of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)")
-                                                             (* ; "And the standard kern value (?)")
-                  (SETQ CHARSETHEIGHT (SIGNED (\WIN WSTRM)
-                                             BITSPERWORD))   (* ; 
-                                   "replace \SFHeight of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)")
-                                                             (* ; "Height is FBBDY")
-                  [COND
-                     (RELFLAG                                (* ; 
-                                                          "Dimensions are relative, must be scaled")
-          (* ;; "replace (FONTDESCRIPTOR FBBOX) of FD with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBOX) of FD) NSMICASIZE) 1000)")
-
-                            (replace (CHARSETINFO CHARSETDESCENT) of CSINFO
-                               with (IQUOTIENT (ITIMES (fetch (CHARSETINFO CHARSETDESCENT)
-                                                              of CSINFO)
-                                                          NSMICASIZE)
-                                               1000))
-          (* ;; "replace (FONTDESCRIPTOR FBBDX) of FD with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBDX) of FD) NSMICASIZE) 1000)")
-
-                            (SETQ CHARSETHEIGHT (IQUOTIENT (ITIMES CHARSETHEIGHT NSMICASIZE)
-                                                       1000]
-                  (replace (CHARSETINFO CHARSETASCENT) of CSINFO
-                     with (IDIFFERENCE CHARSETHEIGHT (fetch CHARSETDESCENT of CSINFO)))
-                  (SETQ FIXEDFLAGS (LRSH (\BIN WSTRM)
-                                         6))                 (* ; "The fixed flags")
-                  (\BIN WSTRM)                               (* ; "Skip the spares")
-                  [COND
-                     ((EQ 2 (LOGAND FIXEDFLAGS 2))           (* ; "This font is fixed width.")
-                      (SETQ TEM (\WIN WSTRM))                (* ; 
-                                                           "Read the fixed width for this font")
-                      [COND
-                         ((AND RELFLAG (NOT (ZEROP TEM)))    (* ; 
-                                                           "If it's size relative, scale it.")
-                          (SETQ TEM (IQUOTIENT (ITIMES TEM NSMICASIZE)
-                                           1000]
-                      (for I from FIRSTCHAR to LASTCHAR
-                         do                              (* ; 
-                                                    "Fill in the char widths table with the width.")
-                               (\FSETWIDTH WIDTHS I TEM)))
-                     (T                                      (* ; 
-                                                  "Variable width font, so we have to read widths.")
-                                                             (* ; 
-                               "AIN WIDTHS FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) WSTRM")
-                        (for I from FIRSTCHAR to LASTCHAR
-                           do (\FSETWIDTH WIDTHS I noInfoCode))
-                        (\BINS (\GETOFD WSTRM 'INPUT)
-                               WIDTHS
-                               (UNFOLD FIRSTCHAR BYTESPERWORD)
-                               (UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
-                                      BYTESPERWORD))         (* ; "Read the X widths.")
-                        (for I from FIRSTCHAR to LASTCHAR
-                           when (EQ noInfoCode (\FGETWIDTH WIDTHS I))
-                           do                            (* ; 
-                                            "For chars that have no width info, let width be zero.")
-                                 (\FSETWIDTH WIDTHS I 0))
-                        (COND
-                           (RELFLAG                          (* ; 
-                                                     "If the widths are size-relative, scale them.")
-                                  (for I from FIRSTCHAR to LASTCHAR
-                                     do (\FSETWIDTH WIDTHS I (IQUOTIENT (ITIMES (\FGETWIDTH
-                                                                                     WIDTHS I)
-                                                                                   NSMICASIZE)
-                                                                        1000]
-                  [COND
-                     [(EQ 1 (LOGAND FIXEDFLAGS 1))
-                      (COND
-                         ((ILESSP (GETFILEPTR WSTRM)
-                                 (GETEOFPTR WSTRM))
-                          (SETQ WIDTHSY (\WIN WSTRM)))
-                         (T                                  (* ; 
-                                                   "STAR FONT FILES LIKE TO LEAVE OFF THE Y WIDTH.")
-                            (SETQ WIDTHSY 0)))               (* ; 
-                "The fixed width-Y for this font;  the width-Y field is a single integer in the FD")
-                      (replace (CHARSETINFO YWIDTHS) of CSINFO
-                         with (COND
-                                     ((AND RELFLAG (NOT (ZEROP WIDTHSY)))
-                                      (IQUOTIENT (ITIMES WIDTHSY NSMICASIZE)
-                                             1000))
-                                     (T WIDTHSY]
-                     (T                                      (* ; 
-                                                      "Variable Y-width font.  Fill it in as above")
-                        (SETQ WIDTHSY (replace (CHARSETINFO YWIDTHS) of CSINFO with
-                                                                                       (
-                                                                                 \CREATECSINFOELEMENT
-                                                                                        )))
-                        (for I from FIRSTCHAR to LASTCHAR
-                           do (\FSETWIDTH WIDTHSY I noInfoCode))
-                        (\BINS (\GETOFD WSTRM 'INPUT)
-                               WIDTHSY
-                               (UNFOLD FIRSTCHAR BYTESPERWORD)
-                               (UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
-                                      BYTESPERWORD))         (* ; "Read the Y widths")
-                        (for I from FIRSTCHAR to LASTCHAR
-                           when (EQ noInfoCode (\FGETWIDTH WIDTHSY I))
-                           do                            (* ; 
-                                             "Let any characters with no width info be zero height")
-                                 (\FSETWIDTH WIDTHSY I 0))
-                        (COND
-                           (RELFLAG                          (* ; 
-                                                     "If the widths are size-relative, scale them.")
-                                  (for I from FIRSTCHAR to LASTCHAR
-                                     do (\FSETWIDTH WIDTHSY I (IQUOTIENT (ITIMES (\FGETWIDTH
-                                                                                      WIDTHSY I)
-                                                                                    NSMICASIZE)
-                                                                         1000]
-                  (RETURN CSINFO])
-)
-(DEFINEQ
-
-(\PRESSCURVE2
-  [LAMBDA (PRSTREAM SPLINE DASHING BRUSHFONT)            (* thh%: "16-Jun-86 10:53")
-          
-          (* Given a spline curve and a font, draw the lines to PRSTREAM)
-
-    (RESETLST (RESETSAVE NIL (LIST '\DSPFONT.PRESSFONT PRSTREAM (\DSPFONT.PRESSFONT PRSTREAM 
-                                                                       BRUSHFONT)))
-           [PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM)))
-                 (COND
-                    ((IGREATERP (IDIFFERENCE (GETFILEPTR (fetch ELSTREAM of PRDATA))
-                                       (fetch ELSTARTBYTE of PRDATA))
-                            25000)
-                     (\ENTITYEND.PRESS PRSTREAM)             (* Hack to prevent mysterious 
-                                                           overflow in length of entities)
-                     (\ENTITYSTART.PRESS PRSTREAM]
-           (\BOUT (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM))
-                  ResetSpaceCode)
-          
-          (* because the space code shouldn't be interpreted specially when we are 
-        drawing in the vector font)
-
-           (PROG ((XPOLY (create POLYNOMIAL))
-                  (X'POLY (create POLYNOMIAL))
-                  (YPOLY (create POLYNOMIAL))
-                  (Y'POLY (create POLYNOMIAL))
-                  (X (fetch (SPLINE SPLINEX) of SPLINE))
-                  (Y (fetch (SPLINE SPLINEY) of SPLINE))
-                  (X' (fetch (SPLINE SPLINEDX) of SPLINE))
-                  (Y' (fetch (SPLINE SPLINEDY) of SPLINE))
-                  (X'' (fetch (SPLINE SPLINEDDX) of SPLINE))
-                  (Y'' (fetch (SPLINE SPLINEDDY) of SPLINE))
-                  (X''' (fetch (SPLINE SPLINEDDDX) of SPLINE))
-                  (Y''' (fetch (SPLINE SPLINEDDDY) of SPLINE))
-                  (%#KNOTS (fetch %#KNOTS of SPLINE))
-                  (X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
-                           1))
-                  (Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
-                           1))
-                  IX IY DX DY XT YT X'T Y'T NEWXT NEWYT XDIFF YDIFF XWALLDT YWALLDT DUPLICATEKNOT 
-                  EXTRANEOUS TT NEWT DELTA DASHON DASHLST DASHCNT HALFVECWIDTH PUTDX EXTRADX PUTDY 
-                  EXTRADY)
-                 (SETQ HALFVECWIDTH (FONTPROP BRUSHFONT 'SIZE))
-          
-          (* Half the width of the brush, in dots.
-        Used to help decide when the line we're drawing goes off-paper.)
-
-                 (SETQ DASHON T)
-          
-          (* These are initialized outside the prog-bindings cause the compiler can't 
-        hack so many initialized variables)
-
-                 (SETQ DASHLST DASHING)
-                 (SETQ DASHCNT (CAR DASHING))
-                 (SETXY.PRESS PRSTREAM (FIXR (FTIMES X0 MicasPerScan))
-                        (FIXR (FTIMES Y0 MicasPerScan)))     (* Move to the first knot on the 
-                                                           curve)
-                 (replace VECMOVINGRIGHT of (fetch IMAGEDATA of PRSTREAM)
-                    with T)                              (* Start by assuming we're moving in 
-                                                           increasing X (since the vector fonts 
-                                                           only have strokes that work in that 
-                                                           direction))
-                 (replace VECWASDISPLAYING of (fetch IMAGEDATA of PRSTREAM)
-                    with (AND (GEQ X0 0)
-                                  (GEQ Y0 0)))
-                 (replace VECSEGCHARS of (fetch IMAGEDATA of PRSTREAM) with
-                                                                                       NIL)
-                 (replace VECCURX of (fetch IMAGEDATA of PRSTREAM) with X0)
-          
-          (* And set the current X and Y positions, denominated in dover spots)
-
-                 (replace VECCURY of (fetch IMAGEDATA of PRSTREAM) with Y0)
-                                                             (* Set up initial values in vec 
-                                                           variables, perform SetX/SetY.)
-                 (SETQ TT 0.0)
-                 (SETQ DELTA 16)
-                 (SETQ IX (FIXR X0))
-                 (SETQ IY (FIXR Y0))
-                 [for KNOT# from 1 to (SUB1 %#KNOTS)
-                    do (LOADPOLY XPOLY X'POLY (ELT X''' KNOT#)
-                                  (ELT X'' KNOT#)
-                                  (ELT X' KNOT#)
-                                  (ELT X KNOT#)) 
-          
-          (* Set up the polynomials that describe X and X' over this segment)
-
-                          (LOADPOLY YPOLY Y'POLY (ELT Y''' KNOT#)
-                                 (ELT Y'' KNOT#)
-                                 (ELT Y' KNOT#)
-                                 (ELT Y KNOT#)) 
-          
-          (* Set up the polynomials that describe Y and Y' over this segment)
-
-                          (SETQ XT (POLYEVAL TT XPOLY 3))    (* XT _ X (t) --Evaluate the next 
-                                                           point)
-                          (SETQ YT (POLYEVAL TT YPOLY 3))    (* YT _ Y (t))
-                          (COND
-                             [(NOT (IEQP KNOT# (SUB1 %#KNOTS)))
-          
-          (* This isn't the last knot. Check to see if the next knot in line is a 
-        duplicated knot.)
-
-                              (SETQ DUPLICATEKNOT (AND (EQP (ELT X (ADD1 KNOT#))
-                                                            (ELT X (IPLUS KNOT# 2)))
-                                                       (EQP (ELT Y (ADD1 KNOT#))
-                                                            (ELT Y (IPLUS KNOT# 2]
-                             (T (SETQ DUPLICATEKNOT NIL)))
-                          [until (GEQ TT 1.0)
-                             do 
-          
-          (* Run the parameter, TT, from 0.0 up to |1.0.|
-        That moves the X and Y locations smoothly from this knot to the next one.)
-
-                                   (SETQ X'T (POLYEVAL TT X'POLY 2)) 
-                                                             (* X'T _ X' (t))
-                                   (SETQ Y'T (POLYEVAL TT Y'POLY 2)) 
-                                                             (* Y'T _ Y' (t))
-                                   (COND
-                                      ((EQP X'T 0.0)
-          
-          (* Never let X' really get to 0.0 -- things become ill-conditioned there.)
-
-                                       (SETQ X'T 5.0E-4)))
-                                   (COND
-                                      ((EQP Y'T 0.0)         (* Likewise Y'.)
-                                       (SETQ Y'T 5.0E-4)))
-                                   [COND
-                                      ((FGTP X'T 0.0)
-          
-          (* If X' is positive, we'll try moving in the +X direction)
-
-                                       (SETQ DX DELTA))
-                                      (T                     (* If not, we'll try the -X 
-                                                           direction.)
-                                         (SETQ DX (IMINUS DELTA]
-                                   [COND
-                                      ((FGTP Y'T 0.0)
-          
-          (* Likewise, if Y' is positive, try moving by DELTA in the +Y direction)
-
-                                       (SETQ DY DELTA))
-                                      (T (SETQ DY (IMINUS DELTA]
-                                   (SETQ XWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IX DX)
-                                                                   XT)
-                                                        X'T)) 
-          
-          (* Compute a dT, based on moving by DELTA in X.)
-
-                                   (SETQ YWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IY DY)
-                                                                   YT)
-                                                        Y'T)) 
-          
-          (* And a dT based on moving by DELTA in Y.)
-
-                                   [COND
-                                      ((FLESSP XWALLDT YWALLDT)
-          
-          (* Use the smaller of the two dT's. In this case, dT for X was smaller, so 
-        compute a new DY as depending on DX.)
-
-                                       (SETQ NEWT (FPLUS TT XWALLDT))
-                                       (SETQ DY (IDIFFERENCE (FIXR (FPLUS YT (FTIMES XWALLDT Y'T)))
-                                                       IY)))
-                                      (T 
-          
-          (* Changing Y gave the smaller dT. Compute a new DX, as though it depended on 
-        DY.)
-
-                                         (SETQ NEWT (FPLUS TT YWALLDT))
-                                         (SETQ DX (IDIFFERENCE (FIXR (FPLUS XT (FTIMES YWALLDT X'T)))
-                                                         IX]
-                                   (SETQ PUTDX DX)
-                                   (SETQ EXTRADX 0)
-                                   (SETQ PUTDY DY)
-                                   (SETQ EXTRADY 0)
-                                   [COND
-                                      ((IGREATERP DX 16)
-                                       (SETQ PUTDX 16)
-                                       (SETQ EXTRADX (IDIFFERENCE DX 16]
-                                   [COND
-                                      ((IGREATERP -16 DX)
-                                       (SETQ PUTDX -16)
-                                       (SETQ EXTRADX (IPLUS DX 16]
-                                   [COND
-                                      ((IGREATERP DY 16)
-                                       (SETQ PUTDY 16)
-                                       (SETQ EXTRADY (IDIFFERENCE DY 16]
-                                   [COND
-                                      ((IGREATERP -16 DY)
-                                       (SETQ PUTDY -16)
-                                       (SETQ EXTRADY (IPLUS DY 16]
-                                   (COND
-                                      ([AND (FGTP NEWT 1.0)
-                                            (OR DUPLICATEKNOT (EQ KNOT# (SUB1 %#KNOTS]
-                                       (SETQ NEWT 1.0)))
-                                   (SETQ NEWXT (POLYEVAL NEWT XPOLY 3)) 
-                                                             (* New XT _ X (new t))
-                                   (SETQ NEWYT (POLYEVAL NEWT YPOLY 3)) 
-                                                             (* New YT _ Y (new t))
-                                   (SETQ XDIFF (ABS (FDIFFERENCE (IPLUS IX DX)
-                                                           NEWXT)))
-                                   (SETQ YDIFF (ABS (FDIFFERENCE (IPLUS IY DY)
-                                                           NEWYT)))
-                                   (COND
-                                      ((AND (IGREATERP DELTA 1)
-                                            (OR (FGTP XDIFF 1.0)
-                                                (FGTP YDIFF 1.0)))
-          
-          (* If we're more than a dover spot off where we'd expect to be because of the 
-        size of DELTA--and if there's room to make DELTA smaller--then try 
-        DELTA_DELTA/2)
-
-                                       (SETQ DELTA (LRSH DELTA 1)))
-                                      (T 
-          
-          (* No, this estimate is close enough. Put out a vector segment based on it, 
-        and move to the new TT.)
-
-                                         (\VECPUT PRSTREAM PUTDX PUTDY HALFVECWIDTH)
-                                                             (* Print out a stroke using the 
-                                                           vector font.)
-                                         (COND
-                                            ((OR (NEQ EXTRADX 0)
-                                                 (NEQ EXTRADY 0))
-          
-          (* If, actually, it was too big for one stroke, use another.)
-
-                                             (\VECPUT PRSTREAM EXTRADX EXTRADY HALFVECWIDTH)))
-                                         (SETQ IX (IPLUS IX DX))
-                                                             (* Our new current location, in 
-                                                           Dover spots)
-                                         (SETQ IY (IPLUS IY DY))
-                                         (SETQ TT NEWT)      (* Set TT to its new value)
-                                         (SETQ XT NEWXT)
-          
-          (* And set the new floating-point values for X
-        (t) and Y (t)%.)
-
-                                         (SETQ YT NEWYT)
-                                         (COND
-                                            ((AND (ILESSP DELTA 16)
-                                                  (OR (FLESSP XDIFF 0.5)
-                                                      (FLESSP YDIFF 0.5)))
-          
-          (* If we were especially close, try making DELTA larger for the next go 
-        round.)
-
-                                             (SETQ DELTA (LLSH DELTA 1]
-                          (SETQ TT (FDIFFERENCE TT 1.0)) 
-          
-          (* Having moved past a knot, back the value of the parameter TT back down.
-        However, don't set it to 0.0--let's try to keep the line going from where it 
-        got to in passing the last knot.)
-
-                          (COND
-                             (DUPLICATEKNOT 
-          
-          (* This next knot is a duplicate. Skip over it, and start from the following 
-        knot. This will avoid odd problems trying to go nowhere while obeying the 
-        constraints of X' and Y' at that knot--since it's a duplicate, X' and Y' are 
-        discontinuous there.)
-
-                                    (add KNOT# 1]
-                 (\ENDVECRUN PRSTREAM HALFVECWIDTH])
-)
-
-
-
-(* Generic utility for coercing fonts, could be used by other devices)
-
-(DEFINEQ
-
-(\COERCEFONT
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE COERCELIST BUTNOT CREATEFLG)
-                                                             (* ; "Edited  9-Mar-88 12:58 by thh:")
-          (* ;; "Returns a font name that the requested font specification coerces to according to COERCELIST.  If CREATEFLG is T, only returns name-lists for which a font descriptor has been created.  BUTNOT can be a list of font-specs which are not an acceptable coercion--e.g.  a previous one that failed, so we want to keep looking beyond that one.")
-(* ;;; "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL (probably only useful for display fonts)")
-          (* ;; "COERCELIST is an alist of font coercions indexed by device, with the value for each device being a list of the form ((user-font real-font) (user-font real-font) ...) --- Each user-font is either simply a family name, or a list of FAMILY, and optionally SIZE, and FACE, in standard font-name order.  Any of these can be NIL, meaning that any requested value matches.  In addition, the SIZE can be either a specific number, or a constraint of the form (< n) or (> n), which matches requested sizes that are less than or greater than the constraint size n.  --- The real-font is a similar family-name or list, except that a NIL field here means that the requested parameter is simply carried over.  Also, no size constraints, only explicit sizes, are allowed.  (e.g., (GACHA) or (GACHA (< 10)) or (GACHA 10))")
-
-    (for TRANSL in (CDR (ASSOC DEVICE COERCELIST)) bind NEWCSINFO USERSPEC REALSPEC 
-                                                                 FAMCONSTRAINT SIZECONSTRAINT 
-                                                                 FACECONSTRAINT NEWFONTNAME
-       when (AND (SETQ USERSPEC (CAR TRANSL))
-                     (OR [NULL (SETQ FAMCONSTRAINT (COND
-                                                      ((LISTP USERSPEC)
-                                                       (pop USERSPEC))
-                                                      (T (PROG1 USERSPEC (SETQ USERSPEC NIL]
-                         (EQ FAMILY FAMCONSTRAINT))
-                     (OR (NOT (SETQ SIZECONSTRAINT (pop USERSPEC)))
-                         (EQ SIZE SIZECONSTRAINT)
-                         (AND (LISTP SIZECONSTRAINT)
-                              (SELECTQ (CAR SIZECONSTRAINT)
-                                  (< (LESSP SIZE (CADR SIZECONSTRAINT)))
-                                  (> (GREATERP SIZE (CADR SIZECONSTRAINT)))
-                                  NIL)))
-                     (OR (NOT (SETQ FACECONSTRAINT (pop USERSPEC)))
-                         (EQUAL FACE FACECONSTRAINT))
-                     (SETQ REALSPEC (CADR TRANSL))
-                     (SETQ NEWFONTNAME (LIST (OR [COND
-                                                    ((LISTP REALSPEC)
-                                                     (pop REALSPEC))
-                                                    (T (PROG1 REALSPEC (SETQ REALSPEC NIL]
-                                                 FAMILY)
-                                             (OR (pop REALSPEC)
-                                                 SIZE)
-                                             (\FONTFACE (OR (pop REALSPEC)
-                                                            FACE))
-                                             ROTATION DEVICE))
-                     (NOT (for EXCLUDE in BUTNOT thereis (EQUAL EXCLUDE NEWFONTNAME)))
-                     (OR (NULL CREATEFLG)
-                         (FONTCREATE NEWFONTNAME NIL NIL NIL NIL T))) do (RETURN NEWFONTNAME])
-)
-
-(ADDTOVAR FONTCOERCIONS (PRESS ((SYMBOL (< 10))
-                                (SYMBOL 10))
-                               ((SYMBOL (> 12))
-                                (SYMBOL 12))))
-
-(ADDTOVAR MISSINGFONTCOERCIONS (PRESS (MODERN HELVETICA)
-                                      (CLASSIC TIMESROMAN)
-                                      (LOGOTYPE LOGO)
-                                      (TERMINAL GACHA)
-                                      (MODERN FRUTIGER)
-                                      (CLASSIC CENTURY)))
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS FONTCOERCIONS MISSINGFONTCOERCIONS)
-)
-(DEFINEQ
-
-(\STRINGWIDTH.PRESS
-  [LAMBDA (STREAM STRING RDTBL)                          (* rmk%: "24-Feb-86 09:49")
-          
-          (* Returns the width of STRING in the press STREAM, observing spacefactor)
-
-    (\STRINGWIDTH.GENERIC STRING (ffetch PRLOGICALFONT of (ffetch IMAGEDATA of STREAM
-                                                                         ))
-           RDTBL
-           (ffetch PRSPACEWIDTH of (ffetch IMAGEDATA of STREAM])
-
-(\CHARWIDTH.PRESS
-  [LAMBDA (STREAM CHARCODE)                              (* rmk%: "24-Feb-86 09:49")
-          
-          (* Gets the width of CHARCODE in a Press STREAM, observing spacefactor)
-
-    (COND
-       ((EQ CHARCODE (CHARCODE SPACE))
-        (ffetch PRSPACEWIDTH of (ffetch IMAGEDATA of STREAM)))
-       (T (\FGETCHARWIDTH (ffetch PRLOGICALFONT of (ffetch IMAGEDATA of STREAM))
-                 CHARCODE])
-
-(\OUTCHARFN.PRESS
-  [LAMBDA (PRSTREAM CHARCODE)                            (* rmk%: "24-Feb-86 12:18")
-          
-          (* Handle all the special-purpose characters going to a PRESS file)
-
-    (SELCHARQ CHARCODE
-         (EOL                                                (* New Line)
-              (NEWLINE.PRESS PRSTREAM)
-              (replace (STREAM CHARPOSITION) of PRSTREAM with 0))
-         (LF                                                 (* Line feed--move down, but not 
-                                                           over)
-             (\DSPXPOSITION.PRESS PRSTREAM (PROG1 (DSPXPOSITION NIL PRSTREAM)
-                                                  (NEWLINE.PRESS PRSTREAM))))
-         (^L                                                 (* Form Feed)
-             (replace (STREAM CHARPOSITION) of PRSTREAM with 0)
-             (NEWPAGE.PRESS PRSTREAM))
-         (PROG (XPOS NEWXPOS CLIPPINGREGION PRCHARCODE TRANSLATION (CHARSET (\CHARSET CHARCODE))
-                     (PRDATA (fetch IMAGEDATA of PRSTREAM)))
-               [if (NEQ CHARSET (ffetch PRLOGICALCHARSET of PRDATA))
-                   then (LET [(CSINFO (\GETCHARSETINFO CHARSET (ffetch PRLOGICALFONT
-                                                                      of PRDATA]
-                                 (UNINTERRUPTABLY
-                                     (freplace PRWIDTHSCACHE of PRDATA
-                                        with (fetch (CHARSETINFO WIDTHS) of CSINFO))
-                                     (freplace PRTRANSLATIONCACHE of PRDATA
-                                        with (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO
-                                                        ))
-                                     (freplace PRLOGICALCHARSET of PRDATA with CHARSET))]
-               (SETQ TRANSLATION (\GETBASEPTR (ffetch PRTRANSLATIONCACHE of PRDATA)
-                                        (UNFOLD (\CHAR8CODE CHARCODE)
-                                               2)))
-               (if (NEQ (CAR TRANSLATION)
-                            (fetch PRFONT of PRDATA))
-                   then (\DSPFONT.PRESSFONT PRSTREAM (CAR TRANSLATION)))
-               (SETQ PRCHARCODE (CDR TRANSLATION))
-               (SETQ XPOS (fetch PRXPOS of PRDATA))
-               [SETQ NEWXPOS (IPLUS XPOS (COND
-                                            ((EQ CHARCODE (CHARCODE SPACE))
-                                             (ffetch PRSPACEWIDTH of PRDATA))
-                                            (T (\FGETWIDTH (ffetch (PRESSDATA PRWIDTHSCACHE)
-                                                              of PRDATA)
-                                                      (\CHAR8CODE CHARCODE]
-               (COND
-                  ((AND [IGEQ XPOS (fetch LEFT of (SETQ CLIPPINGREGION (fetch 
-                                                                                     PRClippingRegion
-                                                                                  of PRDATA]
-                        (ILEQ NEWXPOS (fetch RIGHT of CLIPPINGREGION))
-                        (IGEQ (fetch PRYPOS of PRDATA)
-                              (fetch BOTTOM of CLIPPINGREGION)))
-          
-          (* Bottom test should really subtract off the descent, and also should do a 
-        top-test)
-          
-          (* The Y-tests can probably be done inside SETXY, SETY, and DSPFONT.)
-
-                   [COND
-                      ((NOT (ffetch CHARWASDISPLAYING of PRDATA))
-                                                             (* Was being clipped, now not)
-                       (freplace CHARWASDISPLAYING of PRDATA with T)
-                       (SHOW.PRESS PRSTREAM)                 (* SHOW shouldn't be necessary, but 
-                                                           |...|)
-                       (SETXY.PRESS PRSTREAM XPOS (fetch PRYPOS of PRDATA]
-                   (\BOUT PRSTREAM PRCHARCODE))
-                  (T (SHOW.PRESS PRSTREAM)
-          
-          (* Don't put out any characters if out of the clipping region)
-
-                     (freplace CHARWASDISPLAYING of PRDATA with NIL)))
-               (replace PRXPOS of PRDATA with NEWXPOS])
-)
-(* * new declaration for PRESSDATA)
-
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(DATATYPE PRESSDATA (PRHEADING                               (* ; 
-                                                           "The string to be printed atop each page.")
-                           PRHEADINGFONT                     (* ; "Font to print the heading in")
-                           PRXPOS                            (* ; "Current X position")
-                           PRYPOS                            (* ; "Current Y position")
-                           PRFONT                            (* ; "Current font")
-                           PRCURRFDE PRESSFONTDIR (PRWIDTHSCACHE POINTER 
-                                                             (* ; 
-                                                 "Widths table for the current logical character set")
-                                                         )
-                           PRCOLOR PRLINEFEED PRPAGESTATE PDSTREAM ELSTREAM XPRPAGEREGION PRDOCNAME
-                           (PRLEFT WORD)                     (* ; "Page left margin")
-                           (PRBOTTOM WORD)                   (* ; "Page bottom margin")
-                           (PRRIGHT WORD)                    (* ; "Page right margin")
-                           (PRTOP WORD)                      (* ; "Page top margin")
-                           (PRPAGENUM WORD)                  (* ; "Current Page number")
-                           (PRNEXTFONT# BYTE)
-                           (PRMAXFONTSET BYTE)
-                           (PRPARTSTART INTEGER)
-                           (DLSTARTBYTE INTEGER)
-                           (ELSTARTBYTE INTEGER)
-                           (STARTCHARBYTE INTEGER)
-                           (VECMOVINGRIGHT FLAG)             (* ; 
-                            "If we're drawing a curve with vector fonts, are we moving to the right?")
-                           (VECWASDISPLAYING FLAG)
-
-                           (* ;; "Used during curve/line clipping to remember whether we were on-screen or not, so we know when to force a SETXY.")
-
-                           VECSEGCHARS                       (* ; 
-                                        "Cache for vector characters while we're moving to the left.")
-                           VECCURX                           (* ; 
-                                              "Current X position within vector code, in Dover spots")
-                           VECCURY                           (* ; 
-                                                "Current Y position with vector code, in Dover spots")
-                           PRSPACEFACTOR PRSPACEWIDTH (CHARWASDISPLAYING FLAG)
-                                                             (* ; 
-                           "Says whether we have been printing characters inside the clipping region")
-                           PRClippingRegion
-
-                           (* ;; "The edges of the paper, as far as PRESS is concerned.  Used to protect SPRUCE users who get killed when the image goes off-paper")
-
-                           PRLOGICALFONT                     (* ; "Current logical font")
-                           PRLOGICALCHARSET                  (* ; 
-                      "Current logical character set, whose info is cached.  NIL if cache is invalid")
-                           (PRTRANSLATIONCACHE POINTER       (* ; 
-                                            "Translation table for the current logical character set")
-                                  ))
-                    PRSPACEFACTOR _ 1 PRXPOS _ 0 PRYPOS _ 0  (* ; 
-                      "We assume that the origin is translated to the bottom-left of the page region")
-                    PRClippingRegion _ (create REGION
-                                              LEFT _ SPRUCEPAPERLEFTMICAS
-                                              BOTTOM _ SPRUCEPAPERBOTTOMMICAS
-                                              WIDTH _ (DIFFERENCE SPRUCEPAPERRIGHTMICAS 
-                                                             SPRUCEPAPERLEFTMICAS)
-                                              HEIGHT _ 29210)
-                    [ACCESSFNS ((PRWIDTH (IDIFFERENCE (fetch (PRESSDATA PRRIGHT) of DATUM)
-                                                (fetch (PRESSDATA PRLEFT) of DATUM)))
-                                (PRHEIGHT (IDIFFERENCE (fetch (PRESSDATA PRTOP) of DATUM)
-                                                 (fetch (PRESSDATA PRBOTTOM) of DATUM)))
-                                (PRPAGEREGION (fetch (PRESSDATA XPRPAGEREGION) of DATUM)
-                                       (PROGN (replace (PRESSDATA XPRPAGEREGION) of DATUM
-                                                 with NEWVALUE)
-                                              (replace (PRESSDATA PRLEFT) of DATUM
-                                                 with (fetch (REGION LEFT) of NEWVALUE))
-                                              (replace (PRESSDATA PRBOTTOM) of DATUM
-                                                 with (fetch (REGION BOTTOM) of NEWVALUE))
-                                              (replace (PRESSDATA PRRIGHT) of DATUM
-                                                 with (IPLUS (fetch (REGION LEFT) of NEWVALUE)
-                                                             (fetch (REGION WIDTH) of NEWVALUE)))
-                                              (replace (PRESSDATA PRTOP) of DATUM
-                                                 with (IPLUS (fetch (REGION BOTTOM) of NEWVALUE)
-                                                             (fetch (REGION HEIGHT) of NEWVALUE])
-)
-
-(/DECLAREDATATYPE 'PRESSDATA
-       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-               POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP
-               FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER
-               )
-       '((PRESSDATA 0 POINTER)
-         (PRESSDATA 2 POINTER)
-         (PRESSDATA 4 POINTER)
-         (PRESSDATA 6 POINTER)
-         (PRESSDATA 8 POINTER)
-         (PRESSDATA 10 POINTER)
-         (PRESSDATA 12 POINTER)
-         (PRESSDATA 14 POINTER)
-         (PRESSDATA 16 POINTER)
-         (PRESSDATA 18 POINTER)
-         (PRESSDATA 20 POINTER)
-         (PRESSDATA 22 POINTER)
-         (PRESSDATA 24 POINTER)
-         (PRESSDATA 26 POINTER)
-         (PRESSDATA 28 POINTER)
-         (PRESSDATA 30 (BITS . 15))
-         (PRESSDATA 31 (BITS . 15))
-         (PRESSDATA 32 (BITS . 15))
-         (PRESSDATA 33 (BITS . 15))
-         (PRESSDATA 34 (BITS . 15))
-         (PRESSDATA 35 (BITS . 7))
-         (PRESSDATA 35 (BITS . 135))
-         (PRESSDATA 36 FIXP)
-         (PRESSDATA 38 FIXP)
-         (PRESSDATA 40 FIXP)
-         (PRESSDATA 42 FIXP)
-         (PRESSDATA 28 (FLAGBITS . 0))
-         (PRESSDATA 28 (FLAGBITS . 16))
-         (PRESSDATA 44 POINTER)
-         (PRESSDATA 46 POINTER)
-         (PRESSDATA 48 POINTER)
-         (PRESSDATA 50 POINTER)
-         (PRESSDATA 52 POINTER)
-         (PRESSDATA 52 (FLAGBITS . 0))
-         (PRESSDATA 54 POINTER)
-         (PRESSDATA 56 POINTER)
-         (PRESSDATA 58 POINTER)
-         (PRESSDATA 60 POINTER))
-       '62)
-)
-
-(/DECLAREDATATYPE 'PRESSDATA
-       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
-               POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP
-               FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER
-               )
-       '((PRESSDATA 0 POINTER)
-         (PRESSDATA 2 POINTER)
-         (PRESSDATA 4 POINTER)
-         (PRESSDATA 6 POINTER)
-         (PRESSDATA 8 POINTER)
-         (PRESSDATA 10 POINTER)
-         (PRESSDATA 12 POINTER)
-         (PRESSDATA 14 POINTER)
-         (PRESSDATA 16 POINTER)
-         (PRESSDATA 18 POINTER)
-         (PRESSDATA 20 POINTER)
-         (PRESSDATA 22 POINTER)
-         (PRESSDATA 24 POINTER)
-         (PRESSDATA 26 POINTER)
-         (PRESSDATA 28 POINTER)
-         (PRESSDATA 30 (BITS . 15))
-         (PRESSDATA 31 (BITS . 15))
-         (PRESSDATA 32 (BITS . 15))
-         (PRESSDATA 33 (BITS . 15))
-         (PRESSDATA 34 (BITS . 15))
-         (PRESSDATA 35 (BITS . 7))
-         (PRESSDATA 35 (BITS . 135))
-         (PRESSDATA 36 FIXP)
-         (PRESSDATA 38 FIXP)
-         (PRESSDATA 40 FIXP)
-         (PRESSDATA 42 FIXP)
-         (PRESSDATA 28 (FLAGBITS . 0))
-         (PRESSDATA 28 (FLAGBITS . 16))
-         (PRESSDATA 44 POINTER)
-         (PRESSDATA 46 POINTER)
-         (PRESSDATA 48 POINTER)
-         (PRESSDATA 50 POINTER)
-         (PRESSDATA 52 POINTER)
-         (PRESSDATA 52 (FLAGBITS . 0))
-         (PRESSDATA 54 POINTER)
-         (PRESSDATA 56 POINTER)
-         (PRESSDATA 58 POINTER)
-         (PRESSDATA 60 POINTER))
-       '62)
-(* * NSTOASCIITRANSLATIONS is a list with elements of the form (charset translationArrayName) %, where
- translationArrayName is bound to a translation array for charset which contains (fontFamily charcode)
- lists)
-
-(DEFINEQ
-
-(\NSTOASCIIARRAY
-  [LAMBDA (CHARSET)                                      (* thh%: "17-Feb-86 09:05")
-                                                             (* gets the translation array to use 
-                                                           for this charset)
-    (EVAL (CADR (ASSOC CHARSET NSTOASCIITRANSLATIONS])
-
-(\NSTOASCIITRANSLATION
-  [LAMBDA (TRANSLATION FAMILY FONTDESC)                  (* thh%: " 5-Mar-86 10:23")
-          
-          (* returns (fontdesc . charcode) to use in place of the specified 8-bit 
-        charcode)
-          
-          (* FAMILY, if specified, is font family to use when not specified by the 
-        translation array)
-          
-          (* * determine the (family charcode) translation)
-
-    (OR TRANSLATION (SETQ TRANSLATION unknownCharTranslation))
-    [COND
-       ((FIXP TRANSLATION)
-        (SETQ TRANSLATION (LIST (OR FAMILY FONTDESC)
-                                TRANSLATION]
-          
-          (* * coerce to a full font descriptor)
-
-    (CONS (\PRESS.COERCEFONT FONTDESC (CAR TRANSLATION))
-          (CADR TRANSLATION])
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS NSTOASCIITRANSLATIONS PRESSFONTFAMILIES)
-)
-
-(RPAQ? PRESSFONTFAMILIES '((GACHA)
-                           (TIMESROMAN)
-                           (HELVETICA)
-                           (SYMBOL)
-                           (MATH)
-                           (HIPPO)
-                           (CYRILLIC)
-                           (NEWVEC)
-                           (SNEWVEC)
-                           (HNEWVEC)
-                           (VNEWVEC)))
-
-(RPAQ? NSTOASCIITRANSLATIONS )
-
-(ADDTOVAR NSTOASCIITRANSLATIONS (0 ASCIIFROM0ARRAY)
-                                (38 ASCIIFROM38ARRAY)
-                                (39 ASCIIFROM39ARRAY)
-                                (239 ASCIIFROM239ARRAY))
-
-(READVARS-FROM-STRINGS '(ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY ASCIIFROM239ARRAY)
-       "({Y256 POINTER 0 {R163 NIL}  (SYMBOL 126)  (SYMBOL 127) NIL NIL  (SYMBOL 120) NIL 96 NIL NIL  (SYMBOL 
-55)  (SYMBOL 34)  (SYMBOL 33)  (SYMBOL 35) NIL  (SYMBOL 6) NIL NIL  (SYMBOL 2) NIL  (SYMBOL 123) NIL  
-(SYMBOL 13) 39 {R25 NIL}  (SYMBOL 125) {R44 NIL} }  {Y256 POINTER 0  (HIPPO 118) {R64 NIL}  (HIPPO 65)
-  (HIPPO 66) NIL  (HIPPO 71)  (HIPPO 68)  (HIPPO 69) NIL NIL  (HIPPO 90)  (HIPPO 72)  (HIPPO 81)  (
-HIPPO 73)  (HIPPO 75)  (HIPPO 76)  (HIPPO 77)  (HIPPO 78)  (HIPPO 67)  (HIPPO 79)  (HIPPO 80) NIL  (
-HIPPO 82)  (HIPPO 83) NIL  (HIPPO 84)  (HIPPO 85)  (HIPPO 70)  (HIPPO 88)  (HIPPO 89)  (HIPPO 87) NIL 
-NIL NIL  (HIPPO 97)  (HIPPO 98) NIL  (HIPPO 103)  (HIPPO 100)  (HIPPO 101) NIL NIL  (HIPPO 122)  (
-HIPPO 104)  (HIPPO 113)  (HIPPO 105)  (HIPPO 107)  (HIPPO 108)  (HIPPO 109)  (HIPPO 110)  (HIPPO 99)  
-(HIPPO 111)  (HIPPO 112) NIL  (HIPPO 114)  (HIPPO 115)  (HIPPO 106)  (HIPPO 116)  (HIPPO 117)  (HIPPO 
-102)  (HIPPO 120)  (HIPPO 121)  (HIPPO 119) {R130 NIL} }  {Y256 POINTER 0  (CYRILLIC 127) {R32 NIL}  (
-CYRILLIC 65)  (CYRILLIC 66)  (CYRILLIC 86)  (CYRILLIC 71)  (CYRILLIC 68)  (CYRILLIC 69)  (CYRILLIC 36)
-  (CYRILLIC 87)  (CYRILLIC 90)  (CYRILLIC 73)  (CYRILLIC 74)  (CYRILLIC 75)  (CYRILLIC 76)  (CYRILLIC 
-77)  (CYRILLIC 78)  (CYRILLIC 79)  (CYRILLIC 80)  (CYRILLIC 82)  (CYRILLIC 83)  (CYRILLIC 84)  (
-CYRILLIC 85)  (CYRILLIC 70)  (CYRILLIC 81)  (CYRILLIC 126)  (CYRILLIC 42)  (CYRILLIC 123)  (CYRILLIC 
-125)  (CYRILLIC 94)  (CYRILLIC 88)  (CYRILLIC 67)  (CYRILLIC 64)  (CYRILLIC 89)  (CYRILLIC 72) {R15 
-NIL}  (CYRILLIC 97)  (CYRILLIC 98)  (CYRILLIC 118)  (CYRILLIC 103)  (CYRILLIC 100)  (CYRILLIC 101)  (
-CYRILLIC 52)  (CYRILLIC 119)  (CYRILLIC 122)  (CYRILLIC 105)  (CYRILLIC 106)  (CYRILLIC 107)  (
-CYRILLIC 108)  (CYRILLIC 109)  (CYRILLIC 110)  (CYRILLIC 111)  (CYRILLIC 112)  (CYRILLIC 114)  (
-CYRILLIC 115)  (CYRILLIC 116)  (CYRILLIC 117)  (CYRILLIC 102)  (CYRILLIC 113)  (CYRILLIC 54)  (
-CYRILLIC 56)  (CYRILLIC 91)  (CYRILLIC 93)  (CYRILLIC 95)  (CYRILLIC 120)  (CYRILLIC 143)  (CYRILLIC 
-50)  (CYRILLIC 121)  (CYRILLIC 104) {R12 NIL}  (CYRILLIC 99) {R129 NIL} }  {Y256 POINTER 0 {R36 NIL}  
-(TIMESROMAN 155)  (TIMESROMAN 156) {R6 NIL}  (TIMESROMAN 152)  (TIMESROMAN 153) NIL  (TIMESROMAN 159) 
- (MATH 33)  (MATH 70)  (SYMBOL 104)  (SYMBOL 105) NIL NIL  (SYMBOL 96)  (SYMBOL 97)  (MATH 113) NIL  (
-SYMBOL 109)  (SYMBOL 108)  (MATH 116)  (MATH 118)  (MATH 115)  (MATH 117)  (MATH 64) NIL  (SYMBOL 37) 
- (SYMBOL 38) {R4 NIL}  (MATH 109) NIL  (MATH 66)  (MATH 78)  (MATH 44)  (SYMBOL 40)  (SYMBOL 44)  (
-SYMBOL 41)  (MATH 126)  (MATH 81)  (SYMBOL 36)  (MATH 98) NIL NIL  (SYMBOL 92)  (SYMBOL 91)  (SYMBOL 
-19)  (SYMBOL 18)  (SYMBOL 27)  (SYMBOL 26) NIL NIL  (MATH 75)  (MATH 72) NIL  (MATH 79)  (SYMBOL 8)  (
-SYMBOL 9)  (MATH 54)  (SYMBOL 11)  (TIMESROMAN 183)  (SYMBOL 5)  (MATH 104) NIL  (SYMBOL 58) NIL  (
-SYMBOL 54) NIL NIL  (MATH 22)  (SYMBOL 16)  (MATH 80)  (SYMBOL 17)  (SYMBOL 29) NIL  (SYMBOL 115)  (
-MATH 7)  (SYMBOL 39) NIL  (SYMBOL 25)  (MATH 19)  (MATH 1)  (SYMBOL 112)  (SYMBOL 7) {R41 NIL}  (
-SYMBOL 59) {R6 NIL}  (MATH 82) NIL  (SYMBOL 100)  (SYMBOL 101)  (SYMBOL 98)  (SYMBOL 99)  (SYMBOL 57) 
- (SYMBOL 56)  (SYMBOL 94)  (SYMBOL 95)  (MATH 90)  (MATH 68)  (MATH 100) {R69 NIL} })
-")
-
-(\SMASHPRESSFONTS)
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ unknownCharTranslation (MATH 59))
-
-
-[CONSTANTS (unknownCharTranslation '(MATH 59]
-)
-)
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (2898 3274 (\SMASHPRESSFONTS 2908 . 3272)) (3275 8422 (GETCHARPRESSTRANSLATION 3285 . 
-4793) (PRESS.NSARRAY 4795 . 6118) (PUTCHARPRESSTRANSLATION 6120 . 8420)) (8423 19133 (\DSPFONT.PRESS 
-8433 . 9884) (\DSPSPACEFACTOR.PRESS 9886 . 10738) (\ENTITYSTART.PRESS 10740 . 12462) (\SETSPACE.PRESS 
-12464 . 13166) (\STARTPAGE.PRESS 13168 . 15276) (\PRESS.COERCEFONT 15278 . 16744) (\DSPFONT.PRESSFONT 
-16746 . 18120) (SETUPFONTS.PRESS 18122 . 19131)) (19134 40822 (\CREATEPRESSFONT 19144 . 20342) (
-\CREATECHARSET.PRESS 20344 . 25444) (\CREATECHARSETZERO.PRESS 25446 . 40820)) (40823 55366 (
-\PRESSCURVE2 40833 . 55364)) (55446 59198 (\COERCEFONT 55456 . 59196)) (59822 65319 (
-\STRINGWIDTH.PRESS 59832 . 60325) (\CHARWIDTH.PRESS 60327 . 60792) (\OUTCHARFN.PRESS 60794 . 65317)) (
-74712 75877 (\NSTOASCIIARRAY 74722 . 75074) (\NSTOASCIITRANSLATION 75076 . 75875)))))
-STOP
diff --git a/obsolete/lispusers/PRESSFROMNS.TEDIT b/obsolete/lispusers/PRESSFROMNS.TEDIT
deleted file mode 100644
index 26a478d1..00000000
Binary files a/obsolete/lispusers/PRESSFROMNS.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/PS-PATCH b/obsolete/lispusers/PS-PATCH
deleted file mode 100644
index a0cc1ac3..00000000
--- a/obsolete/lispusers/PS-PATCH
+++ /dev/null
@@ -1,434 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-(FILECREATED " 8-Nov-90 18:53:15" |{PELE:MV:ENVOS}<LISPUSERS>MEDLEY>POSTSCRIPT>PS-PATCH.;2| 24907  
-
-      changes to%:  (VARS PS-PATCHCOMS)
-                    (PROPS (PS-PATCH MAKEFILE-ENVIRONMENT))
-                    (FNS FIX-SKETCH)
-
-      previous date%: "22-Feb-89 14:11:29" |{PELE:MV:ENVOS}<LISPUSERS>MEDLEY>POSTSCRIPT>PS-PATCH.;1|
-)
-
-
-(* ; "
-Copyright (c) 1989, 1990 by ENVOS Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT PS-PATCHCOMS)
-
-(RPAQQ PS-PATCHCOMS
-       ((PROP (MAKEFILE-ENVIRONMENT FILETYPE)
-              PS-PATCH)
-        (FNS ADD.KNOWN.SKETCH.FONT NEW-SK-PICK-FONT NEW-SK-DECREASING-FONT-LIST 
-             NEW-SKETCHW-HARDCOPYFN FIX-SKETCH)
-        [VARS (SKETCH-PATCHES '((NEW-SK-PICK-FONT . SK.PICK.FONT)
-                                (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST)
-                                (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN]
-        
-        (* ;; 
-     "NOTE: to compile the following 2 functions you need FONT loaded prop and EXPORTS.ALL loaded.")
-
-        (FNS \BUILDSLUGCSINFO \CREATECHARSET)
-        (ADDVARS (POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA)
-                        (TIMESROMAND . TIMESROMAN)
-                        (COURIER . COURIER)
-                        (GACHA . COURIER)
-                        (CLASSIC . TIMESROMAN)
-                        (MODERN . HELVETICA)
-                        (CREAM . HELVETICA)
-                        (TERMINAL . COURIER)
-                        (LOGO . HELVETICA)
-                        (MODERN . HELVETICA)))
-        (VARS (\KNOWN.SKETCH.FONTSIZES))
-        (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)
-               POSTSCRIPT.FONT.CONVERSIONS)
-        
-        (* ;; "finally actually do the patching of sketch.")
-
-        (P (FIX-SKETCH))))
-
-(PUTPROPS PS-PATCH MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10
-                                                       ))
-
-(PUTPROPS PS-PATCH FILETYPE :TCOMPL)
-(DEFINEQ
-
-(ADD.KNOWN.SKETCH.FONT
-  [LAMBDA (FAMILY WID DEVICE FONT)                       (* ; "Edited 21-Feb-89 15:06 by snow")
-
-    (* ;; "add to the globally cached font list")
-
-    (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES))
-    (LET ((CACHE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES))
-          (CACHED))
-         (COND
-            [(NULL CACHE)
-             (if \KNOWN.SKETCH.FONTSIZES
-                 then [NCONC1 \KNOWN.SKETCH.FONTSIZES (LIST FAMILY (LIST DEVICE (CONS WID FONT]
-               else (SETQ \KNOWN.SKETCH.FONTSIZES (LIST (LIST FAMILY (LIST DEVICE
-                                                                               (CONS WID FONT]
-            (T (COND
-                  ((SETQ CACHED (ASSOC DEVICE CACHE))
-                   (NCONC1 CACHED (CONS WID FONT)))
-                  (T (NCONC1 CACHE (CONS DEVICE (CONS WID FONT])
-
-(NEW-SK-PICK-FONT
-  [LAMBDA (WID STRING DEVICE FAMILY)                     (* ; "Edited 22-Feb-89 07:53 by snow")
-
-    (* ;; "returns the font in FAMILY that text should be printed in to have the text STRING fit into a region WID points wide")
-
-    (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES))
-    (PROG (LASTFONT LASTSIZE DISPLAYFONT SCALE CACHEDFONT)
-          (IF [SETQ CACHEDFONT (ASSOC WID (ASSOC DEVICE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES]
-              THEN (RETURN (CDR CACHEDFONT)))
-          (RETURN (for FONT in (SK.DECREASING.FONT.LIST FAMILY DEVICE)
-                     when (NOT (GREATERP [SETQ LASTSIZE (COND
-                                                               ((SETQ SCALE (FONTPROP FONT
-                                                                                   'SCALE))
-
-                                                                (* ;; 
-                                                    "IF THERE IS A SCALE, YOU MUST SCALE THE FONT.")
-
-                                                                (QUOTIENT (STRINGWIDTH STRING FONT)
-                                                                       SCALE))
-                                                               ((SETQ DISPLAYFONT (FONTCOPY
-                                                                                   (SETQ LASTFONT 
-                                                                                    FONT)
-                                                                                   'DEVICE
-                                                                                   'DISPLAY
-                                                                                   'NOERROR T))
-                                                             (* ; "use display if it exists.")
-                                                                (STRINGWIDTH STRING DISPLAYFONT))
-                                                               (T 
-                                                             (* ; 
-                                       "in some cases, font exists for devices other than display.")
-                                                                  (QUOTIENT (STRINGWIDTH STRING FONT)
-                                                                         (FONTPROP FONT 'SCALE]
-                                          WID)) do       (* ; 
-       "return a font for the proper device even though the display fonts are used to pick a size.")
-                                                      (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE
-                                                             (FONTCOPY FONT 'DEVICE DEVICE))
-                                                      (RETURN (FONTCOPY FONT 'DEVICE DEVICE))
-                     finally (RETURN (COND
-                                            ((OR (NULL LASTFONT)
-                                                 (GREATERP LASTSIZE (TIMES 1.5 WID)))
-                                             'SHADE)
-                                            (T               (* ; 
-                                                          "use the smallest if it isn't too large.")
-                                               (FONTCOPY LASTFONT 'DEVICE DEVICE])
-
-(NEW-SK-DECREASING-FONT-LIST
-  [LAMBDA (FAMILY DEVICETYPE)                            (* ; "Edited 21-Feb-89 11:26 by snow")
-
-    (* ;; "returns a list of fonts of family FAMILY which work on device DEVICETYPE")
-
-    [COND
-       ((NULL FAMILY)
-        (SETQ FAMILY 'MODERN]
-
-    (* ;; "convert to families that exist on the known devices.")
-
-(* ;;; "NOTE: this is a very bad way to convert the family.  It HARDCODES in the conversions for PRESS and INTERPRESS  and does nothing for new device types.  I have added the conversion for POSTSCRIPT that does things a little cleaner, but it should really look at a property of the device (fontconversions or some such animal.)  --was 2/19/89")
-
-    (LET ((CONVERSION))
-         [COND
-            [(EQ DEVICETYPE 'PRESS)
-             (COND
-                ((EQ FAMILY 'MODERN)
-                 (SETQ FAMILY 'HELVETICA))
-                ((EQ FAMILY 'CLASSIC)
-                 (SETQ FAMILY 'TIMESROMAN))
-                ((EQ FAMILY 'TERMINAL)
-                 (SETQ FAMILY 'GACHA]
-            [(EQ DEVICETYPE 'INTERPRESS)
-             (COND
-                ((EQ FAMILY 'HELVETICA)
-                 (SETQ FAMILY 'MODERN))
-                ((EQ FAMILY 'TIMESROMAN)
-                 (SETQ FAMILY 'CLASSIC))
-                ((EQ FAMILY 'GACHA)
-                 (SETQ FAMILY 'TERMINAL]
-            ((EQ DEVICETYPE 'POSTSCRIPT)
-             (if (SETQ CONVERSION (ASSOC FAMILY POSTSCRIPT.FONT.CONVERSIONS))
-                 then 
-
-                       (* ;; 
-                  "convert the family here for postscript as well as the other well known devices.")
-
-                       (SETQ FAMILY (CDR CONVERSION]
-         (for FONT in (SK.GUESS.FONTSAVAILABLE FAMILY DEVICETYPE)
-            collect (FONTCOPY FONT 'DEVICE DEVICETYPE])
-
-(NEW-SKETCHW-HARDCOPYFN
-  [LAMBDA (SKETCHW OPENIMAGESTREAM)                      (* ; "Edited 22-Feb-89 13:34 by snow")
-                                                             (* ; 
-                                                           "dumps the sketch onto OPENIMAGESTREAM.")
-                                                             (* ; 
-                                       "centers it within the DSPCLIPPINGREGION of OPENIMAGESTREAM")
-    (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW)))
-           (PAGEREGION (DSPCLIPPINGREGION NIL OPENIMAGESTREAM))
-           (SKETCHREGION (SKETCH.REGION.VIEWED SKETCHW))
-           (SCALE (VIEWER.SCALE SKETCHW))
-           SKETCHREGIONINPAGECOORDS PAGELEFTSPACE PAGEBOTTOMSPACE PAGETOSKETCHFACTOR SKETCHX)
-          (OR SKETCH (RETURN))
-          (SPAWN.MOUSE)
-
-     (* ;; "move the margins out of the way")
-
-     (* ;; 
-   "smallp is to maintain compatibility with koto.  For Lute release, this could be increased.")
-
-          (DSPLEFTMARGIN (MIN 0 (fetch (REGION LEFT) of PAGEREGION))
-                 OPENIMAGESTREAM)
-          (DSPBOTTOMMARGIN (MIN 0 (fetch (REGION BOTTOM) of PAGEREGION))
-                 OPENIMAGESTREAM)
-          (DSPTOPMARGIN (MAX MAX.SMALLP (fetch (REGION TOP) of PAGEREGION))
-                 OPENIMAGESTREAM)
-          (DSPRIGHTMARGIN (MAX MAX.SMALLP (fetch (REGION RIGHT) of PAGEREGION))
-                 OPENIMAGESTREAM)
-
-     (* ;; "PAGETOSKETCHFACTOR is the factor to multiply the page coordinates by to get into sketch coordinates.")
-
-          (STATUSPRINT SKETCHW "Hardcopying ...")
-          [STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS (APPEND (LIST 'DOCUMENT.NAME (OR (SKETCH.TITLE
-                                                                                      SKETCHW)
-                                                                                     "A Sketch"))
-                                                           (STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS]
-          (SETQ PAGETOSKETCHFACTOR (FQUOTIENT SCALE (DSPSCALE NIL OPENIMAGESTREAM)))
-          (SETQ SKETCHREGIONINPAGECOORDS (SCALE.REGION.OUT SKETCHREGION PAGETOSKETCHFACTOR))
-          (COND
-             ((AND (NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM)
-                            'PRESS))
-                   (NOT (EQ (FETCH (IMAGEOPS IMROTATE) OF (FETCH (STREAM IMAGEOPS)
-                                                                     OF OPENIMAGESTREAM))
-                            'NILL))
-                   (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS)
-                          (fetch WIDTH of PAGEREGION))
-                   (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS)
-                          (fetch HEIGHT of SKETCHREGIONINPAGECOORDS)))
-
-              (* ;; "we ;have a  stream that supports rotation, use it!")
-
-              (DSPROTATE 90 OPENIMAGESTREAM)
-              (DSPTRANSLATE 0 (MINUS (FETCH (REGION HEIGHT) OF PAGEREGION))
-                     OPENIMAGESTREAM)
-              (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION))
-                     OPENIMAGESTREAM)
-
-              (* ;; "(ROTATE.IP OPENIMAGESTREAM 90) (CONCATT.IP OPENIMAGESTREAM) (TRANSLATE.IP OPENIMAGESTREAM 0 -21590) (CONCATT.IP OPENIMAGESTREAM) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM)")
-
-              (* ;; "this was an incredibly bogus hack to make INTERPRESS only streams rotate the sketch image if they were too big.  Now it tries to do it on any stream that has a dsprotate function.")
-
-              ))
-          (SETQ PAGELEFTSPACE (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION)
-                                               (fetch (REGION WIDTH) of 
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                      ))
-                                     2))
-          (SETQ PAGEBOTTOMSPACE (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION)
-                                                 (fetch (REGION HEIGHT) of 
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                        ))
-                                       2))
-
-     (* ;; "translate the sketch so that the lower left corner of the sketch region is at the lower left corner of the image on the page.")
-
-          [SETQ SKETCHX (TRANSLATE.SKETCH SKETCH (MINUS (TIMES (DIFFERENCE
-                                                                (SETQ PAGELEFTSPACE
-                                                                 (PLUS (fetch (REGION LEFT)
-                                                                          of PAGEREGION)
-                                                                       PAGELEFTSPACE))
-                                                                (fetch (REGION LEFT) of
-                                                                                         
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                                       ))
-                                                               PAGETOSKETCHFACTOR))
-                               (MINUS (TIMES (DIFFERENCE (SETQ PAGEBOTTOMSPACE
-                                                          (PLUS (fetch (REGION BOTTOM)
-                                                                   of PAGEREGION)
-                                                                PAGEBOTTOMSPACE))
-                                                    (fetch (REGION BOTTOM) of 
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                           ))
-                                             PAGETOSKETCHFACTOR]
-                                                             (* ; 
-                                             "calculate the local parts for the interpress sketch.")
-          (SETQ SKETCHX (MAKE.LOCAL.SKETCH SKETCHX (CREATEREGION (TIMES PAGELEFTSPACE 
-                                                                        PAGETOSKETCHFACTOR)
-                                                          (TIMES PAGEBOTTOMSPACE PAGETOSKETCHFACTOR)
-                                                          (fetch (REGION WIDTH) of 
-                                                                                         SKETCHREGION
-                                                                 )
-                                                          (fetch (REGION HEIGHT) of 
-                                                                                         SKETCHREGION
-                                                                 ))
-                               PAGETOSKETCHFACTOR OPENIMAGESTREAM))
-          (DRAW.LOCAL.SKETCH SKETCHX OPENIMAGESTREAM (CREATEREGION PAGELEFTSPACE PAGEBOTTOMSPACE
-                                                            (fetch (REGION WIDTH) of 
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                                   )
-                                                            (fetch (REGION HEIGHT) of 
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                                   )))
-          (STATUSPRINT SKETCHW " done.")
-          (RETURN OPENIMAGESTREAM])
-
-(FIX-SKETCH
-  [LAMBDA NIL                                            (* ; "Edited  8-Nov-90 16:32 by jds")
-    (COND
-       ((BOUNDP 'ALL.SKETCHES)
-
-        (* ;; "sketch is loaded")
-
-        (for PATCHED-FN in '(NEW-SK-PICK-FONT NEW-SK-DECREASING-FONT-LIST 
-                                           NEW-SKETCHW-HARDCOPYFN) as ORIGINAL-FN
-           in '(SK.PICK.FONT SK.DECREASING.FONT.LIST SKETCHW.HARDCOPYFN)
-           do (MOVD PATCHED-FN ORIGINAL-FN NIL T))
-        (PROMPTPRINT "Sketch has been patched!")
-        T)
-       (T (PROMPTPRINT "Sketch doesn't seem to be loaded!")
-          (PROMPTPRINT "When you load sketch, make sure to call the function FIX-SKETCH!")
-          NIL])
-)
-
-(RPAQQ SKETCH-PATCHES ((NEW-SK-PICK-FONT . SK.PICK.FONT)
-                           (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST)
-                           (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN)))
-
-
-
-(* ;; "NOTE: to compile the following 2 functions you need FONT loaded prop and EXPORTS.ALL loaded."
-)
-
-(DEFINEQ
-
-(\BUILDSLUGCSINFO
-  [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE)            (* ; "Edited 14-Feb-89 16:46 by snow")
-
-(* ;;; "builds a csinfo which contains only the slug (black rectangle) character")
-
-    (SETQ SCALE (OR SCALE 1))
-    (PROG ((CSINFO (create CHARSETINFO
-                          CHARSETASCENT _ ASCENT
-                          CHARSETDESCENT _ DESCENT
-                          IMAGEWIDTHS _ (\CREATECSINFOELEMENT)))
-           WIDTHS OFFSETS BITMAP IMAGEWIDTHS)
-          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
-          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
-          (SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
-          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
-          [SELECTQ DEVICE
-              (INTERPRESS                                    (* ; 
-                                                           "don't need offsets in INTERPRESS fonts")
-                          NIL)
-              (PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS (
-                                                                                 \CREATECSINFOELEMENT
-                                                                                              )))
-                     (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
-                     [replace (CHARSETINFO CHARSETBITMAP) of CSINFO
-                        with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE))
-                                                     (ROUND (QUOTIENT (IPLUS ASCENT DESCENT)
-                                                                   SCALE]
-                     (BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE]
-          (RETURN CSINFO])
-
-(\CREATECHARSET
-  [LAMBDA (CHARSET FONT NOSLUG?)                         (* ; "Edited 14-Feb-89 16:29 by snow")
-
-    (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR")
-                                                             (* ; 
-  "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")
-    (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES))
-    (AND (IGREATERP CHARSET \MAXCHARSET)
-         (\ILLEGAL.ARG CHARSET))
-    (PROG (CSINFO CREATEFN)
-
-     (* ;; "For other charsets, create a font descriptor of info for that charset, and use it to fill things in.")
-
-          (if (OR (AND (IGEQ CHARSET 1)
-                           (ILEQ CHARSET 32))
-                      (AND (IGEQ CHARSET 127)
-                           (ILEQ CHARSET 160)))
-              then 
-
-                    (* ;; "this is an illegal NS character set (reserved for control codes) so just return a slug (unless NOSLUG?  is T)")
-
-                    [if NOSLUG?
-                        then (RETURN NIL)
-                      else (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR 
-                                                                                    FONTAVGCHARWIDTH)
-                                                                     of FONT)
-                                                   (FONTPROP FONT 'ASCENT)
-                                                   (FONTPROP FONT 'DESCENT)
-                                                   (FONTPROP FONT 'DEVICE)
-                                                   (FONTPROP FONT 'SCALE]
-            else [SETQ CREATEFN (COND
-                                       ((FMEMB (FONTPROP FONT 'DEVICE)
-                                               \DISPLAYSTREAMTYPES)
-                                        (FUNCTION \CREATECHARSET.DISPLAY))
-                                       (T (CADR (ASSOC 'CREATECHARSET
-                                                       (CDR (ASSOC (FONTPROP FONT 'DEVICE)
-                                                                   IMAGESTREAMTYPES]
-                  [if [NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC)
-                                                                   (LIST CHARSET FONT NOSLUG?]
-                      then                               (* ; 
-         "the create method returned NIL.  so if NOSLUG?  return NIL else build a slug charsetinfo")
-                            (RETURN (if NOSLUG?
-                                        then             (* ; 
-                                  "the caller just wants NIL back to signal that nothing was found")
-                                              NIL
-                                      else (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR
-                                                                                 FONTAVGCHARWIDTH)
-                                                                        of FONT)
-                                                      (FONTPROP FONT 'ASCENT)
-                                                      (FONTPROP FONT 'HEIGHT)
-                                                      (FONTPROP FONT 'DEVICE)
-                                                      (FONTPROP FONT 'SCALE]
-                  (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of
-                                                                                         FONT)
-                                                                    (fetch CHARSETASCENT
-                                                                       of CSINFO)))
-                  (replace \SFDescent of FONT with (IMAX (fetch \SFDescent
-                                                                        of FONT)
-                                                                     (ffetch CHARSETDESCENT
-                                                                        of CSINFO)))
-                  (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent
-                                                                        of FONT)
-                                                                     (ffetch \SFDescent
-                                                                        of FONT))) 
-                                                             (* ; 
-                              "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)")
-                 )
-          (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
-                         CHARSET CSINFO])
-)
-
-(ADDTOVAR POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA)
-                                          (TIMESROMAND . TIMESROMAN)
-                                          (COURIER . COURIER)
-                                          (GACHA . COURIER)
-                                          (CLASSIC . TIMESROMAN)
-                                          (MODERN . HELVETICA)
-                                          (CREAM . HELVETICA)
-                                          (TERMINAL . COURIER)
-                                          (LOGO . HELVETICA)
-                                          (MODERN . HELVETICA))
-
-(RPAQQ \KNOWN.SKETCH.FONTSIZES NIL)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)
-       POSTSCRIPT.FONT.CONVERSIONS)
-)
-
-
-
-(* ;; "finally actually do the patching of sketch.")
-
-
-(FIX-SKETCH)
-(PUTPROPS PS-PATCH COPYRIGHT ("ENVOS Corporation" 1989 1990))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (2086 16850 (ADD.KNOWN.SKETCH.FONT 2096 . 2973) (NEW-SK-PICK-FONT 2975 . 6357) (
-NEW-SK-DECREASING-FONT-LIST 6359 . 8183) (NEW-SKETCHW-HARDCOPYFN 8185 . 16115) (FIX-SKETCH 16117 . 
-16848)) (17182 23954 (\BUILDSLUGCSINFO 17192 . 19090) (\CREATECHARSET 19092 . 23952)))))
-STOP
diff --git a/obsolete/lispusers/PS-RS232 b/obsolete/lispusers/PS-RS232
deleted file mode 100644
index fdd7826d..00000000
--- a/obsolete/lispusers/PS-RS232
+++ /dev/null
@@ -1,76 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED " 2-Aug-89 13:35:49" {DSK}<LISPFILES>PS>PS-RS232.;1 2639   
-
-      changes to%:  (VARS PS-RS232COMS)
-                    (PROPS (PS-RS232 MAKEFILE-ENVIRONMENT)
-                           (PS-RS232 PRINTERTYPE)
-                           (PS-RS232 SPOOLFILE))
-                    (FNS PS-RS232-AFTERLOGOUT PS-RS232-INIT))
-
-
-(* "
-Copyright (c) 1989 by Beckman Instruments, Inc.  All rights reserved.
-")
-
-(PRETTYCOMPRINT PS-RS232COMS)
-
-(RPAQQ PS-RS232COMS ((FILES POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS)
-                                DLRS232C)
-                         (INITVARS (PS-RS232-BAUD 9600)
-                                (PS-RS232-DATABITS 8)
-                                (PS-RS232-PARITY 'NONE)
-                                (PS-RS232-STOPBITS 1)
-                                (PS-RS232-FLOWCONTROL 'XOnXOff))
-                         (FNS PS-RS232-AFTERLOGOUT PS-RS232-INIT)
-                         (ADDVARS (DEFAULTPRINTINGHOST PS-RS232)
-                                (AROUNDEXITFNS PS-RS232-AFTERLOGOUT))
-                         (P (PS-RS232-INIT))
-                         (PROP (MAKEFILE-ENVIRONMENT PRINTERTYPE SPOOLFILE)
-                               PS-RS232)))
-
-(FILESLOAD POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS)
-       DLRS232C)
-
-(RPAQ? PS-RS232-BAUD 9600)
-
-(RPAQ? PS-RS232-DATABITS 8)
-
-(RPAQ? PS-RS232-PARITY 'NONE)
-
-(RPAQ? PS-RS232-STOPBITS 1)
-
-(RPAQ? PS-RS232-FLOWCONTROL 'XOnXOff)
-(DEFINEQ
-
-(PS-RS232-AFTERLOGOUT
-  [LAMBDA (EVENT)
-    (if (EQ EVENT 'AFTERLOGOUT)
-        then (RS232C.INIT PS-RS232-BAUD PS-RS232-DATABITS PS-RS232-PARITY PS-RS232-STOPBITS 
-                        PS-RS232-FLOWCONTROL])
-
-(PS-RS232-INIT
-  [LAMBDA NIL
-    [PUTPROP 'PS-RS232 'SPOOLOPTIONS `((BaudRate ,PS-RS232-BAUD)
-                                       (BitsPerSerialChar ,PS-RS232-DATABITS)
-                                       (Parity ,PS-RS232-PARITY)
-                                       (NoOfStopBits ,PS-RS232-STOPBITS)
-                                       (FlowControl ,PS-RS232-FLOWCONTROL]
-    (PS-RS232-AFTERLOGOUT 'AFTERLOGOUT)                  (* ; "Fake it")
-    NIL])
-)
-
-(ADDTOVAR DEFAULTPRINTINGHOST PS-RS232)
-
-(ADDTOVAR AROUNDEXITFNS PS-RS232-AFTERLOGOUT)
-
-(PS-RS232-INIT)
-
-(PUTPROPS PS-RS232 MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
-
-(PUTPROPS PS-RS232 PRINTERTYPE POSTSCRIPT)
-
-(PUTPROPS PS-RS232 SPOOLFILE "{RS232}FOO.PS")
-(PUTPROPS PS-RS232 COPYRIGHT ("Beckman Instruments, Inc" 1989))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1528 2244 (PS-RS232-AFTERLOGOUT 1538 . 1761) (PS-RS232-INIT 1763 . 2242)))))
-STOP
diff --git a/obsolete/lispusers/PS-RS232.TEDIT b/obsolete/lispusers/PS-RS232.TEDIT
deleted file mode 100644
index dcc1d6ae..00000000
Binary files a/obsolete/lispusers/PS-RS232.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/PS-SKETCH-PATCH b/obsolete/lispusers/PS-SKETCH-PATCH
deleted file mode 100644
index 1b8155d7..00000000
--- a/obsolete/lispusers/PS-SKETCH-PATCH
+++ /dev/null
@@ -1,440 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP")
-(FILECREATED " 4-Aug-89 16:46:48" {DSK}<LISPFILES>LIBRARY>PS-SKETCH-PATCH.;1 25983  
-
-      changes to%:  (VARS PS-SKETCH-PATCHCOMS)
-                    (PROPS (PS-SKETCH-PATCH MAKEFILE-ENVIRONMENT))
-                    (FNS FIX-SKETCH ADD.KNOWN.SKETCH.FONT NEW-SK-DECREASING-FONT-LIST 
-                         NEW-SK-PICK-FONT NEW-SKETCHW-HARDCOPYFN \BUILDSLUGCSINFO \CREATECHARSET))
-
-
-(* "
-Copyright (c) 1989 by ENVOS Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT PS-SKETCH-PATCHCOMS)
-
-(RPAQQ PS-SKETCH-PATCHCOMS ((FILES (SYSLOAD FROM LISPUSERS)
-                                       SKETCH)
-                                (FNS FIX-SKETCH ADD.KNOWN.SKETCH.FONT NEW-SK-DECREASING-FONT-LIST 
-                                     NEW-SK-PICK-FONT NEW-SKETCHW-HARDCOPYFN)
-                                
-                                (* ;; 
-                          "NOTE: to compile the following 2 functions you need EXPORTS.ALL loaded.")
-
-                                (FNS \BUILDSLUGCSINFO \CREATECHARSET)
-                                [VARS (SKETCH-PATCHES '((NEW-SK-PICK-FONT . SK.PICK.FONT)
-                                                        (NEW-SK-DECREASING-FONT-LIST
-                                                                           . SK.DECREASING.FONT.LIST)
-                                                        (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN]
-                                (ADDVARS (POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA)
-                                                (TIMESROMAND . TIMESROMAN)
-                                                (COURIER . COURIER)
-                                                (GACHA . COURIER)
-                                                (CLASSIC . TIMESROMAN)
-                                                (MODERN . HELVETICA)
-                                                (CREAM . HELVETICA)
-                                                (TERMINAL . COURIER)
-                                                (LOGO . HELVETICA)
-                                                (MODERN . HELVETICA)))
-                                (VARS (\KNOWN.SKETCH.FONTSIZES))
-                                (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)
-                                       POSTSCRIPT.FONT.CONVERSIONS)
-                                
-                                (* ;; "finally actually do the patching of sketch.")
-
-                                (P (FIX-SKETCH))
-                                (PROP (MAKEFILE-ENVIRONMENT FILETYPE)
-                                      PS-SKETCH-PATCH)))
-
-(FILESLOAD (SYSLOAD FROM LISPUSERS)
-       SKETCH)
-(DEFINEQ
-
-(FIX-SKETCH
-  [LAMBDA NIL                                     (* ; "Edited  7-Jul-89 19:40 by Matt Heffron")
-    (COND
-       ((BOUNDP 'ALL.SKETCHES)
-
-        (* ;; "sketch is loaded")
-
-        (for X in SKETCH-PATCHES do (MOVD (CAR X)
-                                                      (CDR X)
-                                                      NIL T))
-        (PROMPTPRINT "Sketch has been patched!")
-        T)
-       (T (PROMPTPRINT "Sketch doesn't seem to be loaded!")
-          (PROMPTPRINT "When you load sketch, make sure to call the function FIX-SKETCH!")
-          NIL])
-
-(ADD.KNOWN.SKETCH.FONT
-  [LAMBDA (FAMILY WID DEVICE FONT)                       (* ; "Edited 21-Feb-89 15:06 by snow")
-
-    (* ;; "add to the globally cached font list")
-
-    (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES))
-    (LET ((CACHE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES))
-          (CACHED))
-         (COND
-            [(NULL CACHE)
-             (if \KNOWN.SKETCH.FONTSIZES
-                 then [NCONC1 \KNOWN.SKETCH.FONTSIZES (LIST FAMILY (LIST DEVICE (CONS WID FONT]
-               else (SETQ \KNOWN.SKETCH.FONTSIZES (LIST (LIST FAMILY (LIST DEVICE
-                                                                               (CONS WID FONT]
-            (T (COND
-                  ((SETQ CACHED (ASSOC DEVICE CACHE))
-                   (NCONC1 CACHED (CONS WID FONT)))
-                  (T (NCONC1 CACHE (CONS DEVICE (CONS WID FONT])
-
-(NEW-SK-DECREASING-FONT-LIST
-  [LAMBDA (FAMILY DEVICETYPE)                            (* ; "Edited 21-Feb-89 11:26 by snow")
-
-    (* ;; "returns a list of fonts of family FAMILY which work on device DEVICETYPE")
-
-    [COND
-       ((NULL FAMILY)
-        (SETQ FAMILY 'MODERN]
-
-    (* ;; "convert to families that exist on the known devices.")
-
-(* ;;; "NOTE: this is a very bad way to convert the family.  It HARDCODES in the conversions for PRESS and INTERPRESS  and does nothing for new device types.  I have added the conversion for POSTSCRIPT that does things a little cleaner, but it should really look at a property of the device (fontconversions or some such animal.)  --was 2/19/89")
-
-    (LET ((CONVERSION))
-         [COND
-            [(EQ DEVICETYPE 'PRESS)
-             (COND
-                ((EQ FAMILY 'MODERN)
-                 (SETQ FAMILY 'HELVETICA))
-                ((EQ FAMILY 'CLASSIC)
-                 (SETQ FAMILY 'TIMESROMAN))
-                ((EQ FAMILY 'TERMINAL)
-                 (SETQ FAMILY 'GACHA]
-            [(EQ DEVICETYPE 'INTERPRESS)
-             (COND
-                ((EQ FAMILY 'HELVETICA)
-                 (SETQ FAMILY 'MODERN))
-                ((EQ FAMILY 'TIMESROMAN)
-                 (SETQ FAMILY 'CLASSIC))
-                ((EQ FAMILY 'GACHA)
-                 (SETQ FAMILY 'TERMINAL]
-            ((EQ DEVICETYPE 'POSTSCRIPT)
-             (if (SETQ CONVERSION (ASSOC FAMILY POSTSCRIPT.FONT.CONVERSIONS))
-                 then 
-
-                       (* ;; 
-                  "convert the family here for postscript as well as the other well known devices.")
-
-                       (SETQ FAMILY (CDR CONVERSION]
-         (for FONT in (SK.GUESS.FONTSAVAILABLE FAMILY DEVICETYPE)
-            collect (FONTCOPY FONT 'DEVICE DEVICETYPE])
-
-(NEW-SK-PICK-FONT
-  [LAMBDA (WID STRING DEVICE FAMILY)                     (* ; "Edited 22-Feb-89 07:53 by snow")
-
-    (* ;; "returns the font in FAMILY that text should be printed in to have the text STRING fit into a region WID points wide")
-
-    (DECLARE (GLOBALVARS \KNOWN.SKETCH.FONTSIZES))
-    (PROG (LASTFONT LASTSIZE DISPLAYFONT SCALE CACHEDFONT)
-          (IF [SETQ CACHEDFONT (ASSOC WID (ASSOC DEVICE (ASSOC FAMILY \KNOWN.SKETCH.FONTSIZES]
-              THEN (RETURN (CDR CACHEDFONT)))
-          (RETURN (for FONT in (SK.DECREASING.FONT.LIST FAMILY DEVICE)
-                     when (NOT (GREATERP [SETQ LASTSIZE (COND
-                                                               ((SETQ SCALE (FONTPROP FONT
-                                                                                   'SCALE))
-
-                                                                (* ;; 
-                                                    "IF THERE IS A SCALE, YOU MUST SCALE THE FONT.")
-
-                                                                (QUOTIENT (STRINGWIDTH STRING FONT)
-                                                                       SCALE))
-                                                               ((SETQ DISPLAYFONT (FONTCOPY
-                                                                                   (SETQ LASTFONT 
-                                                                                    FONT)
-                                                                                   'DEVICE
-                                                                                   'DISPLAY
-                                                                                   'NOERROR T))
-                                                             (* ; "use display if it exists.")
-                                                                (STRINGWIDTH STRING DISPLAYFONT))
-                                                               (T 
-                                                             (* ; 
-                                       "in some cases, font exists for devices other than display.")
-                                                                  (QUOTIENT (STRINGWIDTH STRING FONT)
-                                                                         (FONTPROP FONT 'SCALE]
-                                          WID)) do       (* ; 
-       "return a font for the proper device even though the display fonts are used to pick a size.")
-                                                      (ADD.KNOWN.SKETCH.FONT FAMILY WID DEVICE
-                                                             (FONTCOPY FONT 'DEVICE DEVICE))
-                                                      (RETURN (FONTCOPY FONT 'DEVICE DEVICE))
-                     finally (RETURN (COND
-                                            ((OR (NULL LASTFONT)
-                                                 (GREATERP LASTSIZE (TIMES 1.5 WID)))
-                                             'SHADE)
-                                            (T               (* ; 
-                                                          "use the smallest if it isn't too large.")
-                                               (FONTCOPY LASTFONT 'DEVICE DEVICE])
-
-(NEW-SKETCHW-HARDCOPYFN
-  [LAMBDA (SKETCHW OPENIMAGESTREAM)               (* ; "Edited 27-Jul-89 17:52 by Matt Heffron")
-                                                             (* ; 
-                                                           "dumps the sketch onto OPENIMAGESTREAM.")
-                                                             (* ; 
-                                       "centers it within the DSPCLIPPINGREGION of OPENIMAGESTREAM")
-    (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW)))
-           (PAGEREGION (DSPCLIPPINGREGION NIL OPENIMAGESTREAM))
-           (SKETCHREGION (SKETCH.REGION.VIEWED SKETCHW))
-           (SCALE (VIEWER.SCALE SKETCHW))
-           SKETCHREGIONINPAGECOORDS PAGELEFTSPACE PAGEBOTTOMSPACE PAGETOSKETCHFACTOR SKETCHX)
-          (OR SKETCH (RETURN))
-          (SPAWN.MOUSE)
-
-     (* ;; "move the margins out of the way")
-
-          (DSPLEFTMARGIN (MIN 0 (fetch (REGION LEFT) of PAGEREGION))
-                 OPENIMAGESTREAM)
-          (DSPBOTTOMMARGIN (MIN 0 (fetch (REGION BOTTOM) of PAGEREGION))
-                 OPENIMAGESTREAM)
-          (DSPTOPMARGIN (MAX (ITIMES MAX.SMALLP MAX.SMALLP)
-                             (fetch (REGION TOP) of PAGEREGION))
-                 OPENIMAGESTREAM)                            (* ; 
-                                                           "MAX.SMALLP^2 ought to be big enough...")
-          (DSPRIGHTMARGIN (MAX (ITIMES MAX.SMALLP MAX.SMALLP)
-                               (fetch (REGION RIGHT) of PAGEREGION))
-                 OPENIMAGESTREAM)
-
-     (* ;; "PAGETOSKETCHFACTOR is the factor to multiply the page coordinates by to get into sketch coordinates.")
-
-          (STATUSPRINT SKETCHW "Hardcopying ...")
-          [STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS (APPEND (LIST 'DOCUMENT.NAME (OR (SKETCH.TITLE
-                                                                                      SKETCHW)
-                                                                                     "A Sketch"))
-                                                           (STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS]
-          (SETQ PAGETOSKETCHFACTOR (FQUOTIENT SCALE (DSPSCALE NIL OPENIMAGESTREAM)))
-          (SETQ SKETCHREGIONINPAGECOORDS (SCALE.REGION.OUT SKETCHREGION PAGETOSKETCHFACTOR))
-          (COND
-             ((AND (NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM)
-                            'PRESS))
-                   (NOT (EQ (FETCH (IMAGEOPS IMROTATE) OF (FETCH (STREAM IMAGEOPS)
-                                                                     OF OPENIMAGESTREAM))
-                            'NILL))
-                   (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS)
-                          (fetch WIDTH of PAGEREGION))
-                   (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS)
-                          (fetch HEIGHT of SKETCHREGIONINPAGECOORDS)))
-
-              (* ;; "we have a  stream that supports rotation, use it!")
-
-              (DSPROTATE 90 OPENIMAGESTREAM)
-              (COND
-                 ((NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM)
-                           'POSTSCRIPT))
-
-                  (* ;; "Since PostScript's DSPROTATE does the translate also..., dont't do it here. --HACK! HACK! HACK! --Matt.")
-
-                  (DSPTRANSLATE 0 (MINUS (FETCH (REGION HEIGHT) OF PAGEREGION))
-                         OPENIMAGESTREAM)))
-              (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION))
-                     OPENIMAGESTREAM)
-
-              (* ;; "(ROTATE.IP OPENIMAGESTREAM 90) (CONCATT.IP OPENIMAGESTREAM) (TRANSLATE.IP OPENIMAGESTREAM 0 -21590) (CONCATT.IP OPENIMAGESTREAM) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM)")
-
-              (* ;; "this was an incredibly bogus hack to make INTERPRESS only streams rotate the sketch image if they were too big.  Now it tries to do it on any stream that has a dsprotate function.")
-
-              ))
-          (SETQ PAGELEFTSPACE (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION)
-                                               (fetch (REGION WIDTH) of 
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                      ))
-                                     2))
-          (SETQ PAGEBOTTOMSPACE (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION)
-                                                 (fetch (REGION HEIGHT) of 
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                        ))
-                                       2))
-
-     (* ;; "translate the sketch so that the lower left corner of the sketch region is at the lower left corner of the image on the page.")
-
-          [SETQ SKETCHX (TRANSLATE.SKETCH SKETCH (MINUS (TIMES (DIFFERENCE
-                                                                (SETQ PAGELEFTSPACE
-                                                                 (PLUS (fetch (REGION LEFT)
-                                                                          of PAGEREGION)
-                                                                       PAGELEFTSPACE))
-                                                                (fetch (REGION LEFT) of
-                                                                                         
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                                       ))
-                                                               PAGETOSKETCHFACTOR))
-                               (MINUS (TIMES (DIFFERENCE (SETQ PAGEBOTTOMSPACE
-                                                          (PLUS (fetch (REGION BOTTOM)
-                                                                   of PAGEREGION)
-                                                                PAGEBOTTOMSPACE))
-                                                    (fetch (REGION BOTTOM) of 
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                           ))
-                                             PAGETOSKETCHFACTOR]
-                                                             (* ; 
-                                             "calculate the local parts for the interpress sketch.")
-          (SETQ SKETCHX (MAKE.LOCAL.SKETCH SKETCHX (CREATEREGION (TIMES PAGELEFTSPACE 
-                                                                        PAGETOSKETCHFACTOR)
-                                                          (TIMES PAGEBOTTOMSPACE PAGETOSKETCHFACTOR)
-                                                          (fetch (REGION WIDTH) of 
-                                                                                         SKETCHREGION
-                                                                 )
-                                                          (fetch (REGION HEIGHT) of 
-                                                                                         SKETCHREGION
-                                                                 ))
-                               PAGETOSKETCHFACTOR OPENIMAGESTREAM))
-          (DRAW.LOCAL.SKETCH SKETCHX OPENIMAGESTREAM (CREATEREGION PAGELEFTSPACE PAGEBOTTOMSPACE
-                                                            (fetch (REGION WIDTH) of 
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                                   )
-                                                            (fetch (REGION HEIGHT) of 
-                                                                             SKETCHREGIONINPAGECOORDS
-                                                                   )))
-          (STATUSPRINT SKETCHW " done.")
-          (RETURN OPENIMAGESTREAM])
-)
-
-
-
-(* ;; "NOTE: to compile the following 2 functions you need EXPORTS.ALL loaded.")
-
-(DEFINEQ
-
-(\BUILDSLUGCSINFO
-  [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE)            (* ; "Edited 14-Feb-89 16:46 by snow")
-
-(* ;;; "builds a csinfo which contains only the slug (black rectangle) character")
-
-    (SETQ SCALE (OR SCALE 1))
-    (PROG ((CSINFO (create CHARSETINFO
-                          CHARSETASCENT _ ASCENT
-                          CHARSETDESCENT _ DESCENT
-                          IMAGEWIDTHS _ (\CREATECSINFOELEMENT)))
-           WIDTHS OFFSETS BITMAP IMAGEWIDTHS)
-          (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
-          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
-          (SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
-          (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH))
-          [SELECTQ DEVICE
-              (INTERPRESS                                    (* ; 
-                                                           "don't need offsets in INTERPRESS fonts")
-                          NIL)
-              (PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS (
-                                                                                 \CREATECSINFOELEMENT
-                                                                                              )))
-                     (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0))
-                     [replace (CHARSETINFO CHARSETBITMAP) of CSINFO
-                        with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE))
-                                                     (ROUND (QUOTIENT (IPLUS ASCENT DESCENT)
-                                                                   SCALE]
-                     (BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE]
-          (RETURN CSINFO])
-
-(\CREATECHARSET
-  [LAMBDA (CHARSET FONT NOSLUG?)                         (* ; "Edited 14-Feb-89 16:29 by snow")
-
-    (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR")
-                                                             (* ; 
-  "NOSLUG?  means don't create an empty (slug) csinfo if the charset is not found, just return NIL")
-    (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES))
-    (AND (IGREATERP CHARSET \MAXCHARSET)
-         (\ILLEGAL.ARG CHARSET))
-    (PROG (CSINFO CREATEFN)
-
-     (* ;; "For other charsets, create a font descriptor of info for that charset, and use it to fill things in.")
-
-          (if (OR (AND (IGEQ CHARSET 1)
-                           (ILEQ CHARSET 32))
-                      (AND (IGEQ CHARSET 127)
-                           (ILEQ CHARSET 160)))
-              then 
-
-                    (* ;; "this is an illegal NS character set (reserved for control codes) so just return a slug (unless NOSLUG?  is T)")
-
-                    [if NOSLUG?
-                        then (RETURN NIL)
-                      else (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR 
-                                                                                    FONTAVGCHARWIDTH)
-                                                                     of FONT)
-                                                   (FONTPROP FONT 'ASCENT)
-                                                   (FONTPROP FONT 'DESCENT)
-                                                   (FONTPROP FONT 'DEVICE)
-                                                   (FONTPROP FONT 'SCALE]
-            else [SETQ CREATEFN (COND
-                                       ((FMEMB (FONTPROP FONT 'DEVICE)
-                                               \DISPLAYSTREAMTYPES)
-                                        (FUNCTION \CREATECHARSET.DISPLAY))
-                                       (T (CADR (ASSOC 'CREATECHARSET
-                                                       (CDR (ASSOC (FONTPROP FONT 'DEVICE)
-                                                                   IMAGESTREAMTYPES]
-                  [if [NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC)
-                                                                   (LIST CHARSET FONT NOSLUG?]
-                      then                               (* ; 
-         "the create method returned NIL.  so if NOSLUG?  return NIL else build a slug charsetinfo")
-                            (RETURN (if NOSLUG?
-                                        then             (* ; 
-                                  "the caller just wants NIL back to signal that nothing was found")
-                                              NIL
-                                      else (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR
-                                                                                 FONTAVGCHARWIDTH)
-                                                                        of FONT)
-                                                      (FONTPROP FONT 'ASCENT)
-                                                      (FONTPROP FONT 'HEIGHT)
-                                                      (FONTPROP FONT 'DEVICE)
-                                                      (FONTPROP FONT 'SCALE]
-                  (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of
-                                                                                         FONT)
-                                                                    (fetch CHARSETASCENT
-                                                                       of CSINFO)))
-                  (replace \SFDescent of FONT with (IMAX (fetch \SFDescent
-                                                                        of FONT)
-                                                                     (ffetch CHARSETDESCENT
-                                                                        of CSINFO)))
-                  (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent
-                                                                        of FONT)
-                                                                     (ffetch \SFDescent
-                                                                        of FONT))) 
-                                                             (* ; 
-                              "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)")
-                 )
-          (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT)
-                         CHARSET CSINFO])
-)
-
-(RPAQQ SKETCH-PATCHES ((NEW-SK-PICK-FONT . SK.PICK.FONT)
-                           (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST)
-                           (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN)))
-
-(ADDTOVAR POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA)
-                                          (TIMESROMAND . TIMESROMAN)
-                                          (COURIER . COURIER)
-                                          (GACHA . COURIER)
-                                          (CLASSIC . TIMESROMAN)
-                                          (MODERN . HELVETICA)
-                                          (CREAM . HELVETICA)
-                                          (TERMINAL . COURIER)
-                                          (LOGO . HELVETICA)
-                                          (MODERN . HELVETICA))
-
-(RPAQQ \KNOWN.SKETCH.FONTSIZES NIL)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS (\KNOWN.SKETCH.FONTSIZES)
-       POSTSCRIPT.FONT.CONVERSIONS)
-)
-
-
-
-(* ;; "finally actually do the patching of sketch.")
-
-
-(FIX-SKETCH)
-
-(PUTPROPS PS-SKETCH-PATCH MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP"))
-
-(PUTPROPS PS-SKETCH-PATCH FILETYPE :TCOMPL)
-(PUTPROPS PS-SKETCH-PATCH COPYRIGHT ("ENVOS Corporation" 1989))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (2758 17798 (FIX-SKETCH 2768 . 3382) (ADD.KNOWN.SKETCH.FONT 3384 . 4261) (
-NEW-SK-DECREASING-FONT-LIST 4263 . 6087) (NEW-SK-PICK-FONT 6089 . 9471) (NEW-SKETCHW-HARDCOPYFN 9473
- . 17796)) (17888 24660 (\BUILDSLUGCSINFO 17898 . 19796) (\CREATECHARSET 19798 . 24658)))))
-STOP
diff --git a/obsolete/lispusers/PS-SKETCH-PATCH.LCOM b/obsolete/lispusers/PS-SKETCH-PATCH.LCOM
deleted file mode 100644
index 7e130c6a..00000000
Binary files a/obsolete/lispusers/PS-SKETCH-PATCH.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/PS-SKETCH-PATCH.TEDIT b/obsolete/lispusers/PS-SKETCH-PATCH.TEDIT
deleted file mode 100644
index 2a0f2937..00000000
Binary files a/obsolete/lispusers/PS-SKETCH-PATCH.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/PS-patch.tedit b/obsolete/lispusers/PS-patch.tedit
deleted file mode 100644
index e5e51519..00000000
Binary files a/obsolete/lispusers/PS-patch.tedit and /dev/null differ
diff --git a/obsolete/lispusers/PSCFONT-FIX-FILENAME b/obsolete/lispusers/PSCFONT-FIX-FILENAME
deleted file mode 100644
index 50368244..00000000
--- a/obsolete/lispusers/PSCFONT-FIX-FILENAME
+++ /dev/null
@@ -1,84 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-(FILECREATED "11-May-87 16:33:49" {DSK}<LISPFILES>PS>PSCFONT-FIX-FILENAME.\;1 5877   
-
-      |changes| |to:|  (VARS PSCFONT-FIX-FILENAMECOMS)
-                       (FNS PSCFONT-FILENAME-FIX)
-                       (FILEVARS PSCFONT-FIX-FILENAMECOMS))
-
-
-; Copyright (c) 1987 by Beckman Instruments, Inc.  All rights reserved.
-
-(PRETTYCOMPRINT PSCFONT-FIX-FILENAMECOMS)
-
-(RPAQQ PSCFONT-FIX-FILENAMECOMS ((FNS PSCFONT-FILENAME-FIX)
-                                 (VARS POSTSCRIPT-FONT-FILENAME-FIXLIST)))
-(DEFINEQ
-
-(PSCFONT-FILENAME-FIX
-  (LAMBDA NIL                                        (* \; "Edited 11-May-87 15:34 by Matt Heffron")
-
-    (FOR D IN POSTSCRIPTFONTDIRECTORIES
-       DO (FOR F IN POSTSCRIPT-FONT-FILENAME-FIXLIST
-             DO (LET (FN)
-                     (CL:WHEN (SETQ FN (INFILEP (CONCAT D (CAR F))))
-                            (PRINTOUT T FN " => " (RENAMEFILE FN (CONCAT D (\\FONTFILENAME
-                                                                            (CADR F)
-                                                                            1
-                                                                            (CADDR F)
-                                                                            '.PSCFONT)))
-                                   T)))))))
-)
-
-(RPAQQ POSTSCRIPT-FONT-FILENAME-FIXLIST (("AVANTGARDE-BOOK1" AVANTGARDE-BOOK (MEDIUM REGULAR REGULAR)
-                                                )
-                                         ("AVANTGARDE-BOOK1I" AVANTGARDE-BOOK (MEDIUM ITALIC REGULAR)
-                                                )
-                                         ("AVANTGARDE-DEMI1" AVANTGARDE-DEMI (MEDIUM REGULAR REGULAR)
-                                                )
-                                         ("AVANTGARDE-DEMI1I" AVANTGARDE-DEMI (MEDIUM ITALIC REGULAR)
-                                                )
-                                         ("BOOKMAN-DEMI1" BOOKMAN-DEMI (MEDIUM REGULAR REGULAR))
-                                         ("BOOKMAN-DEMI1I" BOOKMAN-DEMI (MEDIUM ITALIC REGULAR))
-                                         ("BOOKMAN-LIGHT1" BOOKMAN-LIGHT (MEDIUM REGULAR REGULAR))
-                                         ("BOOKMAN-LIGHT1I" BOOKMAN-LIGHT (MEDIUM ITALIC REGULAR))
-                                         ("COURIER1" COURIER (MEDIUM REGULAR REGULAR))
-                                         ("COURIER1B" COURIER (BOLD REGULAR REGULAR))
-                                         ("COURIER1BI" COURIER (BOLD ITALIC REGULAR))
-                                         ("COURIER1I" COURIER (MEDIUM ITALIC REGULAR))
-                                         ("HELVETICA-NARROW1" HELVETICA-NARROW (MEDIUM REGULAR 
-                                                                                      REGULAR))
-                                         ("HELVETICA-NARROW1B" HELVETICA-NARROW (BOLD REGULAR REGULAR
-                                                                                      ))
-                                         ("HELVETICA-NARROW1BI" HELVETICA-NARROW (BOLD ITALIC REGULAR
-                                                                                       ))
-                                         ("HELVETICA-NARROW1I" HELVETICA-NARROW (MEDIUM ITALIC 
-                                                                                       REGULAR))
-                                         ("HELVETICA1" HELVETICA (MEDIUM REGULAR REGULAR))
-                                         ("HELVETICA1B" HELVETICA (BOLD REGULAR REGULAR))
-                                         ("HELVETICA1BI" HELVETICA (BOLD ITALIC REGULAR))
-                                         ("HELVETICA1I" HELVETICA (MEDIUM ITALIC REGULAR))
-                                         ("NEWCENTURYSCHLBK1" NEWCENTURYSCHLBK (MEDIUM REGULAR 
-                                                                                      REGULAR))
-                                         ("NEWCENTURYSCHLBK1B" NEWCENTURYSCHLBK (BOLD REGULAR REGULAR
-                                                                                      ))
-                                         ("NEWCENTURYSCHLBK1BI" NEWCENTURYSCHLBK (BOLD ITALIC REGULAR
-                                                                                       ))
-                                         ("NEWCENTURYSCHLBK1I" NEWCENTURYSCHLBK (MEDIUM ITALIC 
-                                                                                       REGULAR))
-                                         ("PALATINO1" PALATINO (MEDIUM REGULAR REGULAR))
-                                         ("PALATINO1B" PALATINO (BOLD REGULAR REGULAR))
-                                         ("PALATINO1BI" PALATINO (BOLD ITALIC REGULAR))
-                                         ("PALATINO1I" PALATINO (MEDIUM ITALIC REGULAR))
-                                         ("SYMBOL1" SYMBOL (MEDIUM REGULAR REGULAR))
-                                         ("TIMES1" TIMES (MEDIUM REGULAR REGULAR))
-                                         ("TIMES1B" TIMES (BOLD REGULAR REGULAR))
-                                         ("TIMES1BI" TIMES (BOLD ITALIC REGULAR))
-                                         ("TIMES1I" TIMES (MEDIUM ITALIC REGULAR))
-                                         ("ZAPFCHANCERY-MEDIUM1I" ZAPFCHANCERY-MEDIUM
-                                                (MEDIUM REGULAR REGULAR))
-                                         ("ZAPFCHANCERY1I" ZAPFCHANCERY (MEDIUM ITALIC REGULAR))
-                                         ("ZAPFDINGBATS1" ZAPFDINGBATS (MEDIUM REGULAR REGULAR))))
-(PUTPROPS PSCFONT-FIX-FILENAME COPYRIGHT ("Beckman Instruments, Inc" 1987))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL (572 1404 (PSCFONT-FILENAME-FIX 582 . 1402)))))
-STOP
diff --git a/obsolete/lispusers/READDISPLAYFONT b/obsolete/lispusers/READDISPLAYFONT
deleted file mode 100644
index d2f895b1..00000000
--- a/obsolete/lispusers/READDISPLAYFONT
+++ /dev/null
@@ -1,110 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED "15-Jul-88 16:33:54" |{MCS:MCS:STANFORD}<LANE>READDISPLAYFONT.;2| 4644   
-
-      changes to%:  (VARS READDISPLAYFONTCOMS)
-
-      previous date%: " 3-May-88 10:33:05" |{MCS:MCS:STANFORD}<LANE>READDISPLAYFONT.;1|)
-
-
-(* "
-Copyright (c) 1988 by Stanford University.  All rights reserved.
-")
-
-(PRETTYCOMPRINT READDISPLAYFONTCOMS)
-
-(RPAQQ READDISPLAYFONTCOMS ((* Redefinition of DISPLAY font functions to facilitate addition of 
-                                   new font types)
-                                (FNS \READDISPLAYFONTFILE FONTFILEFORMAT)
-                                (ADDVARS (DISPLAYFONTTYPES (AC \READACFONTFILE)
-                                                (STRIKE \READSTRIKEFONTFILE)))
-                                (GLOBALVARS DISPLAYFONTTYPES)
-                                (DECLARE%: DONTCOPY (RECORDS DISPLAYFONTTYPE))))
-
-
-
-(* Redefinition of DISPLAY font functions to facilitate addition of new font types)
-
-(DEFINEQ
-
-(\READDISPLAYFONTFILE
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)         (* ; "Edited  3-May-88 10:31 by cdl")
-
-    (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
-    (bind FONTFILE FONTTYPE CSINFO STREAM for EXTENSION inside DISPLAYFONTEXTENSIONS
-       when (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET 
-                                  DISPLAYFONTDIRECTORIES (LIST EXTENSION)))
-       do (* Use CLOSE? to avoid redundant CLOSEF in AC font file case)
-          (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTREAM FONTFILE 'INPUT]
-                 (if (SETQ FONTTYPE (ASSOC (FONTFILEFORMAT STREAM T)
-                                           DISPLAYFONTTYPES))
-                     then (SETQ CSINFO (with DISPLAYFONTTYPE FONTTYPE (APPLY* READFN STREAM FAMILY 
-                                                                             SIZE FACE)))
-                   else (SHOULDNT)))
-          (RETURN CSINFO])
-
-(FONTFILEFORMAT
-  [LAMBDA (STREAM LEAVEOPEN)                                 (* ; "Edited  3-May-88 10:26 by cdl")
-                                                             (* Returns the font format of STREAM)
-    [OR (OPENP STREAM 'INPUT)
-        (SETQ STREAM (OPENSTREAM STREAM 'INPUT]
-    (PROG1 (OR (LET [(EXTENSION (FILENAMEFIELD (FULLNAME STREAM)
-                                       'EXTENSION]
-          
-          (* AC and Strike files count on side effects of this function so we have to 
-          handle them separately for now)
-
-                    (if (AND [NOT (FMEMB EXTENSION '(AC STRIKE]
-                             (ASSOC EXTENSION DISPLAYFONTTYPES))
-                        then EXTENSION))
-               (SELECTC (\WIN STREAM)
-                   ((LIST (LLSH 1 15)
-                          (LOGOR (LLSH 1 15)
-                                 (LLSH 1 13))) 
-          
-          (* If high bit of type is on, then must be strike.
-          If 2nd bit is on, must be strike-index, and we punt.
-          We don't care about the 3rd bit)
-
-                        
-          
-          (* first word has high bits (onebit index fixed)%.
-          Onebit means "new-style font" %, index is 0 for simple strike, 1 for index, and 
-          fixed is if all chars have max width. Lisp doesn't care about "fixed")
-
-                        'STRIKE)
-                   ((LOGOR (LLSH 16 8)
-                           12) 
-          
-          (* This is the length of a standard index header.
-          Other files could also have this value, but it's a pretty good discriminator)
-
-                        
-          
-          (* Skip to byte 25; do it with BINS so works for non-randaccessp devices.
-          This skips the standard name header, then look for type 3 in the following 
-          header)
-
-                        (FRPTQ 22 (\BIN STREAM))             (* (SETFILEPTR STREAM 25))
-                        (AND (EQ 3 (LRSH (\BIN STREAM)
-                                         4))
-                             'AC))
-                   NIL))
-           (OR LEAVEOPEN (CLOSEF STREAM])
-)
-
-(ADDTOVAR DISPLAYFONTTYPES (AC \READACFONTFILE)
-                               (STRIKE \READSTRIKEFONTFILE))
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS DISPLAYFONTTYPES)
-)
-(DECLARE%: DONTCOPY 
-(DECLARE%: EVAL@COMPILE
-
-(RECORD DISPLAYFONTTYPE (TYPE READFN))
-)
-)
-(PUTPROPS READDISPLAYFONT COPYRIGHT ("Stanford University" 1988))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1028 4280 (\READDISPLAYFONTFILE 1038 . 2081) (FONTFILEFORMAT 2083 . 4278)))))
-STOP
diff --git a/obsolete/lispusers/READDISPLAYFONT.LCOM b/obsolete/lispusers/READDISPLAYFONT.LCOM
deleted file mode 100644
index 89e0d0d3..00000000
Binary files a/obsolete/lispusers/READDISPLAYFONT.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/READDISPLAYFONT.TEDIT b/obsolete/lispusers/READDISPLAYFONT.TEDIT
deleted file mode 100644
index 2b774494..00000000
Binary files a/obsolete/lispusers/READDISPLAYFONT.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/REGISTER-MACHINE b/obsolete/lispusers/REGISTER-MACHINE
deleted file mode 100644
index 0604b026..00000000
--- a/obsolete/lispusers/REGISTER-MACHINE
+++ /dev/null
@@ -1,101 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
-(FILECREATED " 1-Feb-2022 16:51:58" 
-{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGISTER-MACHINE.;2 4416   
-
-      :CHANGES-TO (FNS Requst-NS-Registry)
-
-      :PREVIOUS-DATE " 8-Jan-88 18:02:00" 
-{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGISTER-MACHINE.;1)
-
-
-(* ; "
-Copyright (c) 1986-1988 by Xerox Corporation.
-")
-
-(PRETTYCOMPRINT REGISTER-MACHINECOMS)
-
-(RPAQQ REGISTER-MACHINECOMS
-       (
-
-(* ;;; "Add a Lafite form that will request that the current machine be registered with the local Clearinghouse")
-
-        (FNS Requst-NS-Registry AmIRegistered)
-        (ADDVARS (LAFITESPECIALFORMS ("Clearinghouse registry request" 'Requst-NS-Registry 
-           "Make a form to request that the current machine be registered on the local Clearinghouse"
-                                            )))
-        (P (UNMARKASCHANGED 'LAFITESPECIALFORMS 'VARS)
-           (SETQ LAFITEFORMSMENU NIL))))
-
-
-
-(* ;;; 
-"Add a Lafite form that will request that the current machine be registered with the local Clearinghouse"
-)
-
-(DEFINEQ
-
-(Requst-NS-Registry
-  [LAMBDA NIL                                                (* ; "Edited  1-Feb-2022 16:46 by rmk")
-                                                          (* ; "Edited  8-Jan-88 18:00 by Masinter")
-
-(* ;;; 
-"Format a nice note requsting that the current machine be registered on the local Clearinghouse.")
-
-    (LET ((*STANDARD-OUTPUT* (OPENTEXTSTREAM NIL NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT)))
-          (netNumber (fetch NSNET \MY.NSADDRESS))
-          (me (FULLUSERNAME))
-          (CURRENTLY (AmIRegistered)))
-         (CL:FORMAT T "To: UserAdministration~A~A~&" (SELECTQ (LAFITEMODE)
-                                                         (GV ".")
-                                                         ":")
-                CH.DEFAULT.DOMAIN)
-         (CL:FORMAT T "Cc: ~A~%%Reply-to: ~A~%%~%%" me me)
-         (if CURRENTLY
-             then (CL:FORMAT T ">>This machine is already registered as ~A <<~%%~%%" CURRENTLY))
-         (printout NIL "Primary User:  " me T T)
-         (printout NIL "Name:  %"" (OR (ETHERHOSTNAME)
-                                       ">>Desired machine name<<")
-                "%"" T)
-         (CL:FORMAT T "Network Number: ~5,,'-:D~&" (fetch NSNET \MY.NSADDRESS))
-         (CL:FORMAT T "Processor Number: ~5,,'-:D~&" (+ (LSH (fetch NSHNM0 \MY.NSADDRESS)
-                                                             32)
-                                                        (LSH (fetch NSHNM1 \MY.NSADDRESS)
-                                                             16)
-                                                        (fetch NSHNM2 \MY.NSADDRESS)))
-         (printout NIL "Description:  A " (L-CASE (MACHINETYPE)
-                                                 T)
-                " (typically running Lisp)" T)
-         (printout NIL T T "Thank you." T T "-- " FIRSTNAME T)
-         (LET ((field (TEDIT.FIND *STANDARD-OUTPUT* ">>*<<" 1 NIL T)))
-              (if field
-                  then (TEDIT.SETSEL *STANDARD-OUTPUT* (CAR field)
-                              (ADD1 (DIFFERENCE (CADR field)
-                                           (CAR field)))
-                              'LEFT T)))
-         *STANDARD-OUTPUT*])
-
-(AmIRegistered
-  [LAMBDA NIL                                             (* ; "Edited  8-Jan-88 18:00 by Masinter")
-
-    (CL:FLET [(OK (NAMES)
-                  (for wsn in (CH.LIST.OBJECTS NAMES 'WORKSTATION) when (EQUALALL \MY.NSADDRESS
-                                                                               (LOOKUP.NS.SERVER
-                                                                                wsn))
-                     do (RETURN (LIST wsn]
-           (OR (AND (ETHERHOSTNAME)
-                    (OK (ETHERHOSTNAME)))
-               (OK "*"])
-)
-
-(ADDTOVAR LAFITESPECIALFORMS ("Clearinghouse registry request" 'Requst-NS-Registry 
-           "Make a form to request that the current machine be registered on the local Clearinghouse"
-                                    ))
-
-(UNMARKASCHANGED 'LAFITESPECIALFORMS 'VARS)
-
-(SETQ LAFITEFORMSMENU NIL)
-(PUTPROPS REGISTER-MACHINE COPYRIGHT ("Xerox Corporation" 1986 1987 1988))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1131 4015 (Requst-NS-Registry 1141 . 3416) (AmIRegistered 3418 . 4013)))))
-STOP
diff --git a/obsolete/lispusers/SINGLEFILEINDEX b/obsolete/lispusers/SINGLEFILEINDEX
deleted file mode 100644
index 98ff537c..00000000
--- a/obsolete/lispusers/SINGLEFILEINDEX
+++ /dev/null
@@ -1,1057 +0,0 @@
-(FILECREATED "15-Apr-88 09:50:23" {ERINYES}<LISPUSERS>KOTO>SINGLEFILEINDEX.;2 41909  
-
-      changes to:  (FNS \SFI.CENTERPRINT)
-
-      previous date: "31-Mar-86 17:15:30" {ERINYES}<LISP>KOTO>LISPUSERS>SINGLEFILEINDEX.;1)
-
-
-(* Copyright (c) 1984, 1985, 1986, 1988 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT SINGLEFILEINDEXCOMS)
-
-(RPAQQ SINGLEFILEINDEXCOMS [(COMS (* * 
-"Created by Christopher Tong and JonL White, February 1984.  Heavily revised by Bill van Melle, March 1986."
-				       )
-				    (* SINGLEFILEINDEX)
-				    (FNS SINGLEFILEINDEX \SFI.Q1UP \FILELISTING SINGLEFILEINDEX2 
-					 SINGLEFILEINDEX1 \SFI.AnalyzeLine \SFI.FLUSHFONTCHANGE 
-					 PrintFnDef INDEXCOPYBYTES INDEXNEWLINE INDEXNEWPAGE 
-					 \SFI.SORTINDEX UALPHORDERCAR \SFI.FILTER.INDEX)
-				    (FNS PrintFileTitle \SFI.PRINT.INDEX PrintIndex 
-					 \SFI.PrintIndexFactors PrintRelativeFunctionIndex 
-					 \SFI.CENTERPRINT PRINTDOTS \SFI.LISTINGHEADER \SFI.BreakLine)
-				    )
-	(INITVARS (PRINTERDEVICEFILENAME (QUOTE {LPT}))
-		  (RELATIVEINDEXFLG)
-		  (SINGLEFILEINDEX.TWOSIDED)
-		  (SINGLEFILEINDEX.DONTSPAWN)
-		  (\SFI.PROCESS.COMMANDS)
-		  (\SFI.PROCESSLOCK (CREATE.MONITORLOCK "SINGLEFILEINDEX"))
-		  (\SFI.PROCESS)
-		  (ERRORMESSAGESTREAM T))
-	(ADDVARS (SINGLEFILEINDEX.TYPES (MACRO DEFMACRO)
-					(VAR (RPAQ RPAQ? RPAQQ ADDTOVAR)
-					     TestForVar T)
-					(VAR READVARS TestForUglyVars)
-					(BITMAP RPAQ TestForBitmap)
-					(CONSTANTS CONSTANTS TestForConstants)
-					(RECORD (eval CLISPRECORDTYPES))
-					(PROPERTY PUTPROPS TestForProp)
-					(COURIERPROGRAM COURIERPROGRAM)
-					(TEMPLATE SETTEMPLATE TestForQuotedType)
-					(I.S.OPR I.S.OPR TestForQuotedType)
-					(RESOURCES PUTDEF TestForResource)
-					(ADVICE READVISE))
-		 (SINGLEFILEINDEX.PROPERTIES (COPYRIGHT)
-					     (READVICE ADVICE))
-		 (SINGLEFILEINDEX.FILTERS (VAR . CONSTANTS)
-					  (VAR . BITMAP)))
-	(COMS (* "Functions that find types")
-	      (FNS TestForType TestForQuotedType TestForVar TestForBitmap TestForProp TestForResource 
-		   TestForUglyVars TestForGenericDefinition TestForConstants SFI.WHOLE.EXPRESSION 
-		   SFI.LOOKUP.NAME))
-	(DECLARE: EVAL@COMPILE DONTCOPY (MACROS .ERRORSTREAM.)
-		  (RECORDS SFITYPE)
-		  (FILES (IMPORT)
-			 FILEIO)
-		  (GLOBALVARS DEFAULTFONT NOTLISTEDFILES)
-		  (GLOBALVARS FILERDTBL RELATIVEINDEXFLG)
-		  (GLOBALVARS SINGLEFILEINDEX.DONTSPAWN \SFI.PROCESS.COMMANDS \SFI.PROCESSLOCK 
-			      \SFI.PROCESS SINGLEFILEINDEX.TWOSIDED SINGLEFILEINDEX.TYPES 
-			      SINGLEFILEINDEX.PROPERTIES SINGLEFILEINDEX.FILTERS FILELINELENGTH 
-			      MACROPROPS PRINTERDEVICEFILENAME)
-		  DONTEVAL@LOAD
-		  (SPECVARS . T))
-	(COMS (FNS SFI.LISTFILES1)
-	      (DECLARE: DOCOPY DONTEVAL@LOAD (P (MOVD? (QUOTE LISTFILES1)
-						       (QUOTE OLDLISTFILES1))
-						(/MOVD (QUOTE SFI.LISTFILES1)
-						       (QUOTE LISTFILES1)))
-			(INITVARS (LINESPERPAGE 65])
-(* * 
-"Created by Christopher Tong and JonL White, February 1984.  Heavily revised by Bill van Melle, March 1986."
-)
-
-
-
-
-(* SINGLEFILEINDEX)
-
-(DEFINEQ
-
-(SINGLEFILEINDEX
-  [LAMBDA (INF OUTF mergedIndexFlg PRINTOPTIONS)             (* bvm: "28-Mar-86 17:31")
-    (LET ((FULL (FINDFILE INF T)))
-         (COND
-	   ((NOT FULL)                                     (* When called by LISTFILES INF will already be a full
-							     file name)
-	     (printout (.ERRORSTREAM.)
-		       T INF " not found."))
-	   (SINGLEFILEINDEX.DONTSPAWN (SINGLEFILEINDEX2 FULL OUTF mergedIndexFlg PRINTOPTIONS))
-	   (T (\SFI.Q1UP (FUNCTION SINGLEFILEINDEX2)
-			   FULL OUTF mergedIndexFlg PRINTOPTIONS)
-                                                             (* Used to return NIL so that LISTFILES won't try 
-							     removing from NOTLISTEDFILES)
-	      FULL])
-
-(\SFI.Q1UP
-  [LAMBDA (FUN FULL OUTF mergedIndexFlg PRINTOPTIONS)        (* bvm: "15-Mar-86 17:11")
-
-          (* * Add a command to list file FULL to OUTF applying FUN)
-
-
-    (WITH.MONITOR \SFI.PROCESSLOCK                           (* Lock protects \SFI.PROCESS.COMMANDS and 
-							     \SFI.PROCESS)
-		  [COND
-		    ((AND \SFI.PROCESS (NOT (FIND.PROCESS \SFI.PROCESS)))
-                                                             (* Process died, flush handle and any old listing 
-							     requests)
-		      (SETQ \SFI.PROCESS (SETQ \SFI.PROCESS.COMMANDS NIL]
-		  (SETQ \SFI.PROCESS.COMMANDS (NCONC1 \SFI.PROCESS.COMMANDS
-							  (LIST FUN FULL OUTF mergedIndexFlg 
-								  PRINTOPTIONS)))
-		  (COND
-		    ((NULL \SFI.PROCESS)
-		      (SETQ \SFI.PROCESS (ADD.PROCESS (LIST (FUNCTION \FILELISTING))
-							  (QUOTE BEFOREEXIT)
-							  (QUOTE DON'T])
-
-(\FILELISTING
-  [LAMBDA NIL                                                (* bvm: "15-Mar-86 16:58")
-
-          (* * Process that takes listing commands from \SFI.PROCESS.COMMANDS and performs them)
-
-
-    (WITH.MONITOR \SFI.PROCESSLOCK                           (* Lock protects \SFI.PROCESS.COMMANDS and 
-							     \SFI.PROCESS)
-		  (while \SFI.PROCESS.COMMANDS bind FORM
-		     do (SETQ FORM (pop \SFI.PROCESS.COMMANDS))
-			  (RELEASE.MONITORLOCK \SFI.PROCESSLOCK) 
-                                                             (* Release lock while listing so that others can add 
-							     to my queue)
-			  (APPLY (CAR FORM)
-				   (CDR FORM))
-			  (OBTAIN.MONITORLOCK \SFI.PROCESSLOCK)
-		     finally                               (* Nothing left to do, so exit)
-			       (SETQ \SFI.PROCESS NIL])
-
-(SINGLEFILEINDEX2
-  [LAMBDA (FULL OUTF mergedIndexFlg PRINTOPTIONS)            (* bvm: "28-Mar-86 17:44")
-
-          (* * Process a single file FULL to OUTF with options. SINGLEFILEINDEX should have already computed the fullname of 
-	  the input file)
-
-
-    (COND
-      ((COND
-	  ((SINGLEFILEINDEX1 FULL OUTF mergedIndexFlg PRINTOPTIONS)
-	    (AND (NULL OUTF)
-		   (printout (.ERRORSTREAM.)
-			     T "indexed version of " FULL " => " PRINTERDEVICEFILENAME))
-	    T)
-	  (OUTF (printout (.ERRORSTREAM.)
-			  T FULL " is not LISPSOURCEFILEP -- COPYFILE being called"))
-	  (T (OLDLISTFILES1 FULL PRINTOPTIONS)))           (* Do this here since there is little coordination 
-							     between the various multiple processes which are 
-							     listing files)
-	(SETQ NOTLISTEDFILES (REMOVE (ROOTFILENAME FULL)
-					 NOTLISTEDFILES))
-	NIL])
-
-(SINGLEFILEINDEX1
-  [LAMBDA (FULL OUTF RETINDEXFLG PRINTOPTIONS)               (* bvm: "31-Mar-86 15:53")
-
-          (* Makes an indexed file (default is the line printer). The index file will have a number of indices, one for each 
-	  type in INDEXEDTYPESLIST. Each type index will list all the items of that type NIL in alphabetical order and the 
-	  page number of where that item's definition is in the file. -
-	  NOTE1: The indices will be printed last. -
-	  NOTE2: The index file is not "loadable" into LISP.)
-
-
-    (DECLARE (SPECVARS FULL)
-	       (USEDFREE LINESPERPAGE))
-    (RESETLST (PROG ((LINESPERPAGE LINESPERPAGE)
-			 [typesLST (OR (NULL RELATIVEINDEXFLG)
-					 (EQ RELATIVEINDEXFLG (QUOTE BOTH]
-			 (FNUM 0)
-			 (SOURCESTREAM)
-			 (PAGECOUNT)
-			 (LINECOUNT 1)
-			 (ItemPages)
-			 (INDICES)
-			 lastPage MAP FULLEOLC COMS currentItem nextFnGroup nextFnStart FNSMAPSL TEM)
-		        (DECLARE (SPECVARS MAP LINECOUNT PAGECOUNT LINESPERPAGE SOURCESTREAM 
-					       ItemPages typesLST FNUM currentItem linePos newPos 
-					       INDICES))
-
-          (* * Specials are as follows -
-	  SOURCESTREAM -- stream on the input file being formatted -
-	  currentItem -- function, etc currently being printed -
-	  FNUM -- ordinal number of function currently being printed, when RELATIVEINDEXFLG -
-	  PAGECOUNT -- number of current page -
-	  LINECOUNT -- number of current line on page -
-	  ItemPages -- list of (name type page#) constituting the actual index)
-
-
-		        [RESETSAVE (SETQ SOURCESTREAM (OPENSTREAM FULL (QUOTE INPUT)
-									(QUOTE OLD)))
-				     (QUOTE (PROGN (CLOSEF? OLDVALUE]
-		        (SETQ FULL (FULLNAME SOURCESTREAM))
-		        (COND
-			  ([EQ FULL (CAR (SETQ TEM (LISTP (GETP (ROOTFILENAME FULL)
-									  (QUOTE FILEMAP]
-                                                             (* It appears as though the file has already been 
-							     loaded in some way so that the MAP is already loaded)
-			    (SETQ MAP (CADR TEM)))
-			  ((NULL USEMAPFLG)
-			    (RESETSAVE NIL (QUOTE (SETQ USEMAPFLG)))
-                                                             (* Really should bind USEMAPFLG to T but this works if
-							     the system still thinks it's a globalvar)
-			    (SETQ USEMAPFLG T)))
-		        (COND
-			  ([OR (AND (NOT (RANDACCESSP SOURCESTREAM))
-					(OR typesLST (NULL MAP)))
-				 (AND (NULL MAP)
-					(NULL (SETQ MAP (GETFILEMAP FULL)))
-					(NOT (LISPSOURCEFILEP FULL]
-                                                             (* We just let the "old" listfiles do it when the file
-							     isn't RANDACCESSP or when it's probably some kind of 
-							     binary file)
-			    (RETURN)))
-		        (OR OUTF (SETQ OUTF PRINTERDEVICEFILENAME))
-		        [COND
-			  [(OPENP OUTF (QUOTE OUTPUT))
-			    (RESETSAVE (OUTPUT (SETQ OUTF (GETSTREAM OUTF (QUOTE OUTPUT]
-			  (T (RESETSAVE [OUTPUT (SETQ OUTF (OPENSTREAM OUTF (QUOTE OUTPUT)
-									       (QUOTE NEW]
-					  (QUOTE (PROGN (CLOSEF? (OUTPUT OLDVALUE]
-		        [STREAMPROP OUTF (QUOTE PRINTOPTIONS)
-				      (APPEND PRINTOPTIONS (LIST (QUOTE DOCUMENT.NAME)
-								     FULL)
-						(STREAMPROP OUTF (QUOTE PRINTOPTIONS]
-                                                             (* Make sure printer knows original name of file)
-		        (RESETSAVE (RADIX 10))
-		        (SETQ LINESPERPAGE (OR (GETFILEINFO OUTF (QUOTE PAGEHEIGHT))
-						   LINESPERPAGE))
-                                                             (* Determine printing parameters.)
-		        (RESETSAVE (LINELENGTH 1000 OUTF))
-		        (COND
-			  (RELATIVEINDEXFLG                  (* All index info up front, derived from file map, no 
-							     absolute page numbers)
-					    (PrintFileTitle FULL (GETFILEINFO SOURCESTREAM
-										  (QUOTE 
-										     CREATIONDATE)))
-					    (PrintRelativeFunctionIndex MAP)))
-		        [COND
-			  (typesLST (SETQ typesLST
-				      (for ENTRY in SINGLEFILEINDEX.TYPES
-					 collect (COND
-						     ((EQ (CAR (LISTP (fetch (SFITYPE 
-											 PATTERNS)
-									       of ENTRY)))
-							    (QUOTE eval))
-						       (create SFITYPE
-								 PATTERNS _(EVAL
-								   (CADR (fetch (SFITYPE PATTERNS)
-									      of ENTRY)))
-							  reusing ENTRY))
-						     (T ENTRY]
-		        (PROGN (SETQ FNSMAPSL (CDR MAP))
-				 (SETQ FULLEOLC (fetch EOLCONVENTION of SOURCESTREAM))
-				 (SETQ PAGECOUNT 1)
-				 (SETQ nextFnGroup (CDDR (CAR FNSMAPSL)))
-				 (SETQ nextFnStart (CADAR nextFnGroup)))
-
-          (* * Locate and print definitions for each item.)
-
-
-		        (bind linePos newPos (currentPos _ 0)
-				[EOL _(SELECTC FULLEOLC
-						 [CR.EOLC (CONCATCODES (CHARCODE (CR]
-						 [LF.EOLC (CONCATCODES (CHARCODE (LF]
-						 (CONCATCODES (CHARCODE (CR LF]
-			   while (SETQ newPos (FILEPOS EOL SOURCESTREAM currentPos))
-			   do                              (* currentPos = how far we have copied;
-							     linePos = start of current line;
-							     newPos = start of next line)
-				(SETFILEPTR SOURCESTREAM (SETQ linePos currentPos))
-				(COND
-				  ([COND
-				      [(EQ (PEEKCCODE SOURCESTREAM)
-					     (CHARCODE ^F))
-                                                             (* Line might start with a fontchange sequence)
-					(\SFI.FLUSHFONTCHANGE SOURCESTREAM)
-                                                             (* Advance linePos to after any font change chars)
-					(AND nextFnStart (OR (IEQP linePos nextFnStart)
-								 (IEQP currentPos nextFnStart]
-				      (T (AND nextFnStart (IEQP linePos nextFnStart]
-                                                             (* Index and print function group.)
-				    (for function in nextFnGroup do (SETQ newPos
-									    (PrintFnDef function 
-											  OUTF)))
-                                                             (* Should point us at the first of two closing parens)
-				    (pop FNSMAPSL)
-				    (SETQ nextFnGroup (CDDAR FNSMAPSL))
-				    (SETQ nextFnStart (CADAR nextFnGroup)))
-				  (T                         (* Print and index (when appropriate) next line.)
-				     (SELECTC FULLEOLC
-						(CRLF.EOLC (READC SOURCESTREAM)
-							   (add newPos 1))
-						0)
-				     (COND
-				       (typesLST (\SFI.AnalyzeLine SOURCESTREAM typesLST)))
-				     (INDEXCOPYBYTES SOURCESTREAM OUTF currentPos newPos)
-                                                             (* Print the line.)
-				     (INDEXNEWLINE)))
-				(SETQ currentPos (ADD1 newPos)))
-		        (SETQ lastPage PAGECOUNT)
-
-          (* * Print file index or indices.)
-
-
-		        (COND
-			  ((OR (NULL RELATIVEINDEXFLG)
-				 (EQ RELATIVEINDEXFLG (QUOTE BOTH)))
-			    (SETQ INDICES (\SFI.SORTINDEX ItemPages))
-			    [LET ((VARS (ASSOC (QUOTE VAR)
-						   INDICES)))
-                                                             (* Manually filter out the filecoms var)
-			         (RPLACD VARS (DREMOVE (ASSOC (FILECOMS FULL)
-								    (CDR VARS))
-							   (CDR VARS]
-			    (\SFI.FILTER.INDEX INDICES)
-			    (INDEXNEWPAGE T)
-			    (COND
-			      ((AND (EVENP PAGECOUNT)
-				      SINGLEFILEINDEX.TWOSIDED)
-                                                             (* Ensure that the index will not be on the back-side 
-							     of a two-sided listing)
-				(INDEXNEWPAGE T)))
-			    (PrintFileTitle FULL (GETFILEINFO SOURCESTREAM (QUOTE CREATIONDATE))
-					      )
-			    (\SFI.PRINT.INDEX INDICES)))
-		        (RETURN (COND
-				    (RETINDEXFLG (CONS FULL INDICES))
-				    (T FULL])
-
-(\SFI.AnalyzeLine
-  [LAMBDA (SOURCESTREAM TYPETRIPLES FLG)                     (* bvm: "30-Mar-86 15:07")
-
-          (* * Retrieve line as string, beginning with first character that isn't a font change char,)
-
-
-    (DECLARE (USEDFREE ItemPages))
-    (SELECTQ (GETSYNTAX (READCCODE SOURCESTREAM)
-			    FILERDTBL)
-	       [(LEFTPAREN LEFTBRACKET)                      (* Note that if the first character on the line isn't 
-							     a parens then this line can't be the start of anything
-							     interesting)
-		 (COND
-		   ((EQ (PEEKCCODE SOURCESTREAM)
-			  (CHARCODE ^F))
-
-          (* It is possible to have a fontchange sequence just after the open parens, though most forms reserve the font 
-	  change for the named object, coming up next)
-
-
-		     (\SFI.FLUSHFONTCHANGE SOURCESTREAM)))
-		 (LET ((FN (READ SOURCESTREAM FILERDTBL))
-		       HERE PAT MOVED? ITEMNAME)
-		      (SETQ HERE (GETFILEPTR SOURCESTREAM))
-		      (for ENTRY in TYPETRIPLES when (COND
-							     ((EQ (SETQ PAT (fetch
-									(SFITYPE PATTERNS)
-										   of ENTRY))
-								    T)
-                                                             (* Matches anything -- TESTFN must be doing all the 
-							     work)
-							       T)
-							     ((LISTP PAT)
-							       (MEMB FN PAT))
-							     (T (EQ FN PAT)))
-			 do                                (* ENTRY thinks this line might be interesting)
-			      (COND
-				(MOVED?                      (* Previous test may have moved the file pointer, so 
-							     bring it back)
-					(SETFILEPTR SOURCESTREAM HERE)
-					(SETQ MOVED? NIL)))
-			      [COND
-				([SETQ ITEMNAME (CAR (NLSETQ
-							   (APPLY* (OR (fetch (SFITYPE TESTFN)
-									      of ENTRY)
-									   (FUNCTION TestForType))
-								     SOURCESTREAM FN ENTRY]
-				  [COND
-				    ((NLISTP ITEMNAME)     (* Single object to be indexed as the type in ENTRY)
-				      (push ItemPages (LIST (LET ((TYPE (fetch (SFITYPE NAME)
-									       of ENTRY)))
-								     (OR (CAR (LISTP TYPE))
-									   TYPE))
-								ITEMNAME PAGECOUNT)))
-				    (T                       (* Index as some other type)
-				       (for PAIR in (COND
-							  ((LITATOM (CAR ITEMNAME))
-                                                             (* a single pair)
-							    (LIST ITEMNAME))
-							  (T 
-                                                             (* many)
-							     ITEMNAME))
-					  do (for NAME in (CDR PAIR)
-						  do (push ItemPages (LIST (CAR PAIR)
-										 NAME PAGECOUNT]
-				  (COND
-				    ((NOT (fetch (SFITYPE AMBIGUOUS?) of ENTRY))
-				      (RETURN]
-			      (SETQ MOVED? T]
-	       ((RIGHTPAREN RIGHTBRACKET)                    (* Well, some lines will be the closing of a DEFINEQ 
-							     or a DECLARE: or whatever)
-		 NIL)
-	       NIL])
-
-(\SFI.FLUSHFONTCHANGE
-  [LAMBDA (STREAM)                                           (* bvm: "15-Mar-86 17:41")
-    (while (EQ (PEEKCCODE STREAM)
-		   (CHARCODE ^F))
-       do (READCCODE STREAM)
-	    (READCCODE STREAM)
-	    (add linePos 2])
-
-(PrintFnDef
-  [LAMBDA (FNDEF OUTSTREAM)
-    (DECLARE (USEDFREE ItemPages FNUM SOURCESTREAM PAGECOUNT LINESPERPAGE LINECOUNT)
-	       (SPECVARS currentItem))                     (* bvm: "28-Mar-86 17:41")
-
-          (* * Prints a FNDEF definition on the file OUTSTREAM -
-	  FNDEF is map entry of form (name start . end))
-
-
-    (PROG ((END (CDDR FNDEF))
-	     (currentItem (CAR FNDEF)))
-	    (add FNUM 1)
-	    (INDEXNEWLINE)
-	    (COND
-	      (RELATIVEINDEXFLG (printout NIL .SP (IDIFFERENCE FILELINELENGTH (IPLUS
-								   2
-								   (NCHARS FNUM)))
-					  .FONT BOLDFONT "[" FNUM "]" .FONT DEFAULTFONT .RESET)))
-	    (INDEXNEWLINE)
-	    (COND
-	      ((NOT (ILEQ (IPLUS LINECOUNT 3)
-			      LINESPERPAGE))
-		(INDEXNEWPAGE)))
-	    (push ItemPages (LIST (QUOTE FUNCTION)
-				      currentItem PAGECOUNT))
-                                                             (* Print out function.)
-	    (INDEXCOPYBYTES SOURCESTREAM OUTSTREAM (CADR FNDEF)
-			      END)
-	    (RETURN END])
-
-(INDEXCOPYBYTES
-  [LAMBDA (IN OUT START END)
-    (DECLARE (USEDFREE LINECOUNT LINESPERPAGE))          (* bvm: "15-Mar-86 17:50")
-
-          (* This is similar to COPYBYTES except that, INDEXNEWLINE is called whenever an EOL is read, and IndexNewPage is 
-	  called whenever a form feed is read)
-
-
-    (SETFILEPTR IN START)
-    [PROG ((INSTRM (GETSTREAM IN (QUOTE INPUT)))
-	     (OUTSTRM (GETSTREAM OUT (QUOTE OUTPUT)))
-	     EOLC NLFLG LOOKFORLF CH)
-	    (SETQ EOLC (fetch EOLCONVENTION of INSTRM))
-	    (FRPTQ (IDIFFERENCE END START)
-		     (SELCHARQ (SETQ CH (BIN INSTRM))
-			       [CR (SELECTC EOLC
-					      [CR.EOLC (SETQ LOOKFORLF NIL)
-						       (COND
-							 ((AND NLFLG (IGREATERP LINECOUNT
-										    (IDIFFERENCE
-										      LINESPERPAGE 5))
-								 )
-                                                             (* double cr near end of page)
-							   (INDEXNEWPAGE)
-							   (SETQ NLFLG NIL))
-							 (T (INDEXNEWLINE)
-							    (SETQ NLFLG T]
-					      (CRLF.EOLC 
-
-          (* Flag says that EOLC is CRLF and we are looking for next char to be LF. Expanded out this way so that we can keep
-	  track of the character counts accurately)
-
-
-							 (SETQ LOOKFORLF T))
-					      (PROGN (SETQ LOOKFORLF NIL)
-						       (\OUTCHAR OUTSTRM (CHARCODE CR]
-			       (LF [COND
-				     [(OR LOOKFORLF (EQ EOLC LF.EOLC))
-				       (COND
-					 ((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE 
-										     LINESPERPAGE 5)))
-                                                             (* double cr near end of page)
-					   (INDEXNEWPAGE)
-					   (SETQ NLFLG NIL))
-					 (T (INDEXNEWLINE)
-					    (SETQ NLFLG T]
-				     (T (\OUTCHAR OUTSTRM (CHARCODE LF))
-                                                             (* If LF comes thru, it is just a vertical tab.
-							     Want to keep horizontal position the same, but update 
-							     line-counts)
-					(COND
-					  ((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE 
-										     LINESPERPAGE 5)))
-                                                             (* double cr near end of page)
-					    (INDEXNEWPAGE)
-					    (SETQ NLFLG NIL))
-					  (T (COND
-					       ((IGREATERP (add LINECOUNT 1)
-							     LINESPERPAGE)
-						 (INDEXNEWPAGE)))
-					     (SETQ NLFLG T]
-				   (SETQ LOOKFORLF NIL))
-			       (FF (INDEXNEWPAGE)
-				   (SETQ NLFLG NIL)
-				   (SETQ LOOKFORLF NIL))
-			       (PROGN (\BOUT OUTSTRM CH)
-					(SETQ NLFLG NIL)
-					(SETQ LOOKFORLF NIL]
-    T])
-
-(INDEXNEWLINE
-  [LAMBDA (DontPrintPageNbrFlg)                              (* JonL "13-Mar-84 22:04")
-    (TERPRI)
-    (COND
-      ((IGREATERP (add LINECOUNT 1)
-		    LINESPERPAGE)
-	(INDEXNEWPAGE DontPrintPageNbrFlg])
-
-(INDEXNEWPAGE
-  [LAMBDA (DontPrintPageNbrFlg)                              (* JonL "13-Mar-84 22:04")
-    (PRIN3 (FCHARACTER (CHARCODE FF)))
-    (POSITION NIL 0)
-    (SETQ LINECOUNT 0)
-    (COND
-      (PAGECOUNT (add PAGECOUNT 1)))
-    (\SFI.LISTINGHEADER DontPrintPageNbrFlg])
-
-(\SFI.SORTINDEX
-  [LAMBDA (TRIPLES)                                          (* bvm: "29-Mar-86 17:26")
-
-          (* * Sort TRIPLES into a set of indices, one per type. Each element is of the form (type name page), while the 
-	  resulting indices are of the form (type . entries), with each entry looking like (name . pagenumbers))
-
-
-    (LET ([TYPENAMES (CONS (QUOTE FUNCTION)
-			     (for X in SINGLEFILEINDEX.TYPES collect (CAR X]
-	  RESULT INDEX OLDNAME)
-         [for TRIP in TRIPLES
-	    do [COND
-		   ((NULL (SETQ INDEX (ASSOC (CAR TRIP)
-						   RESULT)))
-		     (push RESULT (SETQ INDEX (LIST (CAR TRIP]
-		 (COND
-		   [(SETQ OLDNAME (ASSOC (CADR TRIP)
-					     INDEX))         (* Duplicate entry, so add a page number)
-		     (RPLACD OLDNAME (SORT (UNION (CDDR TRIP)
-							(CDR OLDNAME]
-		   (T (push (CDR INDEX)
-			      (CDR TRIP]
-         (for PAIR in RESULT do (SORT (CDR PAIR)
-					      (FUNCTION UALPHORDERCAR)))
-         (SORT RESULT (FUNCTION (LAMBDA (X Y)            (* X is before Y if its car appears before Y's in 
-							     TYPENAMES)
-		     (FMEMB (CAR Y)
-			      (CDR (FMEMB (CAR X)
-					      TYPENAMES])
-
-(UALPHORDERCAR
-  [LAMBDA (A B)                                              (* JonL " 7-Mar-84 19:52")
-                                                             (* does case independent sort on the CAR of two 
-							     elements.)
-    (UALPHORDER (CAR A)
-		  (CAR B])
-
-(\SFI.FILTER.INDEX
-  [LAMBDA (INDICES)                                          (* bvm: "30-Mar-86 14:11")
-
-          (* * Remove redundancies from the prepared INDICES)
-
-
-    (DECLARE (SPECVARS INDICES))                         (* For SFI.LOOKUP.NAME)
-    (for TYPEPAIR in INDICES bind FILTERS when [SETQ FILTERS (for FILTER in 
-									  SINGLEFILEINDEX.FILTERS
-									  collect (CDR FILTER)
-									  when (EQ (CAR FILTER)
-										       (CAR 
-											 TYPEPAIR]
-       do                                                  (* Each filter is either a type name or a list whose 
-							     car is a function)
-	    (RPLACD TYPEPAIR (for PAIR in (CDR TYPEPAIR) collect PAIR
-				  unless (for F in FILTERS thereis
-								  (COND
-								    ((NLISTP F)
-                                                             (* Name exists as another type)
-								      (SFI.LOOKUP.NAME
-									(CAR PAIR)
-									F))
-								    (T (APPLY* (CAR F)
-										 PAIR])
-)
-(DEFINEQ
-
-(PrintFileTitle
-  [LAMBDA (FILENAME DATE)                                    (* bvm: "15-Mar-86 17:17")
-
-          (* * Print FILENAME title. Should not be called unless FILENAME is essentially "at the top of the page")
-
-
-    (\SFI.CENTERPRINT (CONCAT FILENAME "		" DATE)
-			T)
-    (\SFI.CENTERPRINT (CONCAT "-- Listed on " (DATE)
-				  " --"))
-    (INDEXNEWLINE])
-
-(\SFI.PRINT.INDEX
-  [LAMBDA (INDICES)                                          (* bvm: "30-Mar-86 15:52")
-
-          (* * For each (type . entries) pair in INDICES print a pretty index for the items of the type)
-
-
-    (for PAIR in INDICES when (CDR PAIR)
-       do (PrintIndex (CDR PAIR)
-			  lastPage
-			  (CAR PAIR))
-	    (INDEXNEWLINE T))
-    (\SFI.BreakLine])
-
-(PrintIndex
-  [LAMBDA (INDEXPAIRS MaxIndexNo TYPE)                       (* bvm: "30-Mar-86 15:34")
-
-          (* * print index of items in IndexedList.)
-
-
-    (DECLARE (USEDFREE LINESPERPAGE LINECOUNT))
-    (PROG ([INDEXNOWIDTH (COND
-			     ((ILESSP MaxIndexNo 10)
-			       1)
-			     ((ILESSP MaxIndexNo 100)
-			       2)
-			     (T (NCHARS MaxIndexNo]
-	     NCOLUMNS NROWS WIDTH LEFT SPACING NROWSREMAINING LastItem)
-	    (DECLARE (SPECVARS NCOLUMNS LEFT WIDTH SPACING NROWS))
-	    (SETQ WIDTH (IPLUS (for PAIR in INDEXPAIRS bind
-				      largest (PLUS (NCHARS (CAR PAIR))
-							(COND
-							  ((CDDR PAIR)
-                                                             (* When multiple page nos, must count the extra pages,
-							     plus an additional char each for the separating comma)
-							    (ITIMES (LENGTH (CDDR PAIR))
-								      (IPLUS 1 INDEXNOWIDTH)))
-							  (T 0)))
-				      finally (RETURN $$EXTREME))
-				   INDEXNOWIDTH 1))          (* WIDTH is the widest any entry gets: name plus page 
-							     numbers)
-	    (\SFI.PrintIndexFactors INDEXPAIRS)            (* Compute NCOLUMNS LEFT WIDTH SPACING NROWS)
-	    (SETQ NROWSREMAINING NROWS)
-	    (AND TYPE (\SFI.BreakLine))                  (* When TYPE is non-null, call is from 
-							     PrintOneTypeIndex)
-	    (INDEXNEWLINE T)
-	    (COND
-	      (TYPE [COND
-		      ((AND (IGREATERP (IPLUS NROWS 3)
-					   (IDIFFERENCE LINESPERPAGE LINECOUNT))
-			      (IGREATERP LINECOUNT (LRSH LINESPERPAGE 1)))
-
-          (* * Don't start an indexing on the bottom half of a page which is going to cross a page boundary before the 
-	  "breaker")
-
-
-			(INDEXNEWPAGE T)
-			(AND TYPE (\SFI.BreakLine]
-		    (\SFI.CENTERPRINT (CONCAT TYPE " INDEX")
-					T T)
-		    (INDEXNEWLINE T)))
-	    (while INDEXPAIRS
-	       do (SETQ NROWS (IMIN NROWSREMAINING (IDIFFERENCE LINESPERPAGE LINECOUNT)))
-		    (for ROW from 1 to NROWS bind NEXTINDEX
-		       do (SETQ NEXTINDEX ROW)
-			    (for COLUMN from 1 to NCOLUMNS
-			       do [COND
-				      ((SETQ LastItem (FNTH INDEXPAIRS NEXTINDEX))
-					(LET* ((ITEM (CAR LastItem))
-					       (LABEL (CAR ITEM))
-					       (PAGENO (CDR ITEM)))
-					      [SETQ PAGENO
-						(COND
-						  [(LISTP PAGENO)
-                                                             (* More than one occurrence)
-						    (CONCATLIST (CDR (for P in PAGENO
-									    join (LIST "," P]
-						  (T (MKSTRING PAGENO]
-					      (printout NIL .FONT DEFAULTFONT LABEL ,)
-					      (PRINTDOTS (IDIFFERENCE (IDIFFERENCE
-									    WIDTH
-									    (ADD1 (NCHARS LABEL)))
-									  (NCHARS PAGENO)))
-					      (PRIN1 PAGENO)
-					      (COND
-						((NEQ COLUMN NCOLUMNS)
-						  (SPACES SPACING]
-				    (add NEXTINDEX NROWS))
-			    (INDEXNEWLINE T))
-		    (COND
-		      ((SETQ INDEXPAIRS (CDR LastItem))
-			(INDEXNEWPAGE T)
-			(SETQ NROWSREMAINING (ADD1 (IQUOTIENT (LENGTH INDEXPAIRS)
-								    NCOLUMNS])
-
-(\SFI.PrintIndexFactors
-  [LAMBDA (IndexedList)                                      (* bvm: "30-Mar-86 15:00")
-    (DECLARE (USEDFREE NCOLUMNS LEFT WIDTH SPACING NROWS))
-    (LET ((LEN (LENGTH IndexedList)))
-         [SETQ NCOLUMNS (IMAX 1 (IMIN LEN (IQUOTIENT FILELINELENGTH (IPLUS WIDTH 2]
-                                                             (* Number of columns that fit if you allow 2 spaces 
-							     between columns)
-         (SETQ NROWS (IQUOTIENT (IPLUS LEN (SUB1 NCOLUMNS))
-				    NCOLUMNS))
-         (SETQ NCOLUMNS (IQUOTIENT (IPLUS LEN (SUB1 NROWS))
-				       NROWS))               (* This might reduce the number of columns if all the 
-							     items, printed in NROWS rows, take fewer columns than 
-							     originally allocated)
-         (SETQ LEFT (IDIFFERENCE FILELINELENGTH (ITIMES (IPLUS WIDTH 2)
-							      NCOLUMNS)))
-                                                             (* LEFT is number of spaces remaining after allocating
-							     the columns)
-         (COND
-	   ((EQ NCOLUMNS 1)                                (* Only one column, so either make it half the page 
-							     width or the full width)
-	     [SETQ WIDTH (COND
-		 ((GREATERP WIDTH (IQUOTIENT FILELINELENGTH 2))
-		   FILELINELENGTH)
-		 (T (IQUOTIENT FILELINELENGTH 2]
-	     (SETQ SPACING 0))
-	   (T (SETQ WIDTH (IMIN (IPLUS WIDTH (IQUOTIENT LEFT 2))
-				    (IDIFFERENCE (IQUOTIENT FILELINELENGTH NCOLUMNS)
-						   2)))      (* Spaces LEFT gets divided between the dots an the 
-							     between-column spaces.)
-	      (SETQ SPACING (COND
-		  ((EQ NCOLUMNS 1)
-		    0)
-		  (T (IQUOTIENT (IDIFFERENCE FILELINELENGTH (ITIMES WIDTH NCOLUMNS))
-				  (SUB1 NCOLUMNS])
-
-(PrintRelativeFunctionIndex
-  [LAMBDA (MAP)                                            (* bvm: "31-Mar-86 15:59")
-
-          (* * Create and print an index for the functions on the file.)
-
-
-    (PROG ((MaxIndexNo 0)
-	     IndexedList currentItem)
-	    [SETQ IndexedList (for DFQ in MAP join (for function in (CDDR DFQ)
-							      collect (LIST (CAR function)
-										(add MaxIndexNo 1]
-                                                             (* Printout function index.)
-	    (COND
-	      ((NOT IndexedList)
-		(INDEXNEWLINE T)
-		(INDEXNEWLINE T)
-		(printout NIL .FONT BOLDFONT "No Functions." .FONT DEFAULTFONT))
-	      (T (PrintIndex (SORT IndexedList (FUNCTION UALPHORDERCAR))
-			       MaxIndexNo)))
-	    (INDEXNEWPAGE T)
-	    (RETURN MAP])
-
-(\SFI.CENTERPRINT
-  [LAMBDA (STR BOLDFLG DontPrintPageNbrFlg)                  (* //Z\\ "15-Apr-88 09:49")
-                                                             (* JonL "13-Mar-84 22:07")
-                                                             (* Be sure to only TAB with a positive index)
-    (TAB (IQUOTIENT (if (IGREATERP FILELINELENGTH (NCHARS STR))
-			    then (IDIFFERENCE FILELINELENGTH (NCHARS STR))
-			  else 0)
-			2))
-    (COND
-      (BOLDFLG (printout NIL .FONT BOLDFONT STR .FONT DEFAULTFONT))
-      (T (printout NIL STR)))
-    (INDEXNEWLINE DontPrintPageNbrFlg])
-
-(PRINTDOTS
-  [LAMBDA (N FILE)                                           (* bvm: "15-Mar-86 16:28")
-    (LET [(STRM (GETSTREAM FILE (QUOTE OUTPUT]
-         (FRPTQ N (\OUTCHAR STRM (CHARCODE %.])
-
-(\SFI.LISTINGHEADER
-  [LAMBDA (dontPrintPageNumberFlg)                           (* cht: " 5-JAN-84 15:15")
-    (COND
-      (FULL (PRIN1 FULL)))
-    (COND
-      ((AND currentItem FNUM RELATIVEINDEXFLG)
-	(printout NIL "  (" .P2 currentItem "[" FNUM "] cont.)"))
-      (currentItem (printout NIL "  (" .P2 currentItem " cont.)")))
-    (TAB (IDIFFERENCE FILELINELENGTH 9)
-	   T)
-    (COND
-      ((AND PAGECOUNT (NOT dontPrintPageNumberFlg))
-	(PRIN1 "Page ")
-	(PRINTNUM (QUOTE (FIX 4))
-		    PAGECOUNT)))
-    (INDEXNEWLINE)
-    (INDEXNEWLINE])
-
-(\SFI.BreakLine
-  [LAMBDA NIL                                                (* bvm: "15-Mar-86 16:28")
-    (INDEXNEWLINE T)
-    [LET [(STRM (GETSTREAM NIL (QUOTE OUTPUT]
-         (FRPTQ FILELINELENGTH (\OUTCHAR STRM (CHARCODE ~]
-    (INDEXNEWLINE T])
-)
-
-(RPAQ? PRINTERDEVICEFILENAME (QUOTE {LPT}))
-
-(RPAQ? RELATIVEINDEXFLG )
-
-(RPAQ? SINGLEFILEINDEX.TWOSIDED )
-
-(RPAQ? SINGLEFILEINDEX.DONTSPAWN )
-
-(RPAQ? \SFI.PROCESS.COMMANDS )
-
-(RPAQ? \SFI.PROCESSLOCK (CREATE.MONITORLOCK "SINGLEFILEINDEX"))
-
-(RPAQ? \SFI.PROCESS )
-
-(RPAQ? ERRORMESSAGESTREAM T)
-
-(ADDTOVAR SINGLEFILEINDEX.TYPES (MACRO DEFMACRO)
-				  (VAR (RPAQ RPAQ? RPAQQ ADDTOVAR)
-				       TestForVar T)
-				  (VAR READVARS TestForUglyVars)
-				  (BITMAP RPAQ TestForBitmap)
-				  (CONSTANTS CONSTANTS TestForConstants)
-				  (RECORD (eval CLISPRECORDTYPES))
-				  (PROPERTY PUTPROPS TestForProp)
-				  (COURIERPROGRAM COURIERPROGRAM)
-				  (TEMPLATE SETTEMPLATE TestForQuotedType)
-				  (I.S.OPR I.S.OPR TestForQuotedType)
-				  (RESOURCES PUTDEF TestForResource)
-				  (ADVICE READVISE))
-
-(ADDTOVAR SINGLEFILEINDEX.PROPERTIES (COPYRIGHT)
-				       (READVICE ADVICE))
-
-(ADDTOVAR SINGLEFILEINDEX.FILTERS (VAR . CONSTANTS)
-				    (VAR . BITMAP))
-
-
-
-(* "Functions that find types")
-
-(DEFINEQ
-
-(TestForType
-  [LAMBDA (STREAM FN TRIPLE)                                 (* bvm: "30-Mar-86 13:20")
-
-          (* * Default testfn for types that are dumped in a form whose second element is the object's name)
-
-
-    (LET ((NAME (READ STREAM FILERDTBL)))
-         (AND NAME (LITATOM NAME)
-		NAME])
-
-(TestForQuotedType
-  [LAMBDA (STREAM FN TRIPLE)                                 (* bvm: "30-Mar-86 13:29")
-
-          (* * Like TestForType, but tests for something where the second element of the form is the quoted name.)
-
-
-    (LET ((NAME (READ STREAM FILERDTBL)))
-         (AND (EQ (CAR (LISTP NAME))
-		      (QUOTE QUOTE))
-		(CADR NAME])
-
-(TestForVar
-  [LAMBDA (STREAM FN TRIPLE)                                 (* bvm: "29-Mar-86 17:02")
-
-          (* * Called for expressions whose car is one of RPAQ, RPAQQ, RPAQ?, ADDTOVAR -- read the variable name following 
-	  it. Filters after the fact will remove duplications with other variable types)
-
-
-    (LET (NAME)
-         (COND
-	   ([AND (SETQ NAME (READ STREAM FILERDTBL))
-		   (LITATOM NAME)
-		   (NEQ NAME T)
-		   (NOT (FMEMB NAME (QUOTE (GLOBALVARS SPECVARS LOCALVARS NLAMA NLAML LAMA]
-                                                             (* Ignore compiler-internal vars)
-	     NAME])
-
-(TestForBitmap
-  [LAMBDA (STREAM FN TRIPLE)                                 (* bvm: "28-Mar-86 17:06")
-
-          (* * Called on (RPAQ --) in case the expression is (RPAQ var (READBITMAP)))
-
-
-    (LET ((NAME (READ STREAM FILERDTBL))
-	  CHAR)
-         (COND
-	   ([AND NAME (LITATOM NAME)
-		   (EQ (SETQ CHAR (SKIPSEPRCODES STREAM FILERDTBL))
-			 (CHARCODE "("))
-		   (PROGN (READCCODE STREAM)             (* After the VARS name is the form 
-							     (READBITMAP ...))
-			    (EQ (RATOM STREAM FILERDTBL)
-				  (QUOTE READBITMAP]
-	     NAME])
-
-(TestForProp
-  [LAMBDA (STREAM FN TRIPLE)                                 (* bvm: "31-Mar-86 12:13")
-
-          (* * Called when given a PUTPROPS expression. Determine what type it is by looking at the property name.
-	  If no more specific type known, then index it as a PROPERTY)
-
-
-    (LET ((NAME (READ STREAM FILERDTBL))
-	  (PROP (READ STREAM FILERDTBL)))                  (* See if PROP means something more specific than 
-							     "property")
-         (COND
-	   ((MEMB PROP MACROPROPS)                         (* Do macros in line so that MACRONAMES can be 
-							     dynamically changed.)
-	     (LIST (QUOTE MACRO)
-		     NAME))
-	   (T (for PAIR in SINGLEFILEINDEX.PROPERTIES when (EQ (CAR PAIR)
-								       PROP)
-		 do                                        (* Index it under this other type)
-		      (RETURN (AND (CADR PAIR)
-				       (LIST (CADR PAIR)
-					       NAME)))
-		 finally                                   (* Nothing better, so index it as having a property)
-			   (RETURN NAME])
-
-(TestForResource
-  [LAMBDA (STREAM FN TRIPLE)                                 (* bvm: "28-Mar-86 17:08")
-    (TestForGenericDefinition STREAM FN (QUOTE ((RESOURCES GLOBALRESOURCES])
-
-(TestForUglyVars
-  [LAMBDA (STREAM FN TRIPLE)                                 (* bvm: "30-Mar-86 15:42")
-
-          (* * Uglyvars are dumped as (READVARS var1 var2 ...))
-
-
-    (CONS (QUOTE VAR)
-	    (CDR (SFI.WHOLE.EXPRESSION STREAM])
-
-(TestForGenericDefinition
-  [LAMBDA (STREAM FN TRIPLE)                                 (* bvm: "31-Mar-86 12:02")
-
-          (* * Tests to see if expression is of the form (PUTDEF (QUOTE name) (QUOTE type) (QUOTE value)) where type is one 
-	  specified in TRIPLE)
-
-
-    (LET ((DESIREDTYPE (CAR TRIPLE))
-	  NAME TYPE)
-         (COND
-	   ([AND (PROGN                                  (* After the PUTDEF should find 
-							     (QUOTE name))
-			    (EQ [CAR (LISTP (SETQ NAME (READ STREAM FILERDTBL]
-				  (QUOTE QUOTE)))
-		   (PROGN                                  (* then (QUOTE DESIREDTYPE))
-			    (EQ [CAR (LISTP (SETQ TYPE (READ STREAM FILERDTBL]
-				  (QUOTE QUOTE)))
-		   (OR (EQ [SETQ TYPE (CAR (LISTP (CDR TYPE]
-			       DESIREDTYPE)
-			 (AND (LISTP DESIREDTYPE)
-				(MEMB TYPE DESIREDTYPE]
-	     (CADR NAME])
-
-(TestForConstants
-  [LAMBDA (STREAM FN TRIPLE)                                 (* bvm: "30-Mar-86 14:17")
-
-          (* * Called when expression is (CONSTANTS --) -- return all elements (or CAR of element when it's a pair) as type 
-	  CONSTANTS)
-
-
-    (CONS (QUOTE CONSTANTS)
-	    (for X in (CDR (SFI.WHOLE.EXPRESSION STREAM)) collect (COND
-									      ((LISTP X)
-										(CAR X))
-									      (T X])
-
-(SFI.WHOLE.EXPRESSION
-  [LAMBDA (STREAM)                                           (* bvm: "30-Mar-86 13:34")
-    (DECLARE (USEDFREE linePos))
-
-          (* * Called by testfns that want to see the whole expression)
-
-
-    (SETFILEPTR STREAM linePos)
-    (READ STREAM FILERDTBL])
-
-(SFI.LOOKUP.NAME
-  [LAMBDA (NAME TYPE)                                        (* bvm: "30-Mar-86 13:44")
-    (ASSOC NAME (CDR (ASSOC TYPE INDICES])
-)
-(DECLARE: EVAL@COMPILE DONTCOPY 
-(DECLARE: EVAL@COMPILE 
-(PUTPROPS .ERRORSTREAM. MACRO (NIL (SELECTQ ERRORMESSAGESTREAM (T PROMPTWINDOW)
-					    ERRORMESSAGESTREAM)))
-)
-
-[DECLARE: EVAL@COMPILE 
-
-(RECORD SFITYPE (NAME PATTERNS TESTFN AMBIGUOUS?))
-]
-
-(FILESLOAD (IMPORT)
-	   FILEIO)
-
-(DECLARE: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS DEFAULTFONT NOTLISTEDFILES)
-)
-
-(DECLARE: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS FILERDTBL RELATIVEINDEXFLG)
-)
-
-(DECLARE: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS SINGLEFILEINDEX.DONTSPAWN \SFI.PROCESS.COMMANDS \SFI.PROCESSLOCK \SFI.PROCESS 
-	    SINGLEFILEINDEX.TWOSIDED SINGLEFILEINDEX.TYPES SINGLEFILEINDEX.PROPERTIES 
-	    SINGLEFILEINDEX.FILTERS FILELINELENGTH MACROPROPS PRINTERDEVICEFILENAME)
-)
-DONTEVAL@LOAD 
-(DECLARE: DOEVAL@COMPILE DONTCOPY
-
-(SPECVARS . T)
-)
-)
-(DEFINEQ
-
-(SFI.LISTFILES1
-  [LAMBDA (FILE PRINTOPTIONS)                                (* rmk: "26-Feb-85 10:36")
-    (SINGLEFILEINDEX FILE NIL NIL PRINTOPTIONS])
-)
-(DECLARE: DOCOPY DONTEVAL@LOAD 
-(MOVD? (QUOTE LISTFILES1)
-       (QUOTE OLDLISTFILES1))
-(/MOVD (QUOTE SFI.LISTFILES1)
-       (QUOTE LISTFILES1))
-
-
-(RPAQ? LINESPERPAGE 65)
-)
-(PUTPROPS SINGLEFILEINDEX COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1988))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (3020 25431 (SINGLEFILEINDEX 3030 . 3773) (\SFI.Q1UP 3775 . 4729) (\FILELISTING 4731 . 
-5618) (SINGLEFILEINDEX2 5620 . 6523) (SINGLEFILEINDEX1 6525 . 14860) (\SFI.AnalyzeLine 14862 . 17966) 
-(\SFI.FLUSHFONTCHANGE 17968 . 18246) (PrintFnDef 18248 . 19344) (INDEXCOPYBYTES 19346 . 22103) (
-INDEXNEWLINE 22105 . 22350) (INDEXNEWPAGE 22352 . 22669) (\SFI.SORTINDEX 22671 . 24007) (UALPHORDERCAR
- 24009 . 24309) (\SFI.FILTER.INDEX 24311 . 25429)) (25432 34128 (PrintFileTitle 25442 . 25842) (
-\SFI.PRINT.INDEX 25844 . 26259) (PrintIndex 26261 . 29594) (\SFI.PrintIndexFactors 29596 . 31498) (
-PrintRelativeFunctionIndex 31500 . 32356) (\SFI.CENTERPRINT 32358 . 33005) (PRINTDOTS 33007 . 33228) (
-\SFI.LISTINGHEADER 33230 . 33837) (\SFI.BreakLine 33839 . 34126)) (35163 40656 (TestForType 35173 . 
-35494) (TestForQuotedType 35496 . 35877) (TestForVar 35879 . 36548) (TestForBitmap 36550 . 37165) (
-TestForProp 37167 . 38291) (TestForResource 38293 . 38490) (TestForUglyVars 38492 . 38754) (
-TestForGenericDefinition 38756 . 39712) (TestForConstants 39714 . 40177) (SFI.WHOLE.EXPRESSION 40179
- . 40485) (SFI.LOOKUP.NAME 40487 . 40654)) (41455 41631 (SFI.LISTFILES1 41465 . 41629)))))
-STOP
diff --git a/obsolete/lispusers/TEDITDORADOKEYS b/obsolete/lispusers/TEDITDORADOKEYS
deleted file mode 100644
index 5c6597df..00000000
--- a/obsolete/lispusers/TEDITDORADOKEYS
+++ /dev/null
@@ -1,124 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
-
-(FILECREATED "26-Feb-2024 11:19:15" |{WMEDLEY}<lispusers>TEDITDORADOKEYS.;8| 5385   
-
-      :EDIT-BY |rmk|
-
-      :CHANGES-TO (VARS TEDITDORADOKEYSCOMS)
-
-      :PREVIOUS-DATE "15-Sep-2022 10:10:07" |{WMEDLEY}<lispusers>TEDITDORADOKEYS.;4|)
-
-
-(PRETTYCOMPRINT TEDITDORADOKEYSCOMS)
-
-(RPAQQ TEDITDORADOKEYSCOMS
-       ((DECLARE\: EVAL@COMPILE DONTCOPY (FILES TEDIT-EXPORTS.ALL))
-        (COMS 
-              (* |;;| "Specialized functions for this module")
-
-              (FNS \\TEDIT.DK.ABORT \\TEDIT.DK.INSERT-PARENS \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES 
-                   \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES))
-        (VARS (\\TEDIT.DORADO.KEYS '(("Meta,x" EXPAND)
-                                     ("Meta,X" EXPAND)
-                                     ("Meta,c" FN \\TEDIT.CENTER.SEL)
-                                     ("Meta,C" FN \\TEDIT.CENTER.SEL.REV)
-                                     ("Meta,b" FN \\TEDIT.BOLD.SEL.ON)
-                                     ("Meta,B" FN \\TEDIT.BOLD.SEL.OFF)
-                                     ("Meta,i" FN \\TEDIT.ITALIC.SEL.ON)
-                                     ("Meta,I" FN \\TEDIT.ITALIC.SEL.OFF)
-                                     ("Meta,=" FN \\TEDIT.STRIKEOUT.SEL.ON)
-                                     ("Meta,+" FN \\TEDIT.STRIKEOUT.SEL.OFF)
-                                     ("Meta,-" FN \\TEDIT.UNDERLINE.SEL.ON)
-                                     ("Meta,_" FN \\TEDIT.UNDERLINE.SEL.OFF)
-                                     ("Meta,^" FN \\TEDIT.SUBSCRIPTSEL)
-                                     ("Meta,|" FN \\TEDIT.SUPERSCRIPTSEL)
-                                     ("Meta,SPACE" FN \\TEDIT.DEFAULTSSEL)
-                                     ("Meta,?" FN \\TEDIT.SHOWCARETLOOKS)
-                                     ("Meta,(" FN \\TEDIT.DK.INSERT-PARENS)
-                                     ("Meta,\"" FN \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES)
-                                     ("Meta,'" FN \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES))))
-        (P (FOR ENTRY IN \\TEDIT.DORADO.KEYS DO (SELECTQ (CADR ENTRY)
-                                                       (FN (TEDIT.SETFUNCTION (CAR ENTRY)
-                                                                  (CADDR ENTRY)))
-                                                       (TEDIT.SETSYNTAX (CAR ENTRY)
-                                                              (CADR ENTRY)))))))
-(DECLARE\: EVAL@COMPILE DONTCOPY 
-
-(FILESLOAD TEDIT-EXPORTS.ALL)
-)
-
-
-
-(* |;;| "Specialized functions for this module")
-
-(DEFINEQ
-
-(\\TEDIT.DK.ABORT
-  (LAMBDA (TEXTOBJ)
-    (TEDIT.GET TEXTOBJ)))
-
-(\\TEDIT.DK.INSERT-PARENS
-  (LAMBDA (TEXTOBJ TEXTSTREAM SEL)                           (* \; "Edited 28-Oct-87 19:42 by jds")
-
-    (LET ((CH1 (|fetch| CH# |of| SEL))
-          (CHLIM (|fetch| CHLIM |of| SEL)))
-         (TEDIT.INSERT TEXTSTREAM ")" CHLIM)
-         (TEDIT.INSERT TEXTSTREAM "(" CH1)
-         (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1))))))
-
-(\\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES
-  (LAMBDA (TEXTOBJ TEXTSTREAM SEL)                           (* \; "Edited 28-Oct-87 19:45 by jds")
-          
-          (* |;;| "Insert ASCII double-quotes (\") around the selection")
-
-    (LET ((CH1 (|fetch| CH# |of| SEL))
-          (CHLIM (|fetch| CHLIM |of| SEL)))
-         (TEDIT.INSERT TEXTSTREAM "\"" CHLIM)
-         (TEDIT.INSERT TEXTSTREAM "\"" CH1)
-         (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1))))))
-
-(\\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES
-  (LAMBDA (TEXTOBJ TEXTSTREAM SEL)                           (* \; "Edited 28-Oct-87 19:44 by jds")
-          
-          (* |;;| "Insert NS double quotes around the selection.")
-
-    (LET ((CH1 (|fetch| CH# |of| SEL))
-          (CHLIM (|fetch| CHLIM |of| SEL)))
-         (TEDIT.INSERT TEXTSTREAM (CHARCODE 0\,252)
-                CHLIM)
-         (TEDIT.INSERT TEXTSTREAM (CHARCODE 0\,272)
-                CH1)
-         (TEDIT.SETSEL TEXTSTREAM CH1 (+ 2 (- CHLIM CH1))))))
-)
-
-(RPAQQ \\TEDIT.DORADO.KEYS
-       (("Meta,x" EXPAND)
-        ("Meta,X" EXPAND)
-        ("Meta,c" FN \\TEDIT.CENTER.SEL)
-        ("Meta,C" FN \\TEDIT.CENTER.SEL.REV)
-        ("Meta,b" FN \\TEDIT.BOLD.SEL.ON)
-        ("Meta,B" FN \\TEDIT.BOLD.SEL.OFF)
-        ("Meta,i" FN \\TEDIT.ITALIC.SEL.ON)
-        ("Meta,I" FN \\TEDIT.ITALIC.SEL.OFF)
-        ("Meta,=" FN \\TEDIT.STRIKEOUT.SEL.ON)
-        ("Meta,+" FN \\TEDIT.STRIKEOUT.SEL.OFF)
-        ("Meta,-" FN \\TEDIT.UNDERLINE.SEL.ON)
-        ("Meta,_" FN \\TEDIT.UNDERLINE.SEL.OFF)
-        ("Meta,^" FN \\TEDIT.SUBSCRIPTSEL)
-        ("Meta,|" FN \\TEDIT.SUPERSCRIPTSEL)
-        ("Meta,SPACE" FN \\TEDIT.DEFAULTSSEL)
-        ("Meta,?" FN \\TEDIT.SHOWCARETLOOKS)
-        ("Meta,(" FN \\TEDIT.DK.INSERT-PARENS)
-        ("Meta,\"" FN \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES)
-        ("Meta,'" FN \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES)))
-
-(FOR ENTRY IN \\TEDIT.DORADO.KEYS DO (SELECTQ (CADR ENTRY)
-                                         (FN (TEDIT.SETFUNCTION (CAR ENTRY)
-                                                    (CADDR ENTRY)))
-                                         (TEDIT.SETSYNTAX (CAR ENTRY)
-                                                (CADR ENTRY))))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL (2626 4130 (\\TEDIT.DK.ABORT 2636 . 2703) (\\TEDIT.DK.INSERT-PARENS 2705 . 3092) (
-\\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES 3094 . 3586) (\\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES 3588 . 4128))
-)))
-STOP
diff --git a/obsolete/lispusers/TEDITDORADOKEYS.LCOM b/obsolete/lispusers/TEDITDORADOKEYS.LCOM
deleted file mode 100644
index d65bf602..00000000
Binary files a/obsolete/lispusers/TEDITDORADOKEYS.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/TEDITDORADOKEYS.TEDIT b/obsolete/lispusers/TEDITDORADOKEYS.TEDIT
deleted file mode 100644
index 3399430c..00000000
Binary files a/obsolete/lispusers/TEDITDORADOKEYS.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/TEDITKEY b/obsolete/lispusers/TEDITKEY
deleted file mode 100644
index a5761430..00000000
--- a/obsolete/lispusers/TEDITKEY
+++ /dev/null
@@ -1,1862 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
-
-(FILECREATED "14-Oct-2023 14:53:17" {WMEDLEY}<lispusers>TEDITKEY.;4 93014  
-
-      :EDIT-BY rmk
-
-      :CHANGES-TO (FNS \SEL.LINEDESC)
-
-      :PREVIOUS-DATE "24-Oct-2022 15:25:58" {WMEDLEY}<lispusers>TEDITKEY.;2)
-
-
-(* ; "
-Copyright (c) 1985-1987 by Xerox Corporation.
-")
-
-(PRETTYCOMPRINT TEDITKEYCOMS)
-
-(RPAQQ TEDITKEYCOMS
-       [(COMS 
-
-(* ;;; "This is the Lyric-and-later version of TEditKey")
-)
-        (COMS                                                (* ; 
-                                                             "functions for affecting the selection")
-              (FNS NTHCAR \TEXTOBJ.WINDEX \TK.PREVSCREEN \TK.UNDERLINE.SEL.ON \TK.UNDERLINE.SEL.OFF 
-                   \TK.BOLD.SEL.ON \TK.BOLD.SEL.OFF \TK.ITALIC.SEL.ON \TK.ITALIC.SEL.OFF 
-                   \TK.SMALLERSEL \TK.LARGERSEL \TK.SUPERSCRIPTSEL \TK.SUBSCRIPTSEL \TK.DEFAULTSSEL 
-                   \TK.DEL.WORD.FORWARD \TK.UCASE.SEL \TK.CAPITALISE.SEL \CAPITALISE \TK.LCASE.SEL)
-                                                             (* ; 
-                                             "functions for affecting the paralooks of the selection")
-              (FNS \TK.CENTER.SEL \TK.CENTER.SEL.REV \TK.NEST \TK.UNNEST))
-        (COMS                                                (* ; 
-                                 "functions for affecting (and displaying) the caret character looks")
-              (FNS \TK.SHOWCARETLOOKS \TK.BOLD.CARET.ON \TK.BOLD.CARET.OFF \TK.ITALIC.CARET.ON 
-                   \TK.ITALIC.CARET.OFF \TK.UNDERLINE.CARET.ON \TK.UNDERLINE.CARET.OFF 
-                   \TK.SUPERSCRIPT.CARET \TK.SUBSCRIPT.CARET \TK.SMALLER.CARET \TK.LARGER.CARET 
-                   \TK.DEFAULTS.CARET \TK.FONT1 \TK.FONT2 \TK.FONT3 \TK.SETCARETFONT \TK.FONT4 
-                   \TK.FONT5 \TK.FONT6 \TK.FONT7 \TK.FONT8)
-                                                             (* ; 
-                            "the functions which aren't currently used, which toggle the caret looks")
-              (FNS \TK.BOLDTOGGLE \TK.ITALICTOGGLE \TK.UNDERLINETOGGLE))
-        (COMS                                                (* ; 
-                                                           "functions dealing with the default looks")
-              (FNS \TK.SETDEFAULTLOOKS))
-        (COMS                                                (* ; 
-                                                        "functions for positioning within a document")
-              (FNS GOTONEXTTTYWINDOW \TK.NEXTLINE \TK.PREVLINE \TK.GOTODOCBEGIN \TK.GOTODOCEND 
-                   \TK.GOTOLINEBEGIN \TK.GOTOLINEEND \TK.PREVCHAR \TK.NEXTCHAR \TK.FORWARD.WORD 
-                   \TK.BACK.WORD \TK.SELECT.ALL))
-        (COMS                                                (* ; "other utilities")
-              (FNS \TK.FIND \TK.REDISPLAY \TK.DELLINEFORWARD \TK.OPENLINE \TK.DELCHARFORWARD 
-                   \TK.TRANSPOSECHARS))
-        (COMS                                                (* ; 
-                                                "little selection utilities etc., for building hacks")
-              (FNS \SEL.LIMIT \TK.SETFILEPTR.TO.CARET \SEL.LINEDESC)
-              (MACROS \SEL.LIMIT.FORWARD \TK.ONOROFF \LINEDESC.LAST.REAL.CHAR))
-        (COMS                                                (* ; "fns for the key interface itself")
-              (FNS \SHIFTACTION \ACTION TEDITKEY.INSTALL TEDITKEY.DEINSTALL \TK.ACTIONTOCHARCODE 
-                   \TK.BUILD.MENU \TK.HELP \TK.SETFONTINLOOKS WRITE.CHARDESC.AUX CHARDESC 
-                   TEDITKEY.CONFIGURE \TK.ADDKEY \TK.CHANGEKEY \TK.APPLYPENDING \TK.NTHFONT)
-                                                             (* ; "redefinition of system junk")
-              (FNS METASHIFT))
-        
-        (* ;; "(\TK.BOLDTOGGLE (##H ##h) 'toggle Bold caret looks') (\TK.ITALICTOGGLE (##i ##I) 'toggle Italic caret looks') (\TK.SUPERSCRIPT.CARET (##^) 'Superscript the caret looks') (\TK.SUBSCRIPT.CARET (##_) 'Subscript the caret looks')")
-
-        (FNS TEDIT.FULL.FIND)
-        [VARS \TK.WHITESPACE (TEDIT.INTERRUPTS `((%, (CHARCODE ^G)
-                                                     ERROR)
-                                                 (%, (CHARCODE ^C)
-                                                     HELP]
-        (CONSTANTS (\TK.WHITESPACE 22))
-        (INITVARS (TEDITKEY.VERBOSE T)
-               (TEDITKEY.METAKEY 'TAB)
-               (TEDITKEY.LOCKTOGGLEKEY NIL)
-               (TEDITKEY.NESTWIDTH 36)
-               (\TK.SIZEINCREMENT 2)
-               (TEDITKEY.OFFSETINCREMENT 3)
-               (TEDITKEY.FONTS '(TIMESROMAN HELVETICA GACHA MODERN CLASSIC TERMINAL SYMBOL HIPPO))
-               (TEDITKEY.FNKEYFLG T))
-        (MACROS METACODE CONTROLCODE LCMETACODE)
-        (INITVARS (\TK.SELKEY 'OPEN)
-               (\TK.PENDING))
-        [INITVARS [TEDITKEY.KEYBINDINGS `((\TK.FONT1 (%##1)
-                                                 %,
-                                                 (CONCAT "change to font " (\TK.NTHFONT 1)))
-                                          (\TK.FONT2 (%##2)
-                                                 %,
-                                                 (CONCAT "change to font " (\TK.NTHFONT 2)))
-                                          (\TK.FONT3 (%##3)
-                                                 %,
-                                                 (CONCAT "change to font " (\TK.NTHFONT 3)))
-                                          (\TK.FONT4 (%##4)
-                                                 %,
-                                                 (CONCAT "change to font " (\TK.NTHFONT 4)))
-                                          (\TK.FONT5 (%##5)
-                                                 %,
-                                                 (CONCAT "change to font " (\TK.NTHFONT 5)))
-                                          (\TK.FONT6 (%##6)
-                                                 %,
-                                                 (CONCAT "change to font " (\TK.NTHFONT 6)))
-                                          (\TK.FONT7 (%##7)
-                                                 %,
-                                                 (CONCAT "change to font " (\TK.NTHFONT 7)))
-                                          (\TK.FONT8 (%##8)
-                                                 %,
-                                                 (CONCAT "change to font " (\TK.NTHFONT 8)))
-                                          NIL
-                                          (\TK.DEFAULTS.CARET (%##/)
-                                                 "restore the default caret looks")
-                                          (\TK.SMALLER.CARET (%##9)
-                                                 "decrease the caret font size")
-                                          (\TK.LARGER.CARET (%##0)
-                                                 "increase the caret font size")
-                                          (\TK.SHOWCARETLOOKS (%##=)
-                                                 "display the current caret looks")
-                                          NIL
-                                          (\TK.REDISPLAY (%##R %##r)
-                                                 "Restore the display")
-                                          (\TK.HELP (%##?)
-                                                 "displays the current key bindings")
-                                          NIL
-                                          (\TK.PREVCHAR (^B ^b)
-                                                 "Back one character")
-                                          (\TK.NEXTCHAR (^F ^f)
-                                                 "Forward one character")
-                                          (\TK.FORWARD.WORD (%##F %##f)
-                                                 "Forward one word")
-                                          (\TK.BACK.WORD (%##B %##b)
-                                                 "Back one word")
-                                          (\TK.GOTOLINEBEGIN (^A ^a)
-                                                 "go to stArt of line")
-                                          (\TK.GOTOLINEEND (^E ^e)
-                                                 "go to End of line")
-                                          (\TK.PREVLINE (^P ^p)
-                                                 "go to Previous line")
-                                          (\TK.NEXTLINE (^N ^n)
-                                                 "go to Next line")
-                                          (\TK.GOTODOCBEGIN (%##<)
-                                                 "start of document")
-                                          (\TK.GOTODOCEND (%##>)
-                                                 "end of document")
-                                          (\TK.SELECT.ALL (%##S %##s)
-                                                 "Select whole document")
-                                          NIL
-                                          (\TK.DELLINEFORWARD (^K ^k)
-                                                 "Kill line")
-                                          (\TK.OPENLINE (^O ^o)
-                                                 "Open up blank line")
-                                          (\TK.DELCHARFORWARD (^D ^d)
-                                                 "Delete character forward")
-                                          (\TK.DEL.WORD.FORWARD (%##D %##d)
-                                                 "Delete word forward")
-                                          (\TK.TRANSPOSECHARS (^T ^t)
-                                                 "Transpose characters")
-                                          NIL NIL (\TK.NEST (|##[|)
-                                                         "indents margins (nest)")
-                                          (\TK.UNNEST (|##]|)
-                                                 "exdents margins (unnest)")
-                                          (\TK.CENTER.SEL (%##J %##j)
-                                                 "alter Justification")
-                                          (\TK.UCASE.SEL (%##U %##u)
-                                                 "Uppercasify selection")
-                                          (\TK.CAPITALISE.SEL (%##C %##c)
-                                                 "Capitalize selection")
-                                          (\TK.LCASE.SEL (%##L %##l)
-                                                 "Lowercasify selection")
-                                          (GET.OBJ.FROM.USER (%##O %##o)
-                                                 "insert Object"]
-               [TEDITKEY.DLION.KEYACTIONS `((STOP (%, (CHARCODE ^G)
-                                                      %,
-                                                      (CHARCODE ^C)
-                                                      NOLOCKSHIFT))
-                                            (OPEN (%, (CHARCODE 2,1)
-                                                      %,
-                                                      (CHARCODE 2,41)
-                                                      NOLOCKSHIFT))
-                                            (FONT FONTDOWN . FONTUP)
-                                            (KEYBOARD USERMODE1DOWN . USERMODE1UP]
-               (COMS 
-                     (* ;; "(TEDITKEY.FNKEYACTIONS (BQUOTE ((CENTER (, (CHARCODE ##^B), (CHARCODE ##^C))) (BOLD (, (CHARCODE ##^D), (CHARCODE ##^E) NOLOCKSHIFT)) (ITALICS (, (CHARCODE ##^F), (CHARCODE ##^G) NOLOCKSHIFT)) (UNDERLINE (, (CHARCODE ##^H), (CHARCODE ##^I) NOLOCKSHIFT)) (SUPERSCRIPT (, (CHARCODE ##^J), (CHARCODE ##^K) NOLOCKSHIFT)) (SUBSCRIPT (, (CHARCODE ##^L), (CHARCODE ##^N) NOLOCKSHIFT)) (LARGER (, (CHARCODE ##^O), (CHARCODE ##^P) NOLOCKSHIFT)) (DEFAULTS (, (CHARCODE ##^Q), (CHARCODE ##^R) NOLOCKSHIFT)) (BS (, (CHARCODE ^H), (CHARCODE ^D) NOLOCKSHIFT)))))")
-)
-               [TEDITKEY.DLION.KEYBINDINGS '(((\ACTION 'OPEN)
-                                              \TK.OPENLINE)
-                                             ((\ACTION 'HELP)
-                                              \TK.HELP)
-                                             ((\ACTION 'MARGINS)
-                                              \TK.NEST)
-                                             ((\SHIFTACTION 'MARGINS)
-                                              \TK.UNNEST)
-                                             ((\SHIFTACTION 'NEXT)
-                                              GOTONEXTTTYWINDOW]
-               [TEDITKEY.FNKEYBINDINGS '(((\ACTION 'DEFAULTS)
-                                          \TK.DEFAULTSSEL)
-                                         ((\SHIFTACTION 'DEFAULTS)
-                                          \TK.SETDEFAULTLOOKS]
-               (COMS 
-                     (* ;; "NOT NEEDED (TEDITKEY.DLION.KEYSYNTAX (QUOTE (((\ACTION (QUOTE NEXT)) NEXT) ((\ACTION (QUOTE UNDO)) UNDO) ((\ACTION (QUOTE BS)) CHARDELETE))))")
-)
-               [TEDITKEY.DORADO.KEYACTIONS `((BS (%, (CHARCODE ^H)
-                                                     %,
-                                                     (CHARCODE ^H)))
-                                             (BLANK-BOTTOM (%, (CHARCODE %##^A)
-                                                               %,
-                                                               (CHARCODE %##^A)))
-                                             (BLANK-TOP FONTDOWN . FONTUP)
-                                             (BLANK-MIDDLE USERMODE1DOWN . USERMODE1UP)
-                                             (CENTER (2,101 2,141 NOLOCKSHIFT))
-                                             (BOLD (2,102 2,142 NOLOCKSHIFT))
-                                             (ITALICS (2,103 2,143 NOLOCKSHIFT))
-                                             (UNDERLINE (2,106 2,146 NOLOCKSHIFT))
-                                             (SUPERSCRIPT (2,113 2,153 NOLOCKSHIFT))
-                                             (SUBSCRIPT (2,114 2,154 NOLOCKSHIFT))
-                                             (LARGER (2,110 2,150 NOLOCKSHIFT))
-                                             (DEFAULTS (2,115 2,155 NOLOCKSHIFT]
-               (TEDITKEY.DORADO.KEYSYNTAX '(((CHARCODE %##N)
-                                             NEXT)
-                                            ((CHARCODE %##n)
-                                             NEXT)
-                                            ((\ACTION 'BLANK-BOTTOM)
-                                             UNDO)
-                                            ((\ACTION 'BS)
-                                             CHARDELETE]
-        (P (TEDITKEY.INSTALL))
-        (P (\TK.BUILD.MENU))
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
-                                                                             (NLAML)
-                                                                             (LAMA METASHIFT])
-
-
-
-(* ;;; "This is the Lyric-and-later version of TEditKey")
-
-
-
-
-(* ; "functions for affecting the selection")
-
-(DEFINEQ
-
-(NTHCAR
-  [LAMBDA (LIST N)                                           (* gbn "10-Oct-85 20:54")
-    (CAR (NTH LIST N])
-
-(\TEXTOBJ.WINDEX
-  [LAMBDA (TEXTOBJ)                                          (* gbn "10-Oct-85 20:51")
-          
-          (* * returns the number which is the position in the list textobj%:\window 
-          indicating which window had the last selection in it.
-          This number is then an index into line descriptor lists etc.)
-
-    (bind (CURW _ (fetch SELWINDOW of TEXTOBJ)) for J from 1 as W in (fetch \WINDOW of TEXTOBJ)
-       until (EQ W CURW) do NIL finally (RETURN J])
-
-(\TK.PREVSCREEN
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "10-Oct-85 00:10")
-                                                             (* moves the selection up one line)
-    (PROG (THIS PREV)
-          
-          (* get the selection on the screen so that it has a line descriptor)
-
-          (TEDIT.NORMALIZECARET STREAM SEL)
-          (if [SETQ THIS (CAR (MKLIST (fetch L1 of SEL]
-              then                                           (* empty docs have no line descriptors)
-                   (SETQ PREV (fetch PREVLINE of THIS))
-                   [if (ZEROP (fetch CHARLIM of PREV))
-                       then 
-          
-          (* we need to back format because this is a fake line descriptor)
-
-                            (\BACKFORMAT (CAR (fetch LINES of TEXTOBJ))
-                                   TEXTOBJ
-                                   (fetch SELWINDOW of TEXTOBJ))
-                            (SETQ PREV (fetch PREVLINE of THIS)) 
-                                                             (* (SETQ PREV (replace PREVLINE of 
-                                                             THIS with (\FORMATLINE TEXTOBJ NIL
-                                                             (ADD1 (fetch CHARLIM of THIS))))))]
-                   (TEDIT.NORMALIZECARET STREAM (TEDIT.SETSEL STREAM
-                                                       (IMIN (IPLUS (fetch CHAR1 of PREV)
-                                                                    (IDIFFERENCE (\SEL.LIMIT SEL)
-                                                                           (fetch CHAR1 of THIS)))
-                                                             (fetch CHARLIM of PREV))
-                                                       0])
-
-(\TK.UNDERLINE.SEL.ON
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "19-Mar-85 12:01")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT4 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)
-        (\TK.UNDERLINE.CARET.ON TEXTSTREAM TEXTOBJ SEL))
-       (T (* do the real function of \tk.underlineon which happens when neither Keyboard 
-          nor font is held)
-          (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE ON) SEL])
-
-(\TK.UNDERLINE.SEL.OFF
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "19-Mar-85 12:01")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT4 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)
-        (\TK.UNDERLINE.CARET.OFF TEXTSTREAM TEXTOBJ SEL))
-       (T (* do the real function of \tk.underlineon which happens when neither Keyboard 
-          nor font is held)
-          (TEDIT.LOOKS TEXTSTREAM '(UNDERLINE OFF) SEL])
-
-(\TK.BOLD.SEL.ON
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "19-Mar-85 12:01")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT2 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)                              (* do the caret looks case)
-        (\TK.BOLD.CARET.ON TEXTSTREAM TEXTOBJ SEL))
-       (T (* do the real function of \tk.boldon which happens when neither Keyboard nor 
-          font is held)                                      (* acts on the selection)
-          (TEDIT.LOOKS TEXTSTREAM '(WEIGHT BOLD) SEL])
-
-(\TK.BOLD.SEL.OFF
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE)                  (* gbn "19-Mar-85 12:02")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT2 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)                              (* do the caret looks case)
-        (\TK.BOLD.CARET.OFF TEXTSTREAM TEXTOBJ SEL))
-       (T (* do the real function of \tk.boldon which happens when neither Keyboard nor 
-          font is held)                                      (* acts on the selection)
-          (TEDIT.LOOKS TEXTSTREAM '(WEIGHT MEDIUM) SEL])
-
-(\TK.ITALIC.SEL.ON
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "19-Mar-85 12:02")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT3 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)
-        (\TK.ITALIC.CARET.ON TEXTSTREAM TEXTOBJ SEL))
-       (T (TEDIT.LOOKS TEXTSTREAM '(SLOPE ITALIC) SEL])
-
-(\TK.ITALIC.SEL.OFF
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL CHARCODE)                  (* gbn "19-Mar-85 12:02")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT3 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)
-        (\TK.ITALIC.CARET.OFF TEXTSTREAM TEXTOBJ SEL))
-       (T (TEDIT.LOOKS TEXTSTREAM '(SLOPE REGULAR) SEL])
-
-(\TK.SMALLERSEL
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 21:47")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT7 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)                              (* do the caret looks case)
-        (\TK.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL))
-       (T (* do the real function of \TK.SUPERSCRIPTSEL which happens when neither 
-          Keyboard nor font is held)                         (* acts on the selection)
-          (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT (IMINUS \TK.SIZEINCREMENT))
-                 SEL])
-
-(\TK.LARGERSEL
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 21:47")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT7 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)                              (* do the caret looks case)
-        (\TK.LARGER.CARET TEXTSTREAM TEXTOBJ SEL))
-       (T (* do the real function of \TK.LARGER.SEL which happens when neither Keyboard 
-          nor font is held)                                  (* acts on the selection)
-          (TEDIT.LOOKS TEXTSTREAM (LIST 'SIZEINCREMENT \TK.SIZEINCREMENT)
-                 SEL])
-
-(\TK.SUPERSCRIPTSEL
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 21:56")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT5 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)                              (* do the caret looks case)
-        (\TK.SUPERSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL))
-       (T (* do the real function of \TK.SUPERSCRIPTSEL which happens when neither 
-          Keyboard nor font is held)                         (* acts on the selection)
-          (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT TEDITKEY.OFFSETINCREMENT)
-                 SEL])
-
-(\TK.SUBSCRIPTSEL
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 21:42")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT6 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)                              (* do the caret looks case)
-        (\TK.SUBSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL))
-       (T (* do the real function of \TK.SUPERSCRIPTSEL which happens when neither 
-          Keyboard nor font is held)                         (* acts on the selection)
-          (TEDIT.LOOKS TEXTSTREAM (LIST 'OFFSETINCREMENT (MINUS TEDITKEY.OFFSETINCREMENT))
-                 SEL])
-
-(\TK.DEFAULTSSEL
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 21:55")
-                                                             (* acts on the selection)
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT8 TEXTSTREAM TEXTOBJ SEL))
-       ((SHIFTDOWNP 'USERMODE1)                              (* do the caret looks case)
-        (\TK.DEFAULTS.CARET TEXTSTREAM TEXTOBJ SEL))
-       (T                                                    (* acts on the selection)
-          (PROG ((LOOKS (create CHARLOOKS using TEDIT.DEFAULT.CHARLOOKS)))
-                (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-                (TEDIT.LOOKS TEXTSTREAM LOOKS SEL])
-
-(\TK.DEL.WORD.FORWARD
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "20-Mar-85 00:45")
-          
-          (* * Deletes from here to the end of the first word Refers to the syntax 
-          classes of the characters according to the TEDIT.WORDBOUND.READTABLE)
-
-    (PROG (HERE)
-          
-          (* position the file ptr at the (character after the) caret of the selection)
-
-          (\TK.SETFILEPTR.TO.CARET TEXTSTREAM TEXTOBJ SEL)
-          
-          (* record this position as the beginning of the word
-          (to make the beginning of the selection))
-
-          (SETQ HERE (ADD1 (GETFILEPTR TEXTSTREAM)))         (* skip the whitespace)
-          (while [AND (NOT (EOFP TEXTSTREAM))
-                      (EQ \TK.WHITESPACE (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T]
-             do (BIN TEXTSTREAM))
-          
-          (* find out what syntax class the first letter of the word has.
-          The end of the word is marked by a change of syntax classes)
-
-          (if (NOT (EOFP TEXTSTREAM))
-              then (SETQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T)))
-                   (while [AND (NOT (EOFP TEXTSTREAM))
-                               (EQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T]
-                      do (BIN TEXTSTREAM)))
-          (TEDIT.SETSEL TEXTSTREAM HERE (ADD1 (IDIFFERENCE (GETFILEPTR TEXTSTREAM)
-                                                     HERE))
-                 'RIGHT)
-          (TEDIT.DELETE TEXTSTREAM)
-          (TEDIT.NORMALIZECARET TEXTOBJ])
-
-(\TK.UCASE.SEL
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "20-Mar-85 00:46")
-                                                             (* uppercasifies the selection)
-    (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL))
-           (POS (fetch CH# of SEL))
-           (LEN (fetch DCH of SEL))
-           (POINT (fetch POINT of SEL)))
-          (TEDIT.DELETE STREAM SEL)
-          (TEDIT.INSERT STREAM (U-CASE STR))
-          (TEDIT.SETSEL STREAM POS LEN POINT)
-          (TEDIT.NORMALIZECARET TEXTOBJ])
-
-(\TK.CAPITALISE.SEL
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "24-Feb-86 16:57")
-                                                             (* capitalises the selection)
-    (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL))
-           (POS (fetch (SELECTION CH#) of SEL))
-           (LEN (fetch (SELECTION DCH) of SEL))
-           (POINT (fetch (SELECTION POINT) of SEL)))
-          (TEDIT.DELETE STREAM SEL)
-          (TEDIT.INSERT STREAM (\CAPITALISE STR))
-          (TEDIT.SETSEL STREAM POS LEN POINT)
-          (TEDIT.NORMALIZECARET TEXTOBJ])
-
-(\CAPITALISE
-  [LAMBDA (STR)                                              (* gbn "24-Feb-86 16:56")
-          
-          (* * capitalises a string)
-
-    (SELECTQ (NCHARS STR)
-        (0 STR)
-        (1 (U-CASE STR))
-        (CONCAT (U-CASE (NTHCHAR STR 1))
-               (L-CASE (SUBSTRING STR 2])
-
-(\TK.LCASE.SEL
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "20-Mar-85 00:46")
-                                                             (* uppercasifies the selection)
-    (PROG ((STR (TEDIT.SEL.AS.STRING STREAM SEL))
-           (POS (fetch CH# of SEL))
-           (LEN (fetch DCH of SEL))
-           (POINT (fetch POINT of SEL)))
-          (TEDIT.DELETE STREAM SEL)
-          (TEDIT.INSERT STREAM (L-CASE STR))
-          (TEDIT.SETSEL STREAM POS LEN POINT)
-          (TEDIT.NORMALIZECARET TEXTOBJ])
-)
-
-
-
-(* ; "functions for affecting the paralooks of the selection")
-
-(DEFINEQ
-
-(\TK.CENTER.SEL
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Feb-85 18:17")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT1 TEXTSTREAM TEXTOBJ SEL))
-       (T                                                    (* makes the current paragraph 
-                                                             centered)
-          (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS (SAVECH# (fetch CH# of SEL))
-                       (SAVEDCH (fetch DCH of SEL)))
-                (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ)
-                   do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA))
-                      (SETQ OLDQUAD (LISTGET LOOKS 'QUAD))
-                      [SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT JUSTIFIED CENTERED LEFT]
-                      (LISTPUT LOOKS 'QUAD NEWQUAD)
-                      (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1))
-                      (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL)
-                      (push NEWQUADS NEWQUAD))
-                (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH)
-                (if TEDITKEY.VERBOSE
-                    then (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS)
-                                T])
-
-(\TK.CENTER.SEL.REV
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn " 7-Jun-85 21:34")
-    (COND
-       ((SHIFTDOWNP 'FONT)
-        (\TK.FONT1 TEXTSTREAM TEXTOBJ SEL))
-       (T (* * acts like center.sel but cycles in the opposite direction)
-          (PROG (LOOKS OLDQUAD NEWQUAD NEWQUADS (SAVECH# (fetch CH# of SEL))
-                       (SAVEDCH (fetch DCH of SEL)))
-                (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ)
-                   do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA))
-                      (SETQ OLDQUAD (LISTGET LOOKS 'QUAD))
-                      [SETQ NEWQUAD (CADR (MEMB OLDQUAD (CONSTANT '(LEFT CENTERED JUSTIFIED LEFT]
-                      (LISTPUT LOOKS 'QUAD NEWQUAD)
-                      (SETQ PARASEL (TEDIT.SETSEL TEXTSTREAM PARA 1))
-                      (TEDIT.PARALOOKS TEXTSTREAM LOOKS PARASEL)
-                      (push NEWQUADS NEWQUAD))
-                (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH)
-                (if TEDITKEY.VERBOSE
-                    then (TEDIT.PROMPTPRINT TEXTSTREAM (DREVERSE NEWQUADS)
-                                T])
-
-(\TK.NEST
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Feb-85 18:24")
-    (PROG (LOOKS (SAVECH# (fetch CH# of SEL))
-                 (SAVEDCH (fetch DCH of SEL)))
-          (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ)
-             do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA))
-                (LISTPUT LOOKS 'LEFTMARGIN (IPLUS (LISTGET LOOKS 'LEFTMARGIN)
-                                                  TEDITKEY.NESTWIDTH))
-                (LISTPUT LOOKS '1STLEFTMARGIN (IPLUS (LISTGET LOOKS '1STLEFTMARGIN)
-                                                     TEDITKEY.NESTWIDTH))
-                (LISTPUT LOOKS 'RIGHTMARGIN (IMAX 0 (IDIFFERENCE (LISTGET LOOKS 'RIGHTMARGIN)
-                                                           TEDITKEY.NESTWIDTH)))
-                (TEDIT.SETSEL TEXTSTREAM PARA 1)
-                (TEDIT.PARALOOKS TEXTOBJ LOOKS))
-          (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH])
-
-(\TK.UNNEST
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Feb-85 18:26")
-    (PROG (LOOKS RIGHT (SAVECH# (fetch CH# of SEL))
-                 (SAVEDCH (fetch DCH of SEL)))
-          (for PARA in (\PARAS.IN.SEL SEL TEXTOBJ)
-             do (SETQ LOOKS (TEDIT.GET.PARALOOKS TEXTSTREAM PARA))
-                (LISTPUT LOOKS 'LEFTMARGIN (IMAX (IDIFFERENCE (LISTGET LOOKS 'LEFTMARGIN)
-                                                        TEDITKEY.NESTWIDTH)
-                                                 0))
-                (LISTPUT LOOKS '1STLEFTMARGIN (IMAX (IDIFFERENCE (LISTGET LOOKS '1STLEFTMARGIN)
-                                                           TEDITKEY.NESTWIDTH)
-                                                    0))
-                (SETQ RIGHT (LISTGET LOOKS 'RIGHTMARGIN))
-                (if (NOT (ZEROP RIGHT))
-                    then (LISTPUT LOOKS 'RIGHTMARGIN (IPLUS (LISTGET LOOKS 'RIGHTMARGIN)
-                                                            TEDITKEY.NESTWIDTH)))
-                (TEDIT.SETSEL TEXTSTREAM PARA 1)
-                (TEDIT.PARALOOKS TEXTOBJ LOOKS))
-          (TEDIT.SETSEL TEXTSTREAM SAVECH# SAVEDCH])
-)
-
-
-
-(* ; "functions for affecting (and displaying) the caret character looks")
-
-(DEFINEQ
-
-(\TK.SHOWCARETLOOKS
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "30-Jan-85 16:06")
-          
-          (* * comment)
-
-    (PROG ((LOOKS (fetch CARETLOOKS of TEXTOBJ)))
-          (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT (\TK.DESCRIBEFONT (fetch CLFONT of LOOKS))
-                                               (if (AND (fetch CLOFFSET of LOOKS)
-                                                        (NEQ (fetch CLOFFSET of LOOKS)
-                                                             0))
-                                                   then (CONCAT " offset " (fetch CLOFFSET
-                                                                              of LOOKS))
-                                                 else "")
-                                               (if (fetch CLOLINE of LOOKS)
-                                                   then " overlined"
-                                                 else "")
-                                               (if (fetch CLULINE of LOOKS)
-                                                   then " underlined"
-                                                 else ""))
-                 T)
-          (RETURN])
-
-(\TK.BOLD.CARET.ON
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 20:54")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLBOLD of LOOKS with T)
-          (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS)
-              then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-                   (if TEDITKEY.VERBOSE
-                       then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-                   (RETURN)
-            else (RETURN])
-
-(\TK.BOLD.CARET.OFF
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 20:54")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLBOLD of LOOKS with NIL)
-          (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS)
-              then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-                   (if TEDITKEY.VERBOSE
-                       then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-                   (RETURN)
-            else (RETURN])
-
-(\TK.ITALIC.CARET.ON
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 22:20")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLITAL of LOOKS with T)
-          (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS)
-              then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-                   (if TEDITKEY.VERBOSE
-                       then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-                   (RETURN)
-            else (RETURN])
-
-(\TK.ITALIC.CARET.OFF
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 22:19")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLITAL of LOOKS with NIL)
-          (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS)
-              then (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-                   (if TEDITKEY.VERBOSE
-                       then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-                   (RETURN)
-            else (RETURN])
-
-(\TK.UNDERLINE.CARET.ON
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 17:59")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLULINE of LOOKS with T)
-          (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-          (if TEDITKEY.VERBOSE
-              then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-          (RETURN])
-
-(\TK.UNDERLINE.CARET.OFF
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 18:01")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLULINE of LOOKS with NIL)
-          (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-          (if TEDITKEY.VERBOSE
-              then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-          (RETURN])
-
-(\TK.SUPERSCRIPT.CARET
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 22:25")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (if (fetch CLOFFSET of LOOKS)
-              then (add (fetch CLOFFSET of LOOKS)
-                        TEDITKEY.OFFSETINCREMENT)
-            else (replace CLOFFSET of LOOKS with TEDITKEY.OFFSETINCREMENT))
-          (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-          (if TEDITKEY.VERBOSE
-              then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-          (RETURN])
-
-(\TK.SUBSCRIPT.CARET
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 22:26")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (if (fetch CLOFFSET of LOOKS)
-              then (add (fetch CLOFFSET of LOOKS)
-                        (IMINUS TEDITKEY.OFFSETINCREMENT))
-            else (replace CLOFFSET of LOOKS with (IMINUS TEDITKEY.OFFSETINCREMENT)))
-          (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-          (if TEDITKEY.VERBOSE
-              then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-          (RETURN])
-
-(\TK.SMALLER.CARET
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 21:45")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLSIZE of LOOKS with (IMAX 4 (IDIFFERENCE (fetch CLSIZE of LOOKS)
-                                                       2)))
-          (if (NOT (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS))
-              then (RETURN))
-          (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-          (if TEDITKEY.VERBOSE
-              then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-          (RETURN])
-
-(\TK.LARGER.CARET
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 22:37")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLSIZE of LOOKS with (IPLUS \TK.SIZEINCREMENT (fetch CLSIZE of LOOKS)))
-          (if (NOT (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS))
-              then (RETURN))
-          (TEDIT.CARETLOOKS TEXTSTREAM LOOKS)
-          (if TEDITKEY.VERBOSE
-              then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-          (RETURN])
-
-(\TK.DEFAULTS.CARET
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 21:54")
-    (PROGN (TEDIT.CARETLOOKS TEXTSTREAM (create CHARLOOKS using TEDIT.DEFAULT.CHARLOOKS))
-           (if TEDITKEY.VERBOSE
-               then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL])
-
-(\TK.FONT1
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Jan-85 17:39")
-    (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 1])
-
-(\TK.FONT2
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Jan-85 17:43")
-    (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 2])
-
-(\TK.FONT3
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Jan-85 17:40")
-    (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 3])
-
-(\TK.SETCARETFONT
-  [LAMBDA (TEXTOBJ FONTNAME)                                 (* gbn "19-Mar-85 12:02")
-          
-          (* temporary hack. If this function is called when the keyboard shift is down, 
-          then it refers to the caret looks, otherwise the selection)
-
-    (if (SHIFTDOWNP 'USERMODE1)
-        then [PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-                   (replace CLNAME of LOOKS with FONTNAME)
-                   (if (\TK.SETFONTINLOOKS TEXTOBJ LOOKS)
-                       then 
-          
-          (* we found the font, install it as the caret font and tell the user)
-
-                            (if TEDITKEY.VERBOSE
-                                then (TEDIT.PROMPTPRINT TEXTOBJ FONTNAME T))
-                            (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS]
-      else (TEDIT.LOOKS TEXTSTREAM (LIST 'FAMILY FONTNAME)
-                  SEL])
-
-(\TK.FONT4
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Jan-85 17:40")
-    (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 4])
-
-(\TK.FONT5
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Jan-85 17:41")
-    (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 5])
-
-(\TK.FONT6
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Jan-85 17:41")
-    (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 6])
-
-(\TK.FONT7
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Jan-85 17:42")
-    (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 7])
-
-(\TK.FONT8
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Jan-85 17:43")
-    (\TK.SETCARETFONT TEXTOBJ (CAR (NTH TEDITKEY.FONTS 8])
-)
-
-
-
-(* ; "the functions which aren't currently used, which toggle the caret looks")
-
-(DEFINEQ
-
-(\TK.BOLDTOGGLE
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 20:54")
-          
-          (* * toggles boldness in the caret looks)
-
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLBOLD of LOOKS with (NOT (fetch CLBOLD of LOOKS)))
-          (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS)
-              then (if TEDITKEY.VERBOSE
-                       then (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "bold: "
-                                                                 (\TK.ONOROFF (fetch CLBOLD
-                                                                                 of LOOKS)))
-                                   T))
-                   (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS))
-            else (RETURN])
-
-(\TK.ITALICTOGGLE
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Jan-85 19:23")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLITAL of LOOKS with (NOT (fetch CLITAL of LOOKS)))
-          (if (\TK.SETFONTINLOOKS TEXTSTREAM LOOKS)
-              then (if TEDITKEY.VERBOSE
-                       then (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "italic: "
-                                                                 (\TK.ONOROFF (fetch CLITAL
-                                                                                 of LOOKS)))
-                                   T))
-                   (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS))
-            else (RETURN])
-
-(\TK.UNDERLINETOGGLE
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "27-Jan-85 19:23")
-    (PROG [(LOOKS (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-          (replace CLULINE of LOOKS with (NOT (fetch CLULINE of LOOKS)))
-          (if TEDITKEY.VERBOSE
-              then (TEDIT.PROMPTPRINT TEXTSTREAM (CONCAT "underline: " (\TK.ONOROFF (fetch CLULINE
-                                                                                       of LOOKS)))
-                          T))
-          (RETURN (TEDIT.CARETLOOKS TEXTSTREAM LOOKS])
-)
-
-
-
-(* ; "functions dealing with the default looks")
-
-(DEFINEQ
-
-(\TK.SETDEFAULTLOOKS
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "16-Feb-85 23:00")
-          
-          (* * sets TEDIT.DEFAULT.CHARLOOKS to have the looks of the current selection)
-
-    (PROG NIL
-          (SETQ TEDIT.DEFAULT.CHARLOOKS (COPY (fetch CARETLOOKS of TEXTOBJ)))
-          (if TEDITKEY.VERBOSE
-              then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL))
-          (RETURN])
-)
-
-
-
-(* ; "functions for positioning within a document")
-
-(DEFINEQ
-
-(GOTONEXTTTYWINDOW
-  [LAMBDA NIL                                                (* gbn " 7-May-85 16:19")
-          
-          (* * puts the tty in the next appropriate process in the chain)
-
-    (PROG ((CURRENT (TTY.PROCESS)))
-          (SETQ CANDIDATES (LIST NIL))
-          [MAP.PROCESSES (FUNCTION (LAMBDA (PROC)
-                                     (PROG (W)
-                                           (if (AND (SETQ W (PROCESSPROP PROC 'WINDOW))
-                                                    (OPENWP W)
-                                                    (WINDOWPROP W 'PROCESS))
-                                               then (NCONC1 CANDIDATES PROC]
-          (SETQ NEW (CDR (MEMBER CURRENT CANDIDATES)))
-          (SETQ NEW (if NEW
-                        then (CAR NEW)
-                      else (CADR CANDIDATES)))
-          (TTY.PROCESS NEW)
-          (FLASHWINDOW (PROCESSPROP NEW 'WINDOW)
-                 1 1 GRAYSHADE)                              (* for (PROC _ CURRENT) repeatwhile
-                                                             (NEQ PROC CURRENT) do
-                                                             (SETQ W (PROCESSPROP
-                                                             (SETQ PROC (fetch NEXTPROCHANDLE of 
-                                                             PROC)) (QUOTE WINDOW)))
-                                                             (PRINTOUT T (PROCESSPROP PROC
-                                                             (QUOTE NAME))) (if (AND W
-                                                             (OPENWP W) (WINDOWPROP W
-                                                             (QUOTE PROCESS))) then
-                                                             (* this window would probably be 
-                                                             willing to take the tty if clicked in, 
-                                                             so give the process the tty)
-                                                             (TTY.PROCESS PROC) (FLASHWINDOW W 1 
-                                                             NIL GRAYSHADE) (RETURN)))
-      ])
-
-(\TK.NEXTLINE
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "10-Oct-85 22:47")
-                                                             (* moves the selection down one line)
-    (PROG (THIS NEXT)
-          
-          (* get the selection on the screen so that it has a line descriptor)
-
-          (TEDIT.NORMALIZECARET STREAM SEL)
-          (SETQ THIS (\SEL.LINEDESC SEL))
-          (if THIS
-              then 
-          
-          (* an empty doc has no line descriptors, even after normalizing)
-
-                   (SETQ NEXT (fetch NEXTLINE of THIS))
-                   [if (NOT NEXT)
-                       then                                  (* there isn't already a descriptor 
-                                                             for this line)
-                            (SETQ NEXT (replace NEXTLINE of THIS
-                                          with (\FORMATLINE TEXTOBJ NIL (ADD1 (fetch CHARLIM
-                                                                                 of THIS]
-                   (if NEXT
-                       then 
-          
-          (* if there are no more characters, then there still may not be a descriptor 
-          when we call \formatline)
-
-                            (TEDIT.NORMALIZECARET STREAM
-                                   (TEDIT.SETSEL STREAM (IMIN (IPLUS (fetch CHAR1 of NEXT)
-                                                                     (IDIFFERENCE (\SEL.LIMIT SEL)
-                                                                            (fetch CHAR1 of THIS)))
-                                                              (ADD1 (\LINEDESC.LAST.REAL.CHAR NEXT)))
-                                          0
-                                          'LEFT])
-
-(\TK.PREVLINE
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "10-Oct-85 22:15")
-                                                             (* moves the selection up one line)
-    (PROG (THIS PREV)
-          
-          (* get the selection on the screen so that it has a line descriptor)
-
-          (TEDIT.NORMALIZECARET STREAM SEL)
-          (if (SETQ THIS (\SEL.LINEDESC SEL))
-              then                                           (* empty docs have no line descriptors)
-                   (SETQ PREV (fetch PREVLINE of THIS))
-                   [if (ZEROP (fetch CHARLIM of PREV))
-                       then 
-          
-          (* we need to back format because this is a fake line descriptor)
-
-                            [\BACKFORMAT (NTHCAR (fetch LINES of TEXTOBJ)
-                                                (\TEXTOBJ.WINDEX TEXTOBJ))
-                                   TEXTOBJ
-                                   (fetch PTOP of (DSPCLIPPINGREGION NIL (fetch SELWINDOW
-                                                                            of TEXTOBJ]
-                            (SETQ PREV (fetch PREVLINE of THIS)) 
-                                                             (* (SETQ PREV (replace PREVLINE of 
-                                                             THIS with (\FORMATLINE TEXTOBJ NIL
-                                                             (ADD1 (fetch CHARLIM of THIS))))))]
-                   (TEDIT.NORMALIZECARET STREAM (TEDIT.SETSEL STREAM
-                                                       (IMIN (IPLUS (fetch CHAR1 of PREV)
-                                                                    (IDIFFERENCE (\SEL.LIMIT SEL)
-                                                                           (fetch CHAR1 of THIS)))
-                                                             (fetch CHARLIM of PREV))
-                                                       0])
-
-(\TK.GOTODOCBEGIN
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "13-Dec-84 11:24")
-                                                             (* positions at the beginning of a 
-                                                             document)
-    (TEDIT.SETSEL STREAM 0 0)
-    (TEDIT.NORMALIZECARET TEXTOBJ])
-
-(\TK.GOTODOCEND
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn " 7-Jun-85 16:32")
-                                                             (* positions at the end of a document)
-    (TEDIT.SETSEL STREAM (ADD1 (fetch TEXTLEN of TEXTOBJ))
-           0
-           'LEFT)
-    (TEDIT.NORMALIZECARET STREAM])
-
-(\TK.GOTOLINEBEGIN
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "11-Mar-85 15:04")
-          
-          (* * positions the cursor at the beginning of line)
-
-    (PROG (CH)
-          (TEDIT.NORMALIZECARET TEXTOBJ SEL)
-          (SETQ CH (fetch CHAR1 of (\SEL.LINEDESC SEL)))     (* (if (fetch CR\END of
-                                                             (fetch L1 of SEL)) then
-                                                             (* there is a CR at the end of this 
-                                                             line, we want to position before it)
-                                                             (SETQ CH (SUB1 CH))))
-          (TEDIT.SETSEL TEXTSTREAM CH 0 'LEFT])
-
-(\TK.GOTOLINEEND
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn " 7-Jun-85 15:47")
-          
-          (* * positions the cursor at the end of line)
-
-    (PROG ((POINT 'RIGHT)
-           LN)
-          (TEDIT.NORMALIZECARET TEXTOBJ SEL)
-          (if (SETQ LN (\SEL.LINEDESC SEL))
-              then                                           (* empty docs have no linedescriptors)
-                   (SETQ CH (fetch CHARLIM of LN))
-                   (if (fetch CR\END of LN)
-                       then 
-          
-          (* there is not a CR at the end of this line, we want to position to the right 
-          of the last char)
-
-                            (SETQ POINT 'LEFT))
-                   (TEDIT.SETSEL TEXTSTREAM CH 1 POINT])
-
-(\TK.PREVCHAR
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "19-Mar-85 12:16")
-                                                             (* moves the selection back one char)
-    (PROG NIL
-          (TEDIT.SETSEL STREAM (IMAX 0 (SUB1 (\SEL.LIMIT.FORWARD SEL)))
-                 0
-                 'LEFT)
-          
-          (* I don't think this should be necessary, but there are cases where the caret 
-          is not normalised)
-
-          (TEDIT.NORMALIZECARET TEXTOBJ SEL])
-
-(\TK.NEXTCHAR
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "20-Mar-85 00:48")
-                                                             (* moves the selection back one char)
-    (PROG NIL
-          
-          (* Note%: addition. does *not* distribute with Min Do not pessimize this!)
-
-          (TEDIT.SETSEL STREAM (IMIN (ADD1 (fetch TEXTLEN of TEXTOBJ))
-                                     (ADD1 (\SEL.LIMIT.FORWARD SEL)))
-                 0
-                 'LEFT)
-          (TEDIT.NORMALIZECARET TEXTOBJ])
-
-(\TK.FORWARD.WORD
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "20-Mar-85 00:48")
-          
-          (* * moves the caret one word forward. Refers to the syntax classes of the 
-          characters according to the TEDIT.WORDBOUND.READTABLE)
-
-    (PROG (HERE)
-          
-          (* position the file ptr at the (character after the) caret of the selection)
-
-          (\TK.SETFILEPTR.TO.CARET TEXTSTREAM TEXTOBJ SEL)   (* skip the whitespace)
-          (while [AND (NOT (EOFP TEXTSTREAM))
-                      (EQ \TK.WHITESPACE (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T]
-             do (BIN TEXTSTREAM))
-          
-          (* record this position as the beginning of the word
-          (to make the beginning of the selection))
-
-          (SETQ HERE (ADD1 (GETFILEPTR TEXTSTREAM)))
-          
-          (* find out what syntax class the first letter of the word has.
-          The end of the word is marked by a change of syntax classes)
-
-          (if (NOT (EOFP TEXTSTREAM))
-              then (SETQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T)))
-                   (while [AND (NOT (EOFP TEXTSTREAM))
-                               (EQ CLASS (TEDIT.WORDGET (\PEEKBIN TEXTSTREAM T]
-                      do (BIN TEXTSTREAM)))
-          (TEDIT.SETSEL TEXTSTREAM HERE (ADD1 (IDIFFERENCE (GETFILEPTR TEXTSTREAM)
-                                                     HERE))
-                 'RIGHT)
-          (TEDIT.NORMALIZECARET TEXTOBJ])
-
-(\TK.BACK.WORD
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "20-Mar-85 00:49")
-          
-          (* * moves the caret one word back Refers to the syntax classes of the 
-          characters according to the TEDIT.WORDBOUND.READTABLE)
-
-    (PROG (HERE)
-          
-          (* position the file ptr at the (character after the) caret of the selection)
-
-          (\TK.SETFILEPTR.TO.CARET TEXTSTREAM TEXTOBJ SEL)   (* skip the whitespace)
-          (while [AND (NOT (ZEROP (GETFILEPTR TEXTSTREAM)))
-                      (EQ \TK.WHITESPACE (TEDIT.WORDGET (\BACKPEEKBIN TEXTSTREAM T]
-             do (\BACKBIN TEXTSTREAM))
-          
-          (* record this position as the beginning of the word
-          (to make the beginning of the selection))
-
-          (SETQ HERE (GETFILEPTR TEXTSTREAM))
-          
-          (* find out what syntax class the last letter of the word has.
-          The end of the word is marked by a change of syntax classes)
-
-          (if (NOT (ZEROP (GETFILEPTR TEXTSTREAM)))
-              then (SETQ CLASS (TEDIT.WORDGET (\BACKPEEKBIN TEXTSTREAM T)))
-                   (while [AND (NOT (ZEROP (GETFILEPTR TEXTSTREAM)))
-                               (EQ CLASS (TEDIT.WORDGET (\BACKPEEKBIN TEXTSTREAM T]
-                      do (\BACKBIN TEXTSTREAM)))
-          (TEDIT.SETSEL TEXTSTREAM (ADD1 (GETFILEPTR TEXTSTREAM))
-                 (IDIFFERENCE HERE (GETFILEPTR TEXTSTREAM))
-                 'LEFT)
-          (TEDIT.NORMALIZECARET TEXTOBJ])
-
-(\TK.SELECT.ALL
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "24-Feb-86 17:11")
-                                                             (* positions at the end of a document)
-    (TEDIT.SETSEL STREAM 0 (ADD1 (fetch TEXTLEN of TEXTOBJ))
-           'LEFT])
-)
-
-
-
-(* ; "other utilities")
-
-(DEFINEQ
-
-(\TK.FIND
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "10-Dec-84 12:38")
-          
-          (* just calls the normal tedit.find starting at the right of the current 
-          selection)
-
-    (TEDIT.FULL.FIND TEXTSTREAM])
-
-(\TK.REDISPLAY
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "12-Mar-85 14:27")
-          
-          (* * simply redisplays the window in question.)
-
-    (\TEDIT.REPAINTFN (CAR (MKATOM (fetch \WINDOW of TEXTOBJ])
-
-(\TK.DELLINEFORWARD
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "13-Dec-84 11:56")
-          
-          (* deletes from the caret to the end of this line)
-
-    (PROG (HERE DESC)
-          (TEDIT.NORMALIZECARET TEXTOBJ)
-          (SETQ HERE (\SEL.LIMIT.FORWARD SEL))
-          (SETQ DESC (\SEL.LINEDESC SEL))
-          (SETQ SEL (TEDIT.SETSEL STREAM HERE (IDIFFERENCE (fetch CHARLIM of DESC)
-                                                     HERE)))
-          (TEDIT.DELETE STREAM SEL])
-
-(\TK.OPENLINE
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "30-Jan-85 18:36")
-    (TEDIT.INSERT STREAM (CONSTANT (CHARCODE EOL)))
-    (\TK.PREVCHAR STREAM TEXTOBJ SEL])
-
-(\TK.DELCHARFORWARD
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "20-Mar-85 00:50")
-          
-          (* * deletes one character forward from the caret)
-
-    (PROG (HERE)
-          (SETQ SEL (TEDIT.SETSEL STREAM (\SEL.LIMIT.FORWARD SEL)
-                           1))
-          (TEDIT.DELETE STREAM SEL)
-          (TEDIT.NORMALIZECARET TEXTOBJ])
-
-(\TK.TRANSPOSECHARS
-  [LAMBDA (STREAM TEXTOBJ SEL)                               (* gbn "20-Mar-85 00:51")
-          
-          (* * transposes the two characters on either side of the point, unless it is 
-          the end of a line, in which case it transposes the two characters before the 
-          point)
-
-    (PROG ((KEEPCHARPOS (\SEL.LIMIT.FORWARD SEL))
-           KEEPCHAR LINEDESC)
-          (TEDIT.NORMALIZECARET TEXTOBJ SEL)
-          
-          (* get the line that the point of the selection is on)
-
-          (SETQ LINEDESC (\SEL.LINEDESC SEL))
-          (if (ILESSP (\LINEDESC.LAST.REAL.CHAR LINEDESC)
-                     KEEPCHARPOS)
-              then 
-          
-          (* the point is after the last real char on this line, so transpose the two 
-          before the point.)
-
-                   (add KEEPCHARPOS -1))
-          (SETQ KEEPCHAR (TEDIT.SEL.AS.STRING STREAM (TEDIT.SETSEL STREAM KEEPCHARPOS 1)))
-          (if (AND (IGREATERP KEEPCHARPOS 1)
-                   (IGEQ (fetch TEXTLEN of TEXTOBJ)
-                         KEEPCHARPOS))
-              then (TEDIT.DELETE STREAM)
-                   (TEDIT.INSERT STREAM KEEPCHAR (SUB1 KEEPCHARPOS))
-                   (TEDIT.SETSEL STREAM KEEPCHARPOS 1 'RIGHT))
-          (TEDIT.NORMALIZECARET TEXTOBJ SEL])
-)
-
-
-
-(* ; "little selection utilities etc., for building hacks")
-
-(DEFINEQ
-
-(\SEL.LIMIT
-  [LAMBDA (SEL)                                              (* gbn " 8-Mar-85 12:58")
-          
-          (* returns the character that delimits this selection.
-          The first char if the point is left else the last)
-
-    (if (EQ (fetch POINT of SEL)
-            'LEFT)
-        then (fetch CH# of SEL)
-      else (SUB1 (fetch CHLIM of SEL])
-
-(\TK.SETFILEPTR.TO.CARET
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "23-Feb-85 15:24")
-          
-          (* * makes sure that the fileptr is positioned at character on the right of the 
-          CARET of the selection)
-          
-          (* NOTE THAT FILEPTR's are one less than the corresponding char# in a sel)
-
-    (SETFILEPTR TEXTSTREAM (SUB1 (\SEL.LIMIT.FORWARD SEL])
-
-(\SEL.LINEDESC
-  [LAMBDA (SEL)                                              (* ; "Edited 14-Oct-2023 14:53 by rmk")
-                                                             (* ; "Edited 24-Oct-2022 15:24 by rmk")
-                                                             (* gbn "10-Oct-85 20:57")
-
-(* ;;; "Returns the line descriptor of the point of the selection in the last selected window")
-
-    (NTHCAR (if (EQ (fetch (SELECTION POINT) of SEL)
-                    'LEFT)
-                then (fetch (SELECTION L1) of SEL)
-              else (fetch (SELECTION LN) of SEL))
-           (\TEXTOBJ.WINDEX (fetch (SELECTION SELTEXTOBJ) of SEL])
-)
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \SEL.LIMIT.FORWARD MACRO [LAMBDA (SEL)             (* gbn "13-Dec-84 11:43")
-                                                             (* returns the character in front of 
-                                                             the caret (ch# for left and chlim for 
-                                                             right))
-                                     (if (EQ (fetch POINT of SEL)
-                                             'LEFT)
-                                         then (fetch CH# of SEL)
-                                       else (fetch CHLIM of SEL])
-
-(PUTPROPS \TK.ONOROFF MACRO [LAMBDA (FLG)
-                              (if FLG
-                                  then "on"
-                                else "off"])
-
-(PUTPROPS \LINEDESC.LAST.REAL.CHAR MACRO [LAMBDA (LINEDESC)
-                                           (if (fetch CR\END of LINEDESC)
-                                               then          (* there is a CR at the end so the 
-                                                             last real char CHLIM-1)
-                                                    (SUB1 (fetch CHARLIM of LINEDESC))
-                                             else (fetch CHARLIM of LINEDESC])
-)
-
-
-
-(* ; "fns for the key interface itself")
-
-(DEFINEQ
-
-(\SHIFTACTION
-  [LAMBDA (KEYNAME)                                          (* gbn "16-Feb-85 16:55")
-          
-          (* returns the character code generated by this keyname when typed shifted)
-
-    (CADAR (KEYACTION KEYNAME])
-
-(\ACTION
-  [LAMBDA (KEYNAME)                                          (* gbn "16-Feb-85 16:54")
-          
-          (* RETURNS THE CHARACTER CODE GENERATED BY THIS KEYNAME WHEN TYPED UNSHIFTED)
-
-    (CAAR (KEYACTION KEYNAME])
-
-(TEDITKEY.INSTALL
-  [LAMBDA (READTABLE)                                        (* gbn " 1-Apr-86 22:36")
-          
-          (* * installs the TEDITKEYBINDINGS on the readtable)
-
-    (PROG [(READTABLE (OR READTABLE TEDIT.READTABLE))
-           INTERRUPT
-           (FNKEYITEM '(Function% Keys 'BUILDFNKEYS "Bring up the DLion fn keys window"]
-          
-          (* I think that in Koto, all this is done by the system.
-          The times, they are a-changin'! (PROGN (* Tell everyone who cares to let ^h be 
-          the backspace character) (if (SETQ INTERRUPT
-          (GETINTERRUPT (CHARCODE ^H))) then (printout T "Interrupt on ^H disabled")
-          (SETINTERRUPT (CHARCODE ^H) (QUOTE NIL)))
-          (SETSYNTAX 8 (QUOTE CHARDELETE) \PROMPTFORWORDTTBL)
-          (SETSYNTAX 8 (QUOTE CHARDELETE) ASKUSERTTBL)
-          (SETSYNTAX 8 (QUOTE CHARDELETE) \ORIGTERMTABLE)
-          (SETSYNTAX 8 (QUOTE CHARDELETE) \PRIMTERMTABLE)
-          (SETSYNTAX 8 (QUOTE CHARDELETE) DEDITTTBL)
-          (SETINTERRUPT (CHARCODE ^G) (QUOTE HELP))))
-
-          (METASHIFT T)
-          
-          (* TEditKey redefines METASHIFT to operate on TEDITKEY.METAKEY instead of the 
-          swat (bottom-blank) key)
-          
-          (* install the functions on the main keyboard, that is, not the extra dlion 
-          keys)
-
-          [for TRIPLE in TEDITKEY.KEYBINDINGS
-             do (COND
-                   (TRIPLE                                   (* NILs in the list are for formatting 
-                                                             the menu)
-                          (for KEY in (CADR TRIPLE)
-                             do (APPLY* 'TEDIT.SETFUNCTION (EVAL `(CHARCODE %, KEY))
-                                       (CAR TRIPLE)
-                                       READTABLE]            (* the function keys are set up by 
-                                                             default (MODIFY.KEYACTIONS 
-                                                             TEDITKEY.FNKEYACTIONS))
-          (PROGN                                             (* install the nextttywindow hack)
-                                                             (* INTERRUPTCHAR (\SHIFTACTION
-                                                             (QUOTE NEXT)) (QUOTE
-                                                             (GOTONEXTTTYWINDOW)))
-                                                             (* So that non-tedits know about the 
-                                                             game)
-                 )
-          (SELECTQ (MACHINETYPE)
-              (DANDELION [if TEDITKEY.LOCKTOGGLEKEY
-                             then (KEYACTION TEDITKEY.LOCKTOGGLEKEY '(LOCKTOGGLE]
-                         (if (AND (BOUNDP 'DLIONFNKEYS)
-                                  (OPENWP DLIONFNKEYS))
-                             then 
-          
-          (* this machine has real fn keys so close the fake ones)
-
-                                  (CLOSEW DLIONFNKEYS))
-          
-          (* adjust so that the dlion extra keys return meta control codes)
-
-                         (MODIFY.KEYACTIONS TEDITKEY.DLION.KEYACTIONS)
-                         (for PAIR in TEDITKEY.DLION.KEYBINDINGS
-                            do (TEDIT.SETFUNCTION (EVAL (CAR PAIR))
-                                      (CADR PAIR)
-                                      READTABLE))            (* hang functions off the dlion extra 
-                                                             keys (e.g. italics, bold))
-                         (for PAIR in TEDITKEY.FNKEYBINDINGS do (TEDIT.SETFUNCTION
-                                                                 (EVAL (CAR PAIR))
-                                                                 (CADR PAIR)
-                                                                 READTABLE))
-          
-          (* set next to do next, undo to do undo etc)
-                                                             (* unnecessary in KOTO
-                                                             (for PAIR in TEDITKEY.DLION.KEYSYNTAX 
-                                                             do (TEDIT.SETSYNTAX (EVAL
-                                                             (CAR PAIR)) (CADR PAIR) READTABLE)))
-          
-          (* remove the menu item that may have already been installed)
-                                                             (* you can remove non-existent items 
-                                                             with impunity)
-                         (TEDIT.REMOVE.MENUITEM TEDIT.DEFAULT.MENU FNKEYITEM)
-                         (PROGN                              (* install the nextttywindow hack)
-                                (INTERRUPTCHAR (\SHIFTACTION 'NEXT)
-                                       '(GOTONEXTTTYWINDOW)) (* So that non-tedits know about the 
-                                                             game)
-                                ))
-              (PROGN (MODIFY.KEYACTIONS TEDITKEY.DORADO.KEYACTIONS)
-                     (for PAIR in TEDITKEY.DORADO.KEYSYNTAX do (TEDIT.SETSYNTAX (EVAL (CAR PAIR))
-                                                                      (CADR PAIR)
-                                                                      READTABLE))
-                     (for PAIR in TEDITKEY.FNKEYBINDINGS do (TEDIT.SETFUNCTION (EVAL (CAR PAIR))
-                                                                   (CADR PAIR)
-                                                                   READTABLE))
-                     (TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU FNKEYITEM)))
-          (SELECTQ (MACHINETYPE)
-              ((DORADO DOLPHIN)                              (* bring up the fake function keys)
-                   (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
-                          DLIONFNKEYS)
-                   (COND
-                      ([AND TEDITKEY.FNKEYFLG (NOT (AND (BOUNDP 'DLIONFNKEYS)
-                                                        (OPENWP DLIONFNKEYS]
-          
-          (* if he has the flag set to do so, then check if there is a fnkey window up 
-          yet, and build one if there isn't)
-
-                       (BUILDFNKEYS))))
-              (PROGN NIL))
-          
-          (* install the forms necessary to re-establish the correct bindings on a new 
-          machine if this is sysout'ed)
-                                                             (* if (NOT (ASSOC (QUOTE 
-                                                             TEDITKEY.INSTALL) AFTERMAKESYSFORMS)) 
-                                                             then (push AFTERMAKESYSFORMS
-                                                             (QUOTE (TEDITKEY.INSTALL))))
-          [COND
-             ((NOT (ASSOC 'TEDITKEY.INSTALL AFTERSYSOUTFORMS))
-              (push AFTERSYSOUTFORMS '(TEDITKEY.INSTALL]
-          (RETURN (CONCAT TEDITKEY.METAKEY "'s action is now Meta. TEditKey actions and key bindings installed.  Type #? or press the HELP key to see keybindings"
-                         ])
-
-(TEDITKEY.DEINSTALL
-  [LAMBDA (ARGS |...|)                                       (* gbn "10-Oct-85 00:04")
-    (MODIFY.KEYACTIONS \ORIGKEYACTIONS)
-    (SELECTQ (MACHINETYPE)
-        (DANDELION (MODIFY.KEYACTIONS \DLIONKEYACTIONS))
-        (PROGN NIL])
-
-(\TK.ACTIONTOCHARCODE
-  [LAMBDA (FN)                                               (* gbn "23-Feb-85 17:17")
-          
-          (* takes the name of the function and looks in TEDITKEY.KEYBINDINGS to find out 
-          which CHARCODE generates that behaviour)
-
-    (PROG ((PAIR (ASSOC FN TEDITKEY.KEYBINDINGS)))
-          (RETURN (if PAIR
-                      then [EVAL `(CHARCODE %, (CAADR PAIR]
-                    else NIL])
-
-(\TK.BUILD.MENU
-  [LAMBDA (KEYBINDINGS)                                      (* gbn "23-Feb-85 17:17")
-                                                             (* builds a menu to display the key 
-                                                             bindings)
-    (PROG (ITEMS)
-          [for TRIPLE in TEDITKEY.KEYBINDINGS
-             do (COND
-                   (TRIPLE (push ITEMS (LIST (CADDR TRIPLE)
-                                             `(QUOTE %, TRIPLE) 
-                                "Function which is performed by the key(s) to the right of the mouse"
-                                             ))
-                          (push ITEMS (LIST (for DESC in (CADR TRIPLE) collect (CHARDESC DESC))
-                                            NIL)))
-                   (T 
-          
-          (* insert a space since NIL marks logical divisions in the list)
-
-                      (push ITEMS '("" NIL ""))
-                      (push ITEMS '("" NIL ""]
-          (SETQ \TK.MENU (create MENU
-                                ITEMS _ (DREVERSE ITEMS)
-                                MENUCOLUMNS _ 2
-                                CENTERFLG _ T
-                                MENUFONT _ (FONTCREATE 'HELVETICA 10])
-
-(\TK.HELP
-  [LAMBDA (WHATEVER)                                         (* gbn " 5-Nov-84 18:17")
-                                                             (* brings up a menu of the available 
-                                                             key bindings)
-    (MENU \TK.MENU])
-
-(\TK.SETFONTINLOOKS
-  [LAMBDA (TEXTSTREAM LOOKS)                                 (* gbn "11-Oct-85 07:12")
-          
-          (* * rebuilds the font field of looks according to the values in the fields)
-
-    (PROG (NEWFONT)
-          (SETQ NEWFONT (FONTCREATE (OR (fetch CLNAME of LOOKS)
-                                        (FONTPROP (fetch CLFONT of LOOKS)
-                                               'FAMILY))
-                               (fetch CLSIZE of LOOKS)
-                               (LIST (if (fetch CLBOLD of LOOKS)
-                                         then 'BOLD
-                                       else 'MEDIUM)
-                                     (if (fetch CLITAL of LOOKS)
-                                         then 'ITALIC
-                                       else 'REGULAR)
-                                     'REGULAR)
-                               NIL NIL T))
-          (if (CAR NEWFONT)
-              then                                           (* we got the font, so now replace it)
-                   (RETURN (replace CLFONT of LOOKS with NEWFONT))
-            else 
-          
-          (* we lost, print a msg and return NIL so that the caller knows.)
-
-                 (TEDIT.PROMPTPRINT TEXTSTREAM
-                        (CONCAT "Font not found: " (CONCAT [L-CASE (OR (fetch CLNAME of LOOKS)
-                                                                       (FONTPROP (fetch CLFONT
-                                                                                    of LOOKS)
-                                                                              'FAMILY]
-                                                          " "
-                                                          (fetch CLSIZE of LOOKS)
-                                                          (if (fetch CLBOLD of LOOKS)
-                                                              then 'BOLD " bold"
-                                                            else "")
-                                                          (if (fetch CLITAL of LOOKS)
-                                                              then " italic"
-                                                            else "")))
-                        T)
-                 (RETURN NIL])
-
-(WRITE.CHARDESC.AUX
-  [LAMBDA (TOKENS)                                           (* gbn "10-Oct-85 00:20")
-    (COND
-       ((EQ (LENGTH TOKENS)
-            1)
-        (CONS (CAR TOKENS)
-              NIL))
-       (T (SELECTQ (CAR TOKENS)
-              (%# [CONS "meta " (WRITE.CHARDESC.AUX (COND
-                                                       ((AND (CDR TOKENS)
-                                                             (EQ (CADR TOKENS)
-                                                                 '%#))
-                                                        (CDDR TOKENS])
-              (^ (CONS "control " (WRITE.CHARDESC.AUX (CDR TOKENS))))
-              (ERROR CHARDESC " is a misunderstood character descriptor"])
-
-(CHARDESC
-  [LAMBDA (CHARDESC)                                         (* gbn " 7-Nov-84 14:21")
-          
-          (* takes a description in the form taken as input to charcode and writes out a 
-          human readable form)
-
-    (PACK (WRITE.CHARDESC.AUX (UNPACK CHARDESC])
-
-(TEDITKEY.CONFIGURE
-  [LAMBDA NIL                                                (* gbn " 5-Nov-84 18:58")
-    (PROMPTPRINT "not implemented"])
-
-(\TK.ADDKEY
-  [LAMBDA (TRIPLE)                                           (* gbn " 5-Nov-84 18:41")
-                                                             (* dummy for now)
-    ])
-
-(\TK.CHANGEKEY
-  [LAMBDA (THIS)                                             (* gbn " 5-Nov-84 18:42")
-                                                             (* DUMMY)
-    ])
-
-(\TK.APPLYPENDING
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL)                           (* gbn "10-Dec-84 15:58")
-          
-          (* * takes the entries on \TK.PENDING, reverses them and applies them as 
-          incremental changes to the selection.)
-
-    (PROG ((PENDING (DREVERSE \TK.PENDING))
-           (LOOKS (LIST NIL)))
-          (for ENTRY in PENDING do (SELECTQ ENTRY
-                                       (BOLDON (LISTPUT LOOKS 'WEIGHT 'BOLD))
-                                       (BOLDOFF (LISTPUT LOOKS 'WEIGHT 'MEDIUM))
-                                       (ITALICON (LISTPUT LOOKS 'SLOPE 'ITALIC))
-                                       (ITALICOFF (LISTPUT LOOKS 'SLOPE 'REGULAR))
-                                       (UNDERLINEON (LISTPUT LOOKS 'UNDERLINE 'ON))
-                                       (UNDERLINEOFF (LISTPUT LOOKS 'UNDERLINE 'OFF))
-                                       (SUPERSCRIPT          (* nothing for the moment)
-                                                    NIL)
-                                       (SUBSCRIPT            (* nothing for the moment)
-                                                  NIL)
-                                       (LARGER               (* nothing for the moment)
-                                               NIL)
-                                       (SMALLER              (* nothing for the moment)
-                                                NIL)
-                                       (DEFAULTS (SETQ LOOKS (\TEDIT.UNPARSE.CHARLOOKS.LIST 
-                                                                    TEDIT.DEFAULT.CHARLOOKS)))
-                                       ((TIMESROMAN HELVETICA GACHA MODERN CLASSIC TERMINAL HIPPO 
-                                               MATH) 
-                                            (LISTPUT LOOKS 'FAMILY ENTRY))
-                                       (\LISPERROR "Illegal pending operation in \TK.PENDING" ENTRY))
-               )
-          (SETQ \TK.PENDING NIL)
-          (RETURN (TEDIT.LOOKS TEXTSTREAM LOOKS SEL])
-
-(\TK.NTHFONT
-  [LAMBDA (N)                                                (* gbn "27-Jan-85 17:51")
-                                                             (* returns the name of the nth 
-                                                             teditkey font)
-    (CAR (NTH TEDITKEY.FONTS N])
-)
-
-
-
-(* ; "redefinition of system junk")
-
-(DEFINEQ
-
-(METASHIFT
-  [LAMBDA FLG                                                (* gbn " 6-Mar-85 15:43")
-          
-          (* Sets interpretation of TEDITKEY.METAKEY key to first arg, where T means 
-          meta-shift, NIL means original setting. Returns previous setting)
-
-    (PROG ((METASTATUS '(METADOWN . METAUP))
-           OLDSETTING)
-          [SETQ OLDSETTING (KEYACTION TEDITKEY.METAKEY (AND (IGREATERP FLG 0)
-                                                            (COND
-                                                               ((EQ (ARG FLG 1)
-                                                                    T)
-                                                                METASTATUS)
-                                                               (T (OR (ARG FLG 1)
-                                                                      (CDR (ASSOC TEDITKEY.METAKEY 
-                                                                                  \ORIGKEYACTIONS]
-          (RETURN (COND
-                     ((EQUAL OLDSETTING METASTATUS)
-                      T)
-                     (T OLDSETTING])
-)
-
-
-
-(* ;; 
-"(\TK.BOLDTOGGLE (##H ##h) 'toggle Bold caret looks') (\TK.ITALICTOGGLE (##i ##I) 'toggle Italic caret looks') (\TK.SUPERSCRIPT.CARET (##^) 'Superscript the caret looks') (\TK.SUBSCRIPT.CARET (##_) 'Subscript the caret looks')"
-)
-
-(DEFINEQ
-
-(TEDIT.FULL.FIND
-  [LAMBDA (TEXTSTREAM SEARCHSTRING)                          (* gbn " 8-Mar-85 12:56")
-    (PROG (TARGET (TEXTOBJ (TEXTOBJ TEXTSTREAM))
-                 SEL CH W)                                   (* Case sensitive search, with * and 
-                                                             %# wildcards)
-          [SETQ W (CAR (MKLIST (fetch \WINDOW of TEXTOBJ]
-          [SETQ TARGET (OR SEARCHSTRING (TEDIT.GETINPUT TEXTOBJ "Text to find: " (WINDOWPROP
-                                                                                  W
-                                                                                  '
-                                                                               TEDIT.LAST.FIND.STRING
-                                                                                  )
-                                               (CHARCODE (EOL LF ESC]
-          [COND
-             (TARGET (SETQ SEL (fetch SEL of TEXTOBJ))
-                    (\SHOWSEL SEL NIL NIL)
-                    (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T)
-                    (SETQ CH (TEDIT.FIND TEXTOBJ (MKSTRING TARGET)
-                                    NIL NIL T))
-                    (COND
-                       (CH                                   (* We found the target text.)
-                           (TEDIT.PROMPTPRINT TEXTOBJ "Done.")
-                           (replace CH# of SEL with (CAR CH))(* Set up SELECTION to be the found 
-                                                             text)
-                           (replace CHLIM of SEL with (ADD1 (CADR CH)))
-                           [replace DCH of SEL with (ADD1 (IDIFFERENCE (CADR CH)
-                                                                 (CAR CH]
-                           (replace POINT of SEL with 'RIGHT)
-                           (replace CARETLOOKS of TEXTOBJ with (\TEDIT.GET.INSERT.CHARLOOKS TEXTOBJ 
-                                                                      SEL))
-                           (TEDIT.RESET.EXTEND.PENDING.DELETE SEL)
-                                                             (* And never pending a deletion.)
-                           (\FIXSEL SEL TEXTOBJ)
-                           (TEDIT.NORMALIZECARET TEXTOBJ)
-                           (\SHOWSEL SEL NIL T)
-                           (WINDOWPROP W 'TEDIT.LAST.FIND.STRING TARGET)
-                                                             (* And get it into the window)
-                           )
-                       (T (TEDIT.PROMPTPRINT TEXTOBJ "(not found)")
-                          (\SHOWSEL SEL NIL T]
-          (replace \INSERTNEXTCH of TEXTOBJ with -1])
-)
-
-(RPAQQ \TK.WHITESPACE 22)
-
-(RPAQ TEDIT.INTERRUPTS `((%, (CHARCODE ^G)
-                             ERROR)
-                         (%, (CHARCODE ^C)
-                             HELP)))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \TK.WHITESPACE 22)
-
-
-(CONSTANTS (\TK.WHITESPACE 22))
-)
-
-(RPAQ? TEDITKEY.VERBOSE T)
-
-(RPAQ? TEDITKEY.METAKEY 'TAB)
-
-(RPAQ? TEDITKEY.LOCKTOGGLEKEY NIL)
-
-(RPAQ? TEDITKEY.NESTWIDTH 36)
-
-(RPAQ? \TK.SIZEINCREMENT 2)
-
-(RPAQ? TEDITKEY.OFFSETINCREMENT 3)
-
-(RPAQ? TEDITKEY.FONTS '(TIMESROMAN HELVETICA GACHA MODERN CLASSIC TERMINAL SYMBOL HIPPO))
-
-(RPAQ? TEDITKEY.FNKEYFLG T)
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS METACODE MACRO [LAMBDA (CHARCODE)
-                           (LOGOR CHARCODE 128])
-
-(PUTPROPS CONTROLCODE MACRO [LAMBDA (CHARCODE)
-                              (LOGAND CHARCODE 31])
-
-(PUTPROPS LCMETACODE MACRO [LAMBDA (CHARCODE)
-                             (LOGOR 160 CHARCODE])
-)
-
-(RPAQ? \TK.SELKEY 'OPEN)
-
-(RPAQ? \TK.PENDING )
-
-(RPAQ? TEDITKEY.KEYBINDINGS
-       `((\TK.FONT1 (%##1)
-                %,
-                (CONCAT "change to font " (\TK.NTHFONT 1)))
-         (\TK.FONT2 (%##2)
-                %,
-                (CONCAT "change to font " (\TK.NTHFONT 2)))
-         (\TK.FONT3 (%##3)
-                %,
-                (CONCAT "change to font " (\TK.NTHFONT 3)))
-         (\TK.FONT4 (%##4)
-                %,
-                (CONCAT "change to font " (\TK.NTHFONT 4)))
-         (\TK.FONT5 (%##5)
-                %,
-                (CONCAT "change to font " (\TK.NTHFONT 5)))
-         (\TK.FONT6 (%##6)
-                %,
-                (CONCAT "change to font " (\TK.NTHFONT 6)))
-         (\TK.FONT7 (%##7)
-                %,
-                (CONCAT "change to font " (\TK.NTHFONT 7)))
-         (\TK.FONT8 (%##8)
-                %,
-                (CONCAT "change to font " (\TK.NTHFONT 8)))
-         NIL
-         (\TK.DEFAULTS.CARET (%##/)
-                "restore the default caret looks")
-         (\TK.SMALLER.CARET (%##9)
-                "decrease the caret font size")
-         (\TK.LARGER.CARET (%##0)
-                "increase the caret font size")
-         (\TK.SHOWCARETLOOKS (%##=)
-                "display the current caret looks")
-         NIL
-         (\TK.REDISPLAY (%##R %##r)
-                "Restore the display")
-         (\TK.HELP (%##?)
-                "displays the current key bindings")
-         NIL
-         (\TK.PREVCHAR (^B ^b)
-                "Back one character")
-         (\TK.NEXTCHAR (^F ^f)
-                "Forward one character")
-         (\TK.FORWARD.WORD (%##F %##f)
-                "Forward one word")
-         (\TK.BACK.WORD (%##B %##b)
-                "Back one word")
-         (\TK.GOTOLINEBEGIN (^A ^a)
-                "go to stArt of line")
-         (\TK.GOTOLINEEND (^E ^e)
-                "go to End of line")
-         (\TK.PREVLINE (^P ^p)
-                "go to Previous line")
-         (\TK.NEXTLINE (^N ^n)
-                "go to Next line")
-         (\TK.GOTODOCBEGIN (%##<)
-                "start of document")
-         (\TK.GOTODOCEND (%##>)
-                "end of document")
-         (\TK.SELECT.ALL (%##S %##s)
-                "Select whole document")
-         NIL
-         (\TK.DELLINEFORWARD (^K ^k)
-                "Kill line")
-         (\TK.OPENLINE (^O ^o)
-                "Open up blank line")
-         (\TK.DELCHARFORWARD (^D ^d)
-                "Delete character forward")
-         (\TK.DEL.WORD.FORWARD (%##D %##d)
-                "Delete word forward")
-         (\TK.TRANSPOSECHARS (^T ^t)
-                "Transpose characters")
-         NIL NIL (\TK.NEST (|##[|)
-                        "indents margins (nest)")
-         (\TK.UNNEST (|##]|)
-                "exdents margins (unnest)")
-         (\TK.CENTER.SEL (%##J %##j)
-                "alter Justification")
-         (\TK.UCASE.SEL (%##U %##u)
-                "Uppercasify selection")
-         (\TK.CAPITALISE.SEL (%##C %##c)
-                "Capitalize selection")
-         (\TK.LCASE.SEL (%##L %##l)
-                "Lowercasify selection")
-         (GET.OBJ.FROM.USER (%##O %##o)
-                "insert Object")))
-
-(RPAQ? TEDITKEY.DLION.KEYACTIONS
-       `((STOP (%, (CHARCODE ^G)
-                   %,
-                   (CHARCODE ^C)
-                   NOLOCKSHIFT))
-         (OPEN (%, (CHARCODE 2,1)
-                   %,
-                   (CHARCODE 2,41)
-                   NOLOCKSHIFT))
-         (FONT FONTDOWN . FONTUP)
-         (KEYBOARD USERMODE1DOWN . USERMODE1UP)))
-
-(RPAQ? COMS 
-            (* ;; "(TEDITKEY.FNKEYACTIONS (BQUOTE ((CENTER (, (CHARCODE ##^B), (CHARCODE ##^C))) (BOLD (, (CHARCODE ##^D), (CHARCODE ##^E) NOLOCKSHIFT)) (ITALICS (, (CHARCODE ##^F), (CHARCODE ##^G) NOLOCKSHIFT)) (UNDERLINE (, (CHARCODE ##^H), (CHARCODE ##^I) NOLOCKSHIFT)) (SUPERSCRIPT (, (CHARCODE ##^J), (CHARCODE ##^K) NOLOCKSHIFT)) (SUBSCRIPT (, (CHARCODE ##^L), (CHARCODE ##^N) NOLOCKSHIFT)) (LARGER (, (CHARCODE ##^O), (CHARCODE ##^P) NOLOCKSHIFT)) (DEFAULTS (, (CHARCODE ##^Q), (CHARCODE ##^R) NOLOCKSHIFT)) (BS (, (CHARCODE ^H), (CHARCODE ^D) NOLOCKSHIFT)))))")
-)
-
-(RPAQ? TEDITKEY.DLION.KEYBINDINGS
-       '(((\ACTION 'OPEN)
-          \TK.OPENLINE)
-         ((\ACTION 'HELP)
-          \TK.HELP)
-         ((\ACTION 'MARGINS)
-          \TK.NEST)
-         ((\SHIFTACTION 'MARGINS)
-          \TK.UNNEST)
-         ((\SHIFTACTION 'NEXT)
-          GOTONEXTTTYWINDOW)))
-
-(RPAQ? TEDITKEY.FNKEYBINDINGS '(((\ACTION 'DEFAULTS)
-                                 \TK.DEFAULTSSEL)
-                                ((\SHIFTACTION 'DEFAULTS)
-                                 \TK.SETDEFAULTLOOKS)))
-
-(RPAQ? COMS 
-            (* ;; "NOT NEEDED (TEDITKEY.DLION.KEYSYNTAX (QUOTE (((\ACTION (QUOTE NEXT)) NEXT) ((\ACTION (QUOTE UNDO)) UNDO) ((\ACTION (QUOTE BS)) CHARDELETE))))")
-)
-
-(RPAQ? TEDITKEY.DORADO.KEYACTIONS
-       `((BS (%, (CHARCODE ^H)
-                 %,
-                 (CHARCODE ^H)))
-         (BLANK-BOTTOM (%, (CHARCODE %##^A)
-                           %,
-                           (CHARCODE %##^A)))
-         (BLANK-TOP FONTDOWN . FONTUP)
-         (BLANK-MIDDLE USERMODE1DOWN . USERMODE1UP)
-         (CENTER (2,101 2,141 NOLOCKSHIFT))
-         (BOLD (2,102 2,142 NOLOCKSHIFT))
-         (ITALICS (2,103 2,143 NOLOCKSHIFT))
-         (UNDERLINE (2,106 2,146 NOLOCKSHIFT))
-         (SUPERSCRIPT (2,113 2,153 NOLOCKSHIFT))
-         (SUBSCRIPT (2,114 2,154 NOLOCKSHIFT))
-         (LARGER (2,110 2,150 NOLOCKSHIFT))
-         (DEFAULTS (2,115 2,155 NOLOCKSHIFT))))
-
-(RPAQ? TEDITKEY.DORADO.KEYSYNTAX '(((CHARCODE %##N)
-                                    NEXT)
-                                   ((CHARCODE %##n)
-                                    NEXT)
-                                   ((\ACTION 'BLANK-BOTTOM)
-                                    UNDO)
-                                   ((\ACTION 'BS)
-                                    CHARDELETE)))
-
-(TEDITKEY.INSTALL)
-
-(\TK.BUILD.MENU)
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA )
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA METASHIFT)
-)
-(PUTPROPS TEDITKEY COPYRIGHT ("Xerox Corporation" 1985 1986 1987))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (15387 27818 (NTHCAR 15397 . 15526) (\TEXTOBJ.WINDEX 15528 . 16085) (\TK.PREVSCREEN 
-16087 . 17997) (\TK.UNDERLINE.SEL.ON 17999 . 18479) (\TK.UNDERLINE.SEL.OFF 18481 . 18964) (
-\TK.BOLD.SEL.ON 18966 . 19558) (\TK.BOLD.SEL.OFF 19560 . 20156) (\TK.ITALIC.SEL.ON 20158 . 20506) (
-\TK.ITALIC.SEL.OFF 20508 . 20859) (\TK.SMALLERSEL 20861 . 21498) (\TK.LARGERSEL 21500 . 22131) (
-\TK.SUPERSCRIPTSEL 22133 . 22778) (\TK.SUBSCRIPTSEL 22780 . 23429) (\TK.DEFAULTSSEL 23431 . 24150) (
-\TK.DEL.WORD.FORWARD 24152 . 25748) (\TK.UCASE.SEL 25750 . 26316) (\TK.CAPITALISE.SEL 26318 . 26932) (
-\CAPITALISE 26934 . 27248) (\TK.LCASE.SEL 27250 . 27816)) (27890 32567 (\TK.CENTER.SEL 27900 . 29168) 
-(\TK.CENTER.SEL.REV 29170 . 30348) (\TK.NEST 30350 . 31330) (\TK.UNNEST 31332 . 32565)) (32651 42379 (
-\TK.SHOWCARETLOOKS 32661 . 33972) (\TK.BOLD.CARET.ON 33974 . 34537) (\TK.BOLD.CARET.OFF 34539 . 35105)
- (\TK.ITALIC.CARET.ON 35107 . 35672) (\TK.ITALIC.CARET.OFF 35674 . 36242) (\TK.UNDERLINE.CARET.ON 
-36244 . 36683) (\TK.UNDERLINE.CARET.OFF 36685 . 37127) (\TK.SUPERSCRIPT.CARET 37129 . 37771) (
-\TK.SUBSCRIPT.CARET 37773 . 38431) (\TK.SMALLER.CARET 38433 . 39075) (\TK.LARGER.CARET 39077 . 39664) 
-(\TK.DEFAULTS.CARET 39666 . 39991) (\TK.FONT1 39993 . 40165) (\TK.FONT2 40167 . 40339) (\TK.FONT3 
-40341 . 40513) (\TK.SETCARETFONT 40515 . 41507) (\TK.FONT4 41509 . 41681) (\TK.FONT5 41683 . 41855) (
-\TK.FONT6 41857 . 42029) (\TK.FONT7 42031 . 42203) (\TK.FONT8 42205 . 42377)) (42468 44800 (
-\TK.BOLDTOGGLE 42478 . 43353) (\TK.ITALICTOGGLE 43355 . 44166) (\TK.UNDERLINETOGGLE 44168 . 44798)) (
-44858 45320 (\TK.SETDEFAULTLOOKS 44868 . 45318)) (45381 58503 (GOTONEXTTTYWINDOW 45391 . 47670) (
-\TK.NEXTLINE 47672 . 49560) (\TK.PREVLINE 49562 . 51662) (\TK.GOTODOCBEGIN 51664 . 52022) (
-\TK.GOTODOCEND 52024 . 52375) (\TK.GOTOLINEBEGIN 52377 . 53161) (\TK.GOTOLINEEND 53163 . 53987) (
-\TK.PREVCHAR 53989 . 54518) (\TK.NEXTCHAR 54520 . 55084) (\TK.FORWARD.WORD 55086 . 56623) (
-\TK.BACK.WORD 56625 . 58193) (\TK.SELECT.ALL 58195 . 58501)) (58536 61575 (\TK.FIND 58546 . 58817) (
-\TK.REDISPLAY 58819 . 59077) (\TK.DELLINEFORWARD 59079 . 59619) (\TK.OPENLINE 59621 . 59828) (
-\TK.DELCHARFORWARD 59830 . 60217) (\TK.TRANSPOSECHARS 60219 . 61573)) (61644 63231 (\SEL.LIMIT 61654
- . 62069) (\TK.SETFILEPTR.TO.CARET 62071 . 62498) (\SEL.LINEDESC 62500 . 63229)) (64698 81534 (
-\SHIFTACTION 64708 . 64954) (\ACTION 64956 . 65198) (TEDITKEY.INSTALL 65200 . 72641) (
-TEDITKEY.DEINSTALL 72643 . 72906) (\TK.ACTIONTOCHARCODE 72908 . 73371) (\TK.BUILD.MENU 73373 . 74689) 
-(\TK.HELP 74691 . 75002) (\TK.SETFONTINLOOKS 75004 . 77479) (WRITE.CHARDESC.AUX 77481 . 78237) (
-CHARDESC 78239 . 78545) (TEDITKEY.CONFIGURE 78547 . 78702) (\TK.ADDKEY 78704 . 78904) (\TK.CHANGEKEY 
-78906 . 79101) (\TK.APPLYPENDING 79103 . 81209) (\TK.NTHFONT 81211 . 81532)) (81579 82740 (METASHIFT 
-81589 . 82738)) (82986 85812 (TEDIT.FULL.FIND 82996 . 85810)))))
-STOP
diff --git a/obsolete/lispusers/TEDITKEY.LCOM b/obsolete/lispusers/TEDITKEY.LCOM
deleted file mode 100644
index a303ab73..00000000
Binary files a/obsolete/lispusers/TEDITKEY.LCOM and /dev/null differ
diff --git a/obsolete/lispusers/TEDITKEY.TEDIT b/obsolete/lispusers/TEDITKEY.TEDIT
deleted file mode 100644
index a7347104..00000000
--- a/obsolete/lispusers/TEDITKEY.TEDIT
+++ /dev/null
@@ -1,149 +0,0 @@
-en·vÅos	TEDITKEY
2

4

1

TEDITKEY
1

4

By:  Greg Nuyens
Supported by: Jan Pedersen (Pedersen.pa@Xerox.com)
Uses: KEYOBJ, DLIONFNKEYS
TEditKey is a module that provides a keyboard interface to TEdit.   On a Dandelion, the interface takes advantage of the special keys to the left, top, and right of the main keyboard. On a Dorado or Dolphin, a window mimicking the Dandelion function keys provides some of the same abilities.  
The abilities provided include allowing the user to alter the caret looks (the looks of characters typed in) or the selection looks.  These commands are given using the Dandelion function keys and/or metacodes. (Metacodes are keys typed while a meta key is held down. The default meta key is the tab key; to alter this see "User Switches" below.)  Other metacodes and control codes move the cursor within the document (beginning/end of line, back/forward a character, up/down a line, etc.).
Thus, many of the special Dandelion keys are made to function in TEdit the way they are labeled.  The following keys change their behavior once TEditKey is loaded.
CENTER modifies the justification of the paragraph(s) containing the current selection.  If the selection was left justified, then hitting the CENTER key makes it centered.  Hitting it again produces right and left justification. 
BOLD boldfaces the selection.  All other properties remain unchanged.  Holding the shift key down while hitting BOLD will make the selection become un-bold.
ITALICS italicizes the selection.  Shift-ITALICS is the opposite.
UNDERLINE underlines the selection.  Shift-UNDERLINE is the opposite.
SUPERSCRIPT superscripts the selection by a constant amount.  Any relative superscripts (or subscripts) are maintained.  Thus if "Xi" is selected in "the set Xi is empty" then pressing the SUPERSCRIPT button produces "the set Xi is empty." See "User Switches" below for how to set the increment.  Shift-SUPERSCRIPT is the same as SUBSCRIPT. 
SUBSCRIPT is analogous to SUPERSCRIPT.
SMALLER decreases the font size of the selection.  All relative size differences are maintained.  E.g.,"this is bigger than that" produces "this is bigger than that."  Shift-SMALLER (labeled LARGER) does the opposite.
DEFAULTS makes the selection have default looks.  N.B.: The default looks can be set to the current caret looks by typing shift-DEFAULTS.
The above keys all affect the caret looks if the keyboard key is held down when they are hit.  Thus holding down KEYBOARD and then hitting UNDERLINE makes the caret looks be underlined.
FONT changes the font of the selection or caret looks according to the following table  (to alter this table see "User Switches" below):
1	Times Roman 
2	Helvetica 
3	Gacha
4	Modern
5	Classic
6	Terminal
7	Symbol
8	Hippo
Thus, to change the font of the selection to Classic, hold down FONT and hit 5.  To change the caret font to Classic, hold down FONT (to signal the font change) and KEYBOARD (to direct the change to the caret looks) then hit 5.  Note that this table is part of the menu displayed when the HELP button is pressed.
On a Dorado, middle-blank is the FONT key.
KEYBOARD applies any changes that occur while this key is down to the caret looks instead of the selection.  On a Dorado, bottom-blank is the KEYBOARD key.
AGAIN invokes the redo facility in TEdit.  A wide variety of operations can be repeated very simply by making a selection, performing an operation (for instance, an insertion), then picking a new selection and hitting the AGAIN key. The AGAIN key is an ESCape key, which acts as the TEdit REDO syntax class.  (See page 20.22 of the Interlisp Reference Manual.)
OPEN 	opens a blank line at the current cursor position.  OPEN is also used to type a linefeed outside of TEdit (for example to the function FILES?).
FIND prompts the user for a target string, then searches from the selection forward.
NEXT acts as the TEdit NEXT syntax class.  (It goes to the next field to be filled in. These fields are marked as follows: >>text to be substituted<< .)
shift-NEXT 	transfers the TTY (which window will receive typed characters) to the next window which can accept typein.  Thus one can cycle through the open text windows (mail windows, top level lisp windows, TEdit windows, etc.) without using the mouse.
EXPAND expands TEdit abbreviations. (See page 20.31 of the Interlisp Reference Manual.)
HELP displays a menu of the keybindings until a mouse key is clicked.
UNDO acts as the TEdit UNDO syntax class.  Note that it still retains its TELERAID function as does STOP.   There are TEditKey operations (such as Transpose Characters) that are implemented with multiple TEdit operations.  Since TEdit will UNDO only single operations, it does not fully UNDO these operations.
RightArrow	enters \, and | when shifted.  (Recall that AGAIN is an escape key.)
MARGINS indents the margins of the paragraph selected.  Shift-MARGINS exdents the margins. If the right margin is a floating margin, it is left unchanged.  To control the amount by which the margins are moved, see "User Switches."
As well as the previous functions available on the Dandelion's special keys, the following functions are available on the standard keyboard (thus usable on the Dandelion, Dolphin, and Dorado).  Each function is shown with the key that invokes it (in conjunction with the control (denoted ^) or meta (denoted #) key).   Thus, for the sixth entry, holding down the metakey and hitting f (or "F") would move the caret one word forward.  (To find out how to get a metakey see "User Switches" below.)
#/	defaults the caret looks 
#=	queries caret looks
#9	smaller caret font 
#0	larger caret font
^b	back character  
^f	forward character
#b	back word
#f	forward word
^p	previous line
^n	next line
^a	beginning of line
^e	end of line
#<	beginning of document
#>	end of document
#s	select whole document
^k	kills line (delete from caret to end of line)
^o	opens line
^d	deletes character forward (also on shift backspace)
#d	deletes word forward (as always ^w deletes word backward)
^t	transposes characters
#[	indents paralooks.  Also available on the MARGINS key
#]	exdents paralooks.  Also available as shift-MARGINS
#j	justification  change (same as CENTER key)
#u	uppercases selection
#c	capitalizes selection
#l	lowercases selection
#o	inserts object into document 
#?	shows keybindings (same as HELP)
#r	restores the display
Note that the positions of any of these functions can be individually changed using TEDIT.SETFUNCTION (see page 20.30 of the Interlisp Reference Manual).  For wholesale customization see "User Switches" below.
INTERRUPTS
Any operation can be aborted by typing the STOP key.  This can be used to abort font changes, GETs, PUTs, etc.   A stronger form of interrupt is available as shift-STOP, which prompts the user for a menu of processes to interrupt.
^G is available as a synonym for hitting the STOP key within TEditKey.  Outside of TEdit, however, ^G will continue to have the meaning specified in the user's init file.  This is often the HELP interrupt, which acts as shift-STOP.
Users who are accustomed to typing ^E as a soft interrupt should note that ^E moves to the end of the line.  As discussed above, hitting the STOP key (or equivalently, typing ^G) accomplishes what ^E did.
Since ^H is defined to be the Backspace action in TEditKey, users cannot type ^A to erase characters even outside of TEditKey (Interlisp-D currently does not allow multiple backspace characters).  
In addition to the changed functionality mentioned above (provided courtesy of TEditKey), the user should be aware of the following standard Interlisp-D/TEdit behavior:
SAME operates as a LooksCopy mode key.   First make a selection.  Now to copy the looks from some other text simply hold down the SAME key, then select the source for the looks.  (Paragraph looks can be copied the same way, but by making the final selection while in the left margin.  This is the standard way to select a whole paragraph in TEdit.)
MOVE and COPY act as mode keys for the selection mechanism.   Thus the user can select the destination, then hold down the MOVE key and make a second selection.  This selection will be moved (or COPY'd depending on the mode key used) to the (original) caret position.
CONTROL operates as a mode key to signal deletion.   This means that holding down the CONTROL key and selecting some text will delete that text when the CONTROL key is released.
DELETE deletes the current selection when pressed.
DORADO EQUIVALENTS
Dandelion Key:	Equivalent key on Dorado:
OPEN	^o ( or ^O)
SAME	META
FIND	finds item in TEdit menu
AGAIN	ESC
DELETE	DEL
COPY	SHIFT
MOVE	CTRL-SHIFT
PROP'S	META or LOCK depending on switches
NEXT	#n ( or #N)
EXPAND	^x (or ^X)
HELP	#?
MARGINS	#[	(unnest (which is shift-MARGINS on the Dandelion) is #] )
FONT	top blank 
KEYBOARD	middle blank 
UNDO	bottom blank
STOP	^G
shift-STOP	#^S (intentionally difficult to type accidentally)
The function keys (CENTER, BOLD, etc.) are all available on the function key window brought up when TEditKey is loaded on a Dorado.
Note that the function key window can be rebuilt on a Dorado by selecting "Function Keys" in the default TEdit menu (obtained by buttoning in the title bar of a TEdit window).
USER SWITCHES
TEDITKEY.METAKEY The user must choose a metakey to make use of TEditKey.  The value of the variable TEDITKEY.METAKEY is the name of the key that will be your metakey.  For instance to make TAB (the default) your metakey, (SETQ TEDITKEY 'TAB) before loading TEditKey.   (Note that even in the standard system, TAB is available as Control-I).
NOTE: METASHIFT (see page 18.9 of the Interlisp Reference Manual) is redefined to operate on TEDITKEY.METAKEY instead of on the bottom-blank key of the Dorado.
The operation of TEditKey is controlled by the following (INITVARed) variables:
TEDITKEY.LOCKTOGGLEKEY is the key that will be turned into a lock-toggle.  If it is non-NIL, that key is set to act as a lock-toggle.  Thus hitting this switches the case of the type-in.  For those users who have removed the spring from their lock key,  TEDITKEY.LOCKTOGGLEKEY is usually PROP'S.  The action of LOCK is then made to be '(CTRLDOWN. CTRLUP) providing the user with a control key where LOCK is located and a lock toggle where PROP'S is located.
TEDITKEY.FONTS is an eight-element list of the fonts that are invoked by meta-1 through meta-8.  The defaults are listed above.
TEDIT.DEFAULT.CHARLOOKS defines the looks that result when the DEFAULTS key is pressed or when default caret looks are requested.  It is an instance of the CHARLOOKS datatype.  To preset it, for instance, to TIMESROMAN 10 type the following to the Lisp top level.
(SETQ TEDIT.DEFAULT.CHARLOOKS (CHARLOOKS.FROM.FONT (FONTCREATE 'TIMESROMAN 10)))
However, a much simpler method is to select an instance of the desired looks and type shift-DEFAULTS.
TEDITKEY.VERBOSE if T (the default), the functions that modify the caret looks print feedback in the (TEdit) prompt window.
TEDITKEY.NESTWIDTH is the distance (in points) that the indent and exdent functions move the margins.  Initially 36 points (0.5 inches).
\TK.SIZEINCREMENT is the amount (in points) which the LARGER function increases the selection (and conversely for SMALLER).  Initially 2 points.
TEDITKEY.OFFSETINCREMENT is the amount (in points) which the SUBSCRIPT function raises the selection (and conversely for SUPERSCRIPT).  Initially 3 points.
TEDITKEY.KEYBINDINGS is the list that controls the mapping of keys to functions for the functions that are common to the Dandelion, Dorado, and Dolphin.  It consists of triples of function name, list of CHARCODE-style character specifications, and a comment describing what the function does.  (The comments are used by the automated menu-building tools and their inclusion is encouraged.) 
TEDITKEY.DLION.KEYACTIONS is the list that specifies the key actions of the non-Alto keys (to the left and right) on the Dandelion.  It is the format acceptable to MODIFY.KEYACTIONS (see page 18.9 of the Interlisp Reference Manual).
TEDITKEY.DLION.KEYBINDINGS is the list specifying the functions to be tied to the characters generated from above.  The keynames in the CAR of each element are comments.  Note that TEDIT.DLION.KEYACTIONS and TEDIT.DLION.KEYBINDINGS must be coordinated (similarly for TEDITKEY.FNKEYACTIONS and TEDITKEY.FNKEYBINDINGS).
TEDIT.DLION.KEYSYNTAX is the list of syntax classes to be applied to the Dandelion keys.
TEDITKEY.FNKEYACTIONS is the list that specifies the keyactions of the function keys (center, bold, etc.).
TEDITKEY.FNKEYBINDINGS is analogous to TEDIT.DLION.KEYBINDINGS but for the function keys.
TEDITKEY.DORADO.KEYACTIONS are the keyactions unique to the Dorado (and Dolphin).
TEDITKEY.DORADO.KEYSYNTAX is analogous to TEDIT.DLION.KEYSYNTAX.
The previous variables in conjunction with the following functions specify the effect of TEditKey.
(TEDITKEY.INSTALL readtable) invokes the keyactions and bindings as specified by the above variables on readtable.  (Readtable defaults to TEDIT.READTABLE).
(\TK.BUILD.MENU) is a function that automagically builds the help menu from the values of the above variables.
(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 267) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)) (282 42 72 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)) (282 42 72 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL)))))-ÈT,È2ÈÈ2È02Èx,È,È,È,ŠŠ8,ŠŠ8HÈÈPAGEHEADINGRUNNINGHEADCLASSICCLASSICCLASSIC
-TIMESROMAN
-MODERNMODERNMODERN
-ÿüMODERN
-ÿþMODERN
-ÿþMODERN
-MODERN
-MODERNMODERNMODERN
-
	HRULE.GETFNMODERN
-
-HRULE.GETFNMODERN
-
-HRULE.GETFNMODERN
-			HRULE.GETFNMODERN
-HRULE.GETFNMODERN3
-&>#
-~¢
-
-ß
-
-–
-
-9
-	
-
-0
-
-x	B	C
-+
-	
-
-
-a$
-5
-
-‚¹
-
-…
	
-	9*
-
-“
-
-G
-
-‘
-
-P
-
-”
-
-
-ñ
-5
-
-@
-
-1
-
-
-E
-
-àð
-

17=97.!$}:
-
-
-çèÍÆ¨
-
-X
-
-
-þ
-
-ª
-
--
-(
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-#
-
-
-
-
-
-
-
-=
-
-
-
-
-
-

-
-
-4„¯
-
-
-T
-á&`O
-
-²
-
-q
-
-ñQd
-
-k
-
-v
-
-
-
-ƒ
-
-r
-
-²
-
-#
-
-C
-
-U
-
-C
-
-7
-
-'b
-
-	M		
-
-]
-3f³zº
\ No newline at end of file
diff --git a/obsolete/lispusers/TKDORADO b/obsolete/lispusers/TKDORADO
deleted file mode 100644
index 58923d3f..00000000
--- a/obsolete/lispusers/TKDORADO
+++ /dev/null
@@ -1,243 +0,0 @@
-(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10)
-(FILECREATED "16-Apr-87 17:28:48" {ERIS}<LISPUSERS>LYRIC>TKDORADO.;5 14764  
-
-      changes to%:  (VARS TKDORADOCOMS)
-                    (FNS \TKD.SETLOOKS)
-
-      previous date%: "14-Apr-87 17:10:44" {ERIS}<LISPUSERS>LYRIC>TKDORADO.;4)
-
-
-(* "
-Copyright (c) 1986, 1987 by Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT TKDORADOCOMS)
-
-(RPAQQ TKDORADOCOMS [(FILES TEDITKEY)
-                     (FNS \TKD.SETLOOKS)
-                     (P [SETQ TEDITKEY.KEYBINDINGS
-                              (UNION (APPEND TEDITKEY.KEYBINDINGS '(NIL))
-                                     '(([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (if (ZEROP (fetch DCH of SEL))
-                                                   then
-                                                   (\TK.DEFAULTS.CARET TEXTSTREAM TEXTOBJ SEL)
-                                                   else
-                                                   (\TK.DEFAULTSSEL TEXTSTREAM TEXTOBJ SEL]
-                                        (%##^V)
-                                        "default looks")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL
-                                                      '(OVERLINE ON]
-                                        (%##^D)
-                                        "overbar on")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL
-                                                      '(OVERLINE OFF]
-                                        (%##^F)
-                                        "overbar off")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL
-                                                      '(STRIKEOUT ON]
-                                        (%##^G)
-                                        "strikethru on")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL
-                                                      '(STRIKEOUT OFF]
-                                        (%##^H)
-                                        "strikethru off")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL
-                                                      '(UNDERLINE ON]
-                                        (%##^J)
-                                        "underlining on")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL
-                                                      '(UNDERLINE OFF]
-                                        (%##^K)
-                                        "underlining off")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL
-                                                      '(WEIGHT BOLD]
-                                        (%##^B)
-                                        "bold on")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL
-                                                      '(WEIGHT MEDIUM]
-                                        (%##^N)
-                                        "bold off")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL
-                                                      '(SLOPE ITALIC]
-                                        (%##^I)
-                                        "italics on")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL
-                                                      '(SLOPE REGULAR]
-                                        (%##^O)
-                                        "italics off")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (IF (ZEROP (FETCH DCH OF SEL))
-                                                   then
-                                                   (\TK.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL)
-                                                   else
-                                                   (\TK.SMALLERSEL TEXTSTREAM TEXTOBJ SEL]
-                                        (|##^[|)
-                                        "smaller font")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (IF (ZEROP (FETCH DCH OF SEL))
-                                                   then
-                                                   (\TK.LARGER.CARET TEXTSTREAM TEXTOBJ SEL)
-                                                   else
-                                                   (\TK.LARGERSEL TEXTSTREAM TEXTOBJ SEL]
-                                        (|##^]|)
-                                        "larger font")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (IF (ZEROP (FETCH DCH OF SEL))
-                                                   then
-                                                   (\TK.SUPERSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL)
-                                                   else
-                                                   (\TK.SUPERSCRIPTSEL TEXTSTREAM TEXTOBJ SEL]
-                                        (%##^^)
-                                        "superscript")
-                                       ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                               (IF (ZEROP (FETCH DCH OF SEL))
-                                                   then
-                                                   (\TK.SUBSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL)
-                                                   else
-                                                   (\TK.SUBSCRIPTSEL TEXTSTREAM TEXTOBJ SEL]
-                                        (%##^_)
-                                        "subscript")
-                                       (\TK.CENTER.SEL (%##^C)
-                                              "center, justify, ... "]
-                        (\TK.BUILD.MENU)
-                        (TEDITKEY.INSTALL)
-                        (AND (BOUNDP 'DLIONFNKEYS)
-                             (OPENWP DLIONFNKEYS)
-                             (CLOSEW DLIONFNKEYS))
-                        (TEDIT.SETSYNTAX (CHARCODE ESC)
-                               'REDO])
-(FILESLOAD TEDITKEY)
-(DEFINEQ
-
-(\TKD.SETLOOKS
-  [LAMBDA (TEXTSTREAM TEXTOBJ SEL LOOKS)                     (* ; "Edited 16-Apr-87 17:26 by mdd")
-    (if (ZEROP (fetch DCH of SEL))
-        then [LET [(charlooks (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ]
-                  [REPLACEFIELD (LISTGET [CONSTANT (LIST 'UNDERLINE (CADADR (RECORDACCESSFORM
-                                                                             'CLULINE))
-                                                         'OVERLINE
-                                                         (CADADR (RECORDACCESSFORM 'CLOLINE))
-                                                         'STRIKEOUT
-                                                         (CADADR (RECORDACCESSFORM 'CLSTRIKE))
-                                                         'SLOPE
-                                                         (CADADR (RECORDACCESSFORM 'CLITAL))
-                                                         'WEIGHT
-                                                         (CADADR (RECORDACCESSFORM 'CLBOLD]
-                                       (CAR LOOKS))
-                         charlooks
-                         (FMEMB (CADR LOOKS)
-                                '(ITALIC BOLD ON]
-                  (if (OR (AND (NEQ (CAR LOOKS)
-                                    'SLOPE)
-                               (NEQ (CAR LOOKS)
-                                    'WEIGHT))
-                          (\TK.SETFONTINLOOKS TEXTSTREAM charlooks))
-                      then (TEDIT.CARETLOOKS TEXTSTREAM charlooks)
-                           (if TEDITKEY.VERBOSE
-                               then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL]
-      else (TEDIT.LOOKS TEXTSTREAM LOOKS SEL])
-)
-[SETQ TEDITKEY.KEYBINDINGS (UNION (APPEND TEDITKEY.KEYBINDINGS '(NIL))
-                                  '(([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (if (ZEROP (fetch DCH of SEL))
-                                                then
-                                                (\TK.DEFAULTS.CARET TEXTSTREAM TEXTOBJ SEL)
-                                                else
-                                                (\TK.DEFAULTSSEL TEXTSTREAM TEXTOBJ SEL]
-                                     (%##^V)
-                                     "default looks")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(OVERLINE ON]
-                                     (%##^D)
-                                     "overbar on")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(OVERLINE OFF]
-                                     (%##^F)
-                                     "overbar off")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(STRIKEOUT ON]
-                                     (%##^G)
-                                     "strikethru on")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(STRIKEOUT OFF]
-                                     (%##^H)
-                                     "strikethru off")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(UNDERLINE ON]
-                                     (%##^J)
-                                     "underlining on")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(UNDERLINE OFF]
-                                     (%##^K)
-                                     "underlining off")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(WEIGHT BOLD]
-                                     (%##^B)
-                                     "bold on")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(WEIGHT MEDIUM]
-                                     (%##^N)
-                                     "bold off")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(SLOPE ITALIC]
-                                     (%##^I)
-                                     "italics on")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(SLOPE REGULAR]
-                                     (%##^O)
-                                     "italics off")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (IF (ZEROP (FETCH DCH OF SEL))
-                                                then
-                                                (\TK.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL)
-                                                else
-                                                (\TK.SMALLERSEL TEXTSTREAM TEXTOBJ SEL]
-                                     (|##^[|)
-                                     "smaller font")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (IF (ZEROP (FETCH DCH OF SEL))
-                                                then
-                                                (\TK.LARGER.CARET TEXTSTREAM TEXTOBJ SEL)
-                                                else
-                                                (\TK.LARGERSEL TEXTSTREAM TEXTOBJ SEL]
-                                     (|##^]|)
-                                     "larger font")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (IF (ZEROP (FETCH DCH OF SEL))
-                                                then
-                                                (\TK.SUPERSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL)
-                                                else
-                                                (\TK.SUPERSCRIPTSEL TEXTSTREAM TEXTOBJ SEL]
-                                     (%##^^)
-                                     "superscript")
-                                    ([LAMBDA (TEXTSTREAM TEXTOBJ SEL)
-                                            (IF (ZEROP (FETCH DCH OF SEL))
-                                                then
-                                                (\TK.SUBSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL)
-                                                else
-                                                (\TK.SUBSCRIPTSEL TEXTSTREAM TEXTOBJ SEL]
-                                     (%##^_)
-                                     "subscript")
-                                    (\TK.CENTER.SEL (%##^C)
-                                           "center, justify, ... "]
-(\TK.BUILD.MENU)
-(TEDITKEY.INSTALL)
-(AND (BOUNDP 'DLIONFNKEYS)
-     (OPENWP DLIONFNKEYS)
-     (CLOSEW DLIONFNKEYS))
-(TEDIT.SETSYNTAX (CHARCODE ESC)
-       'REDO)
-(PUTPROPS TKDORADO COPYRIGHT ("Xerox Corporation" 1986 1987))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (7206 9013 (\TKD.SETLOOKS 7216 . 9011)))))
-STOP
diff --git a/obsolete/lispusers/TKDORADO.TEDIT b/obsolete/lispusers/TKDORADO.TEDIT
deleted file mode 100644
index a667eec2..00000000
Binary files a/obsolete/lispusers/TKDORADO.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/UPCSTATS b/obsolete/lispusers/UPCSTATS
deleted file mode 100644
index 90daba92..00000000
--- a/obsolete/lispusers/UPCSTATS
+++ /dev/null
@@ -1,297 +0,0 @@
-(FILECREATED "11-Oct-84 14:34:16" {ERIS}<LISPCORE>LIBRARY>UPCSTATS.;3 9157   
-
-      changes to:  (FNS UPCSTATS)
-
-      previous date: "12-NOV-82 12:47:49" {ERIS}<LISPCORE>LIBRARY>UPCSTATS.;1)
-
-
-(* Copyright (c)  by NIL. All rights reserved.)
-
-(PRETTYCOMPRINT UPCSTATSCOMS)
-
-(RPAQQ UPCSTATSCOMS ((VARS IMSIZE)
-		     (FNS GATHERUPCSTATS PRINTCUMULATIVEPERCENT PRINTUPC UPCSTATS)
-		     (FNS READMBFILE READNAME)
-		     (FNS PLOTPCS)
-		     (INITVARS (STATSBUFFER)
-			       (VIRTOREAL)
-			       (VIRTONAME))
-		     (VARS (UPCTHRESHOLD 0 (* lower threshold for percentage to show up on Microcode 
-					      PC Sample histogram)))
-		     (MACROS BIN2 UPCCOUNT)))
-
-(RPAQQ IMSIZE 4096)
-(DEFINEQ
-
-(GATHERUPCSTATS
-  [LAMBDA (FORM)                                             (* lmm "12-NOV-82 12:45")
-    (DECLARE (GLOBALVARS STATSBUFFER))
-    (OR STATSBUFFER (SETQ STATSBUFFER (\ALLOCLOCKED IMSIZE)))
-    [\ZEROWORDS STATSBUFFER (\ADDBASE STATSBUFFER (SUB1 (ITIMES IMSIZE (PROG1 2 
-                                                             (* words per fixp)]
-    [RESETVARS ((STRF T)
-		(LCFIL))
-	       (COMPILE1 (QUOTE STATSDUMMYFUNCTION)
-			 (BQUOTE (LAMBDA NIL ((OPCODES UPCTRACE)
-					  STATSBUFFER)
-					 , FORM ((OPCODES UPCTRACE)
-					  NIL]
-    (STATSDUMMYFUNCTION])
-
-(PRINTCUMULATIVEPERCENT
-  [LAMBDA NIL                      (* lmm "29-SEP-80 15:56")
-    (PROGN (PRIN1 "(" NIL)
-	   (PRIN1 (FQUOTIENT (FPLUS (FTIMES 65536. CUHI)
-				    CULO)
-			     TOTAL)
-		  NIL)
-	   (PRIN1 ")" NIL])
-
-(PRINTUPC
-  [LAMBDA NIL                                                (* lmm "12-NOV-82 11:40")
-    (COND
-      (UPCSEEN (do (PRIN1 "Use .MB file: " T)
-		   (SETQ MBFILE (READ T T)) repeatuntil (OR (EQ (NTHCHAR MBFILE 1)
-								(QUOTE {))
-							    (EQ MBFILE (QUOTE NIL:))
-							    (INFILEP MBFILE)))
-	       (READMBFILE MBFILE)
-	       (PRIN1 "Microcode PC Sample: ")
-	       (PLOTPCS)))
-    (STATSDUMMYFUNCTION])
-
-(UPCSTATS
-  [LAMBDA (FORM DOLISTFLG)                                   (* gbn "11-Oct-84 14:33")
-    (PROG ((STRF T)
-	   (LCFIL))
-          (DECLARE (SPECVARS STRF LCFIL))
-          (IF (NOT (EQ (MACHINETYPE)
-		       (QUOTE DORADO)))
-	      THEN (PRINTOUT T " UPCSTATS  only runs on Dorados")
-		   (RETURN))
-          (GATHERUPCSTATS FORM)
-          (READMBFILE)
-          (PLOTPCS])
-)
-(DEFINEQ
-
-(READMBFILE
-  [LAMBDA (MBFILE)                                           (* lmm "12-NOV-82 12:31")
-    (OR MBFILE (do (PRIN1 "Use .MB file: " T)
-		   (SETQ MBFILE (READ T T)) repeatuntil (INFILEP MBFILE)))
-    (PROG ((INX (GETOFD (SETQ MBFILE (OPENFILE MBFILE (QUOTE INPUT)
-					       (QUOTE OLD)
-					       8))
-			(QUOTE INPUT)))
-	   (CURMEMWIDTH 0)
-	   (CURMEM 0)
-	   (CURLOC 0)
-	   IM BLOCKTYPE)
-          (SETQ MEMORIES)
-          (OR VIRTOREAL (SETQ VIRTOREAL (ARRAY IMSIZE (QUOTE SMALLP)
-					       0 0)))
-          (OR VIRTONAME (SETQ VIRTONAME (ARRAY IMSIZE (QUOTE POINTER)
-					       NIL 0)))
-      LP  (SELECTQ (SETQ BLOCKTYPE (BIN2 INX))
-		   (0 (RETURN))
-		   [1 (COND
-			((EQ CURMEM IM)
-			  (BIN2 INX)                         (* source line #)
-			  (BIN2 INX)                         (* bits 0 to 15)
-			  (BIN2 INX)                         (* bits 16 to 31)
-			  (BIN2 INX)                         (* bits 32 to 47)
-			  (FASTSETAW VIRTOREAL (PROG1 CURLOC (add CURLOC 1))
-				     (LOGAND (BIN2 INX)
-					     4095))          (* bits 48 to 63)
-			  )
-			(T (BIN2 INX)
-			   (FRPTQ CURMEMWIDTH (BIN2 INX]
-		   (2 (SETQ CURMEM (BIN2 INX))
-		      (SETQ CURLOC (BIN2 INX))
-		      (SETQ CURMEMWIDTH (IQUOTIENT (IPLUS (CADR (OR (FASSOC CURMEM MEMORIES)
-								    (HELP)))
-							  15)
-						   16)))
-		   [3                                        (* FIXUP MEM# LOC FIRSTBIT,,LASTBIT VALUE)
-		      (COND
-			((EQ (BIN2 INX)
-			     IM)
-			  (HELP))
-			(T (BIN2 INX)
-			   (BIN2 INX)
-			   (BIN2 INX]
-		   [4 (push MEMORIES (LIST (BIN2 INX)
-					   (BIN2 INX)
-					   (READNAME INX)))
-		      (COND
-			((EQ (CADDR (CAR MEMORIES))
-			     (QUOTE IM))
-			  (SETQ IM (CAAR MEMORIES))
-			  (OR (EQ (CADAR MEMORIES)
-				  64)
-			      (HELP (QUOTE IM)
-				    "wrong # bits"]
-		   [5                                        (* symbol location)
-		      (COND
-			((EQ (BIN2 INX)
-			     IM)
-			  (FASTSETA VIRTONAME (BIN2 INX)
-				    (READNAME INX)))
-			(T (BIN2 INX)
-			   (READNAME INX T]
-		   (6 (BIN2 INX)
-		      (BIN2 INX)
-		      (BIN2 INX)
-		      (READNAME INX T))
-		   (HELP))
-          (GO LP))
-    (CLOSEF MBFILE])
-
-(READNAME
-  [LAMBDA (J FLG)                  (* lmm "16-MAY-81 16:51")
-    (bind EVENBYTE CH CHARS do (COND
-				 [(ZEROP (SETQ CH (\BIN J)))
-				   (RETURN (PROG1 (OR FLG (PACKC (DREVERSE CHARS)))
-						  (COND
-						    ((NOT EVENBYTE)
-						      (\BIN J]
-				 (T (SETQ EVENBYTE (NOT EVENBYTE))
-				    (push CHARS CH])
-)
-(DEFINEQ
-
-(PLOTPCS
-  [LAMBDA (ALLFLG)                                           (* lmm "12-NOV-82 12:29")
-    (PROG (NAME (INC 0)
-		LASTPRINTEDNAME V CNTPERSTAR (BIGGEST 0)
-		(2NDBIGGEST 0)
-		(3RDBIGGEST 0)
-		(TOTHI 0)
-		(TOTLO 0)
-		CUM HALFSTAR MAXSTARS LASTSTARPOS NSTARS TABPOS THRESHOLD TOTAL (CUHI 0)
-		(CULO 0))
-          (PRIN1 "Microcode PC Sample: ")
-          [for I from 0 to (SUB1 IMSIZE) do (COND
-					      ((NEQ (SETQ V (UPCCOUNT I))
-						    0)
-						(add TOTHI (LRSH V 16))
-						(add TOTLO (LOGAND V 65535))
-						(COND
-						  ((IGREATERP V 3RDBIGGEST)
-						    (COND
-						      [(IGREATERP V 2NDBIGGEST)
-							(COND
-							  ((IGREATERP V BIGGEST)
-							    (SETQ BIGGEST V))
-							  (T (SETQ 2NDBIGGEST V]
-						      (T (SETQ 3RDBIGGEST V]
-                                                             (* Each line has (NAME 14) (+nnn 4) 
-							     (%| 1) stars ((nn.nnnn%%) 10) + 2 for luck)
-          (SETQ MAXSTARS (IDIFFERENCE [SETQ LASTSTARPOS (IDIFFERENCE (LINELENGTH)
-								     (COND
-								       (ALLFLG 20)
-								       (T 12]
-				      20))
-          (SETQ CNTPERSTAR (IQUOTIENT 3RDBIGGEST MAXSTARS))
-          (SETQ HALFSTAR (IQUOTIENT CNTPERSTAR 2))
-          (SETQ TOTAL (FPLUS TOTLO (FTIMES TOTHI 65536.0)))
-          [SETQ THRESHOLD (COND
-	      (ALLFLG 0)
-	      (T (IMAX HALFSTAR (FIX (QUOTIENT (TIMES UPCTHRESHOLD CNTPERSTAR)
-					       TOTAL]
-          (SETQ TOTAL (FQUOTIENT TOTAL 100.0))
-          (printout NIL " Each * = " CNTPERSTAR " count, or " .F8.2 (FQUOTIENT CNTPERSTAR TOTAL)
-		    "%%")
-          [for VPC from 0 to (SUB1 IMSIZE)
-	     do [COND
-		  ((SETQ V (FASTELT VIRTONAME VPC))
-		    (SETQ NAME V)
-		    (SETQ INC 0))
-		  (T (SETQ INC (ADD1 INC]
-		(SETQ V (UPCCOUNT (FASTELTW VIRTOREAL VPC)))
-		(COND
-		  (ALLFLG (COND
-			    [(NEQ NAME LASTPRINTEDNAME)
-			      (COND
-				(LASTPRINTEDNAME             (* don't do it the first time)
-						 (TAB LASTSTARPOS)
-						 (PRINTCUMULATIVEPERCENT)))
-			      (TERPRI)
-			      (PRIN1 (COND
-				       ((IGREATERP (SETQ TABPOS (NCHARS (SETQ LASTPRINTEDNAME NAME)))
-						   14)
-					 (SUBSTRING NAME 1 (SETQ TABPOS 14)))
-				       (T NAME]
-			    (T (TERPRI)
-			       (SPACES TABPOS)))
-			  (add CUHI (LRSH V 16))
-			  (add CULO (LOGAND V 65535))
-			  (COND
-			    ((NEQ INC 0)
-			      (printout NIL "+" .I3...T INC)))
-			  (TAB 18)
-			  (printout NIL "#" .I8.4 (FASTELTW VIRTOREAL VPC)
-				    "  " .I10 V))
-		  ((IGREATERP V THRESHOLD)
-		    (COND
-		      [(NEQ NAME LASTPRINTEDNAME)
-			(COND
-			  (LASTPRINTEDNAME                   (* don't do it the first time)
-					   (TAB LASTSTARPOS)
-					   (PRINTCUMULATIVEPERCENT)))
-			(TERPRI)
-			(PRIN1 (COND
-				 ((IGREATERP (SETQ TABPOS (NCHARS (SETQ LASTPRINTEDNAME NAME)))
-					     14)
-				   (SUBSTRING NAME 1 (SETQ TABPOS 14)))
-				 (T NAME]
-		      (T (TERPRI)
-			 (SPACES TABPOS)))
-		    (add CUHI (LRSH V 16))
-		    (add CULO (LOGAND V 65535))
-		    (COND
-		      ((NEQ INC 0)
-			(printout NIL "+" .I3...T INC)))
-		    (TAB 18)
-		    (PRIN1 "|")
-		    (FRPTQ (COND
-			     ((IGEQ (SETQ NSTARS (IQUOTIENT (IPLUS V HALFSTAR)
-							    CNTPERSTAR))
-				    MAXSTARS)
-			       (printout NIL "(" .I4 NSTARS ")")
-			       (IDIFFERENCE MAXSTARS 6))
-			     (T NSTARS))
-			   (PRIN1 "*"]
-          (TAB LASTSTARPOS)
-          (PRINTCUMULATIVEPERCENT)
-          (TERPRI)
-          (SETQ CUHI (IDIFFERENCE TOTHI CUHI))
-          (SETQ CULO (IDIFFERENCE TOTLO CULO))
-          (printout NIL T T "Not shown: ")
-          (PRINTCUMULATIVEPERCENT)
-          (TERPRI])
-)
-
-(RPAQ? STATSBUFFER )
-
-(RPAQ? VIRTOREAL )
-
-(RPAQ? VIRTONAME )
-
-(RPAQ UPCTHRESHOLD 0 (* lower threshold for percentage to show up on Microcode PC Sample histogram))
-(DECLARE: EVAL@COMPILE 
-
-(PUTPROPS BIN2 MACRO ((INX)
-		      (IPLUS (LLSH (\BIN INX)
-				   8)
-			     (\BIN INX))))
-
-(PUTPROPS UPCCOUNT MACRO [OPENLAMBDA (N)
-				     (\MAKENUMBER (\GETBASE STATSBUFFER (ADD1 (LLSH N 1)))
-						  (\GETBASE STATSBUFFER (LLSH N 1])
-)
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (698 2431 (GATHERUPCSTATS 708 . 1305) (PRINTCUMULATIVEPERCENT 1307 . 1533) (PRINTUPC 
-1535 . 1979) (UPCSTATS 1981 . 2429)) (2432 4989 (READMBFILE 2442 . 4644) (READNAME 4646 . 4987)) (4990
- 8641 (PLOTPCS 5000 . 8639)))))
-STOP
diff --git a/obsolete/lispusers/UPCSTATS.TEDIT b/obsolete/lispusers/UPCSTATS.TEDIT
deleted file mode 100644
index f45c716c..00000000
Binary files a/obsolete/lispusers/UPCSTATS.TEDIT and /dev/null differ
diff --git a/obsolete/lispusers/XORCURSORPATCH b/obsolete/lispusers/XORCURSORPATCH
deleted file mode 100644
index 29181f2d..00000000
--- a/obsolete/lispusers/XORCURSORPATCH
+++ /dev/null
@@ -1,34 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-(FILECREATED "19-Jul-88 11:37:37" {ERINYES}<LISPUSERS>LYRIC>XORCURSORPATCH.\;1 1455   
-
-      |changes| |to:|  (VARS XORCURSORPATCHCOMS)
-
-      |previous| |date:| " 7-Oct-86 18:56:37" {PHYLUM}<LISPUSERS>KOTO>XORCURSORPATCH.\;1)
-
-
-; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.
-
-(PRETTYCOMPRINT XORCURSORPATCHCOMS)
-
-(RPAQQ XORCURSORPATCHCOMS ((FNS DOVE.XOR.CURSOR) (INITVARS (|\\DoveDisplay.VideoColor| 1)) (GLOBALVARS |\\DoveDisplay.VideoColor|) (ADVISE (|\\DoveDisplay.SetVideoColor| :IN VIDEOCOLOR))))
-(DEFINEQ
-
-(DOVE.XOR.CURSOR
-(LAMBDA (FLG) (* |cdl| " 7-Oct-86 18:56") (SELECTQ (MACHINETYPE) (DOVE (|if| (EQP |\\DoveDisplay.VideoColor| 1) |then| (|if| FLG |then| (SETQ |\\DoveDisplay.VideoColor| (|if| (NUMBERP FLG) |then| FLG |else| 9))) |else| (|if| (NULL FLG) |then| (SETQ |\\DoveDisplay.VideoColor| 1))) (|\\DoveDisplay.SetCursorMix| |\\DoveDisplay.VideoColor|) T) NIL))
-)
-)
-
-(RPAQ? |\\DoveDisplay.VideoColor| 1)
-(DECLARE\: DOEVAL@COMPILE DONTCOPY
-
-
-(GLOBALVARS |\\DoveDisplay.VideoColor|)
-)
-
-(XCL:REINSTALL-ADVICE (QUOTE (|\\DoveDisplay.SetVideoColor| :IN VIDEOCOLOR)) :AFTER (QUOTE ((:LAST (SELECTQ (MACHINETYPE) (DOVE (|if| (NOT INVERSE?) |then| (|\\DoveDisplay.SetCursorMix| |\\DoveDisplay.VideoColor|))) NIL)))))
-
-(READVISE (|\\DoveDisplay.SetVideoColor| :IN VIDEOCOLOR))
-(PUTPROPS XORCURSORPATCH COPYRIGHT ("Xerox Corporation" 1988))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL (585 967 (DOVE.XOR.CURSOR 595 . 965)))))
-STOP
diff --git a/obsolete/lispusers/XORCursorPatch.TEdit b/obsolete/lispusers/XORCursorPatch.TEdit
deleted file mode 100644
index 80acd855..00000000
Binary files a/obsolete/lispusers/XORCursorPatch.TEdit and /dev/null differ
diff --git a/obsolete/lispusers/XREF b/obsolete/lispusers/XREF
deleted file mode 100644
index 7e5f195a..00000000
--- a/obsolete/lispusers/XREF
+++ /dev/null
@@ -1,311 +0,0 @@
-(FILECREATED "18-Feb-87 15:48:37" {SUMEX-AIM}PS:<TMAX.SOURCES>XREF.;6 12717  
-
-      changes to:  (VARS XREF.DISPLAY.METHODS)
-		   (FNS XREF.IMAGEBOXFN INSERT.REF)
-
-      previous date: " 5-Feb-87 14:57:51" {SUMEX-AIM}PS:<GILMURRAY.LISP>XREF.;5)
-
-
-(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.)
-
-(PRETTYCOMPRINT XREFCOMS)
-
-(RPAQQ XREFCOMS ((* Developed under support from NIH grant RR-00785.)
-		   (* Written by Frank Gilmurray and Sami Shaio.)
-		   (* An XREF is a general-purpose cross-referencing imageobject. In order to create 
-		      an instance of an XREF one simply calls the function XREF with a TAG that is 
-		      supposed to link it with some imageobject that it is referencing. In order to 
-		      add to the class of imageobjects that can be referenced with XREF one uses the 
-		      function XREF.ADD.DISPLAYFN with the type of the imageobject and a function 
-		      that operates on it to return some string that XREF will then display in the 
-		      document.)
-		   (FNS XREF XREFP XREF.DISPLAYFN XREF.IMAGEBOXFN XREF.PUTFN XREF.GETFN 
-			XREF.BUTTONEVENTINFN XREF.WHENDELETEDFN)
-		   (FNS XREF.GET.DISPLAY.TEXT XREF.GET.TOOBJ TSPOBJ.GETTYPE)
-		   (FNS UPDATE.XREFS REBUILD.TAG.ARRAY INSERT.REF GET.REF TSP.LIST.REFS 
-			XREF.TAG.OBJECT TSP.GET.INCODE TSP.GETCODEVAL TSP.PUTCODE)
-		   (* Functions for adding and retrieving the method for a gven imageobject.)
-		   (FNS XREF.ADD.DISPLAYFN XREF.GET.DISPLAYFN)
-		   (* Examples of some XREF display methods.)
-		   (FNS NGROUP.XREF.DISPLAYFN NOTE.XREF.DISPLAYFN)
-		   (UGLYVARS XREF.DISPLAY.METHODS)))
-
-
-
-(* Developed under support from NIH grant RR-00785.)
-
-
-
-
-(* Written by Frank Gilmurray and Sami Shaio.)
-
-
-
-
-(* An XREF is a general-purpose cross-referencing imageobject. In order to create an instance 
-of an XREF one simply calls the function XREF with a TAG that is supposed to link it with some 
-imageobject that it is referencing. In order to add to the class of imageobjects that can be 
-referenced with XREF one uses the function XREF.ADD.DISPLAYFN with the type of the imageobject 
-and a function that operates on it to return some string that XREF will then display in the 
-document.)
-
-(DEFINEQ
-
-(XREF
-  (LAMBDA (TAG)                                              (* edited: "28-Jan-87 12:53")
-
-          (* Returns a new XREF imageobject. The TAG argument is obligatory and should be the tag that is used to reference 
-	  the object that this XREF object is referencing.)
-
-
-    (LET ((NEWOBJ (IMAGEOBJCREATE TAG (IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN)
-							  (FUNCTION XREF.IMAGEBOXFN)
-							  (FUNCTION XREF.PUTFN)
-							  (FUNCTION XREF.GETFN)
-							  (FUNCTION NILL)
-							  (FUNCTION XREF.BUTTONEVENTINFN)
-							  (FUNCTION NILL)
-							  (FUNCTION NILL)
-							  (FUNCTION NILL)
-							  (FUNCTION NILL)
-							  (FUNCTION NILL)
-							  (FUNCTION NILL)
-							  (FUNCTION NILL)))))
-         (IMAGEOBJPROP NEWOBJ 'TYPE
-			 'XREF)
-     NEWOBJ)))
-
-(XREFP
-  (LAMBDA (OBJ)                                              (* edited: "22-Jan-87 21:20")
-                                                             (* Test whether something is an XREF imageobject.)
-    (AND (IMAGEOBJP OBJ)
-	   (EQ (IMAGEOBJPROP OBJ 'TYPE)
-		 'XREF))))
-
-(XREF.DISPLAYFN
-  (LAMBDA (OBJ STREAM)                                       (* edited: "22-Jan-87 21:09")
-                                                             (* General purpose display function for an XREF 
-							     imageobject. Relies on XREF.GET.DISPLAY.TEXT to get 
-							     the actual text that must be displayed.)
-    (LET* ((TEXT.TO.DISPLAY (XREF.GET.DISPLAY.TEXT OBJ)))
-          (PRIN3 TEXT.TO.DISPLAY STREAM))))
-
-(XREF.IMAGEBOXFN
-  (LAMBDA (OBJ STREAM)                                       (* fsg "18-Feb-87 15:35")
-                                                             (* Returns the size of an XREF imageobject based on 
-							     the string that will be used to display it which is 
-							     found using XREF.GET.DISPLAY.TEXT.)
-    (DSPFONT (CURRENT.DISPLAY.FONT STREAM)
-	       STREAM)
-    (create IMAGEBOX
-	      XSIZE _(TEDIT.STRINGWIDTH (XREF.GET.DISPLAY.TEXT OBJ)
-					  STREAM)
-	      YSIZE _(FONTPROP STREAM 'HEIGHT)
-	      YDESC _(FONTPROP STREAM 'DESCENT)
-	      XKERN _ 0)))
-
-(XREF.PUTFN
-  (LAMBDA (OBJ STREAM)                                       (* edited: "28-Jan-87 12:54")
-    (PRIN1 (LIST 'XREF
-		     (fetch OBJECTDATUM of OBJ))
-	     STREAM)))
-
-(XREF.GETFN
-  (LAMBDA (STREAM)                                           (* edited: "28-Jan-87 13:14")
-    (XREF (CADR (READ STREAM)))))
-
-(XREF.BUTTONEVENTINFN
-  (LAMBDA (OBJ STREAM)                                       (* edited: "28-Jan-87 14:51")
-                                                             (* Bogus buttoneventinfn to tell you what the tag of 
-							     this XREF object is.)
-    (TEDIT.PROMPTPRINT STREAM (CONCAT "Reference to: " (fetch OBJECTDATUM of OBJ))
-			 T)))
-
-(XREF.WHENDELETEDFN
-  (LAMBDA (IMOBJ TARG.WINDOW.STREAM SOURCE.STR TARG.STR)     (* fsg " 4-Feb-87 13:26")
-    (TSP.PUTCODE (IMAGEOBJPROP IMOBJ 'TAG)
-		   NIL TARG.WINDOW.STREAM)
-    (AND (UPDATE? TARG.WINDOW.STREAM)
-	   (UPDATE.XREFS TARG.WINDOW.STREAM))))
-)
-(DEFINEQ
-
-(XREF.GET.DISPLAY.TEXT
-  (LAMBDA (OBJ)                                              (* edited: "22-Jan-87 21:11")
-
-          (* This function will first lookup a "TOOBJ", in other words, the imageobject that the XREF object OBJ is 
-	  referencing. Then, if there is such an object, a suitable XREF display method is found using XREF.GET.DISPLAYFN.
-	  If such a function is found, then it is applied to TOOBJ and a string to be displayed is returned.)
-
-
-    (LET ((TOOBJ (XREF.GET.TOOBJ (fetch OBJECTDATUM of OBJ)))
-	  SPECIFIC.DISPLAYFN)
-         (COND
-	   (TOOBJ (COND
-		    ((SETQ SPECIFIC.DISPLAYFN (XREF.GET.DISPLAYFN TOOBJ))
-		      (APPLY* SPECIFIC.DISPLAYFN TOOBJ))
-		    (T (RINGBELLS)
-		       (CONCAT "??? Unknown XREF display method for " (TSPOBJ.GETTYPE TOOBJ)
-				 " ???"))))
-	   (T (CONCAT "<reference to: " (fetch OBJECTDATUM of OBJ)
-			">"))))))
-
-(XREF.GET.TOOBJ
-  (LAMBDA (TAG)                                              (* edited: "22-Jan-87 19:41")
-
-          (* This function is called in a specific context where a reference must be displayed. It is called by an XREF 
-	  object and should return the IMAGEOBJECT that the XREF object is referencing.)
-
-
-    (LET ((WINDOW (CAR (fetch \WINDOW of TEXTOBJ))))
-         (GETHASH TAG (WINDOWPROP WINDOW 'TSP.CODE.ARRAY)))))
-
-(TSPOBJ.GETTYPE
-  (LAMBDA (OBJ)                                              (* edited: "22-Jan-87 20:16")
-    (IMAGEOBJPROP OBJ 'TYPE)))
-)
-(DEFINEQ
-
-(UPDATE.XREFS
-  (LAMBDA (WINDOW)                                           (* edited: "22-Jan-87 21:05")
-                                                             (* Update all the XREF objects in the window.)
-    (LET* ((TEXTOBJ (TEXTOBJ WINDOW))
-	   (STREAM (TEXTSTREAM WINDOW)))
-          (TEDIT.PROMPTPRINT STREAM "Updating XRefs..." T)
-          (for REF in (TSP.LIST.OF.OBJECTS TEXTOBJ (FUNCTION XREFP))
-	     do (TEDIT.OBJECT.CHANGED STREAM (CAR REF)))
-          (TEDIT.PROMPTPRINT STREAM "done."))))
-
-(REBUILD.TAG.ARRAY
-  (LAMBDA (WINDOW)                                           (* edited: "28-Jan-87 13:24")
-    (for TAG in (TSP.LIST.OF.OBJECTS (TEXTOBJ WINDOW)
-					   (FUNCTION (LAMBDA (OBJ)
-					       (AND (NUMBEROBJP OBJ)
-						      (OR (IMAGEOBJPROP OBJ 'TAG)
-							    (EQ (fetch USE
-								     of (fetch OBJECTDATUM
-									     of OBJ))
-								  'NGROUP))))))
-       do (PROGN (SETQ TAG (CAR TAG))
-		     (TSP.PUTCODE (OR (IMAGEOBJPROP TAG 'TAG)
-					  (fetch LINK.TO of (fetch OBJECTDATUM of TAG)))
-				    TAG WINDOW)))))
-
-(INSERT.REF
-  (LAMBDA (STREAM DISPLAY.PREV)                              (* edited: "22-Jan-87 21:01")
-    (LET* ((WINDOW (\TEDIT.MAINW STREAM))
-	   (CODE (GET.REF WINDOW STREAM "Reference to: " DISPLAY.PREV))
-	   (REF (XREF CODE)))
-          (AND CODE (TEDIT.INSERT.OBJECT REF STREAM))
-          (TEDIT.PROMPTPRINT STREAM "" T))))
-
-(GET.REF
-  (LAMBDA (WINDOW STREAM PROMPTSTR DISPLAY.PREV)             (* ss: " 9-Aug-85 14:49")
-    (LET ((PREVREFS (TSP.LIST.REFS WINDOW)))
-         (COND
-	   ((AND PREVREFS DISPLAY.PREV)
-	     (LET ((NMENU (create MENU
-				    TITLE _ "Known Ref Codes"
-				    ITEMS _ PREVREFS)))
-	          (MENU NMENU)))
-	   (T (MKATOM (TEDIT.GETINPUT STREAM "Reference to: ")))))))
-
-(TSP.LIST.REFS
-  (LAMBDA (WINDOW)                                           (* fsg "15-Jan-87 14:08")
-
-          (* * Don't collect the Index or IndexEntry references here. Use the INDEX.LIST.REFS function.)
-
-
-    (LET ((REFLIST NIL))
-         (MAPHASH (WINDOWPROP WINDOW 'TSP.CODE.ARRAY)
-		    (FUNCTION (LAMBDA (VAL KY)
-			(SETQ REFLIST (CONS KY REFLIST)))))
-     REFLIST)))
-
-(XREF.TAG.OBJECT
-  (LAMBDA (OBJ STREAM TAG)                                   (* fsg " 4-Feb-87 16:35")
-
-          (* TAG an arbitrary imageobject for later cross-referencing. given an imageobject OBJ, a textstream STREAM, and a 
-	  tag TAG. If TAG is nil then the user will be asked for a tag via TSP.GET.INCODE.)
-
-
-    (OR TAG (SETQ TAG (TSP.GET.INCODE WINDOW)))
-    (IMAGEOBJPROP OBJ 'TAG
-		    TAG)
-    (TSP.PUTCODE TAG OBJ WINDOW)))
-
-(TSP.GET.INCODE
-  (LAMBDA (STREAM)                                           (* ss: "24-Apr-86 15:46")
-    (LET ((CODE (MKATOM (TEDIT.GETINPUT STREAM "Codeword to use as a tag:"))))
-         (COND
-	   (CODE (COND
-		   ((TSP.GETCODEVAL CODE (\TEDIT.MAINW STREAM))
-		     (TEDIT.PROMPTPRINT STREAM "[Codeword already in use: Please try again]")
-		     (TSP.GET.INCODE STREAM))
-		   (T (TEDIT.PROMPTPRINT STREAM "" T)
-		      CODE)))
-	   (T (TEDIT.PROMPTPRINT STREAM "" T))))))
-
-(TSP.GETCODEVAL
-  (LAMBDA (CODE WINDOW)                                      (* fsg " 4-Feb-87 14:32")
-    (LET ((TSP.CODE.ARRAY (WINDOWPROP WINDOW 'TSP.CODE.ARRAY)))
-         (GETHASH CODE TSP.CODE.ARRAY))))
-
-(TSP.PUTCODE
-  (LAMBDA (CODE VALUE WINDOW)                                (* fsg " 4-Feb-87 14:34")
-    (PUTHASH CODE VALUE (LIST (WINDOWPROP WINDOW 'TSP.CODE.ARRAY)))))
-)
-
-
-
-(* Functions for adding and retrieving the method for a gven imageobject.)
-
-(DEFINEQ
-
-(XREF.ADD.DISPLAYFN
-  (LAMBDA (OBJTYPE NAME.OF.FUNCTION)                         (* edited: "22-Jan-87 21:08")
-
-          (* Adds an XREF display method for an imageobject of the given type. This means that the function NAME.OF.FUNCTION 
-	  will be used to display text when an XREF object references an imageobject of type OBJTYPE.)
-
-
-    (PUTHASH OBJTYPE NAME.OF.FUNCTION XREF.DISPLAY.METHODS)))
-
-(XREF.GET.DISPLAYFN
-  (LAMBDA (OBJ)                                              (* edited: "22-Jan-87 21:11")
-                                                             (* Returns the XREF display method for an imageobject 
-							     OBJ.)
-    (GETHASH (fetch USE of (fetch OBJECTDATUM of OBJ))
-	       XREF.DISPLAY.METHODS)))
-)
-
-
-
-(* Examples of some XREF display methods.)
-
-(DEFINEQ
-
-(NGROUP.XREF.DISPLAYFN
-  (LAMBDA (NGROUP)                                           (* edited: "29-Jan-87 16:07")
-                                                             (* A sample XREF display method for NGROUP objects.)
-    (MKSTRING (fetch NUMSTRING of (fetch OBJECTDATUM of NGROUP)))))
-
-(NOTE.XREF.DISPLAYFN
-  (LAMBDA (OBJ)                                              (* edited: "29-Jan-87 16:07")
-                                                             (* A sample XREF display method for NOTE objects.)
-    (MKSTRING (fetch NUMSTRING of (fetch OBJECTDATUM of OBJ)))))
-)
-(READVARS XREF.DISPLAY.METHODS)
-({H(20 ERROR) 2 NGROUP.XREF.DISPLAYFN NGROUP NOTE.XREF.DISPLAYFN NOTE })
-(PUTPROPS XREF COPYRIGHT ("Leland Stanford Junior University" 1987))
-(DECLARE: DONTCOPY
-  (FILEMAP ((7675) (2226 5527 (XREF 2236 . 3078) (XREFP 3080 . 3388) (XREF.DISPLAYFN 3390 . 3854) (
-XREF.IMAGEBOXFN 3856 . 4491) (XREF.PUTFN 4493 . 4693) (XREF.GETFN 4695 . 4851) (XREF.BUTTONEVENTINFN 
-4853 . 5238) (XREF.WHENDELETEDFN 5240 . 5525)) (5528 7093 (XREF.GET.DISPLAY.TEXT 5538 . 6475) (
-XREF.GET.TOOBJ 6477 . 6940) (TSPOBJ.GETTYPE 6942 . 7091)) (7094 NIL (UPDATE.XREFS 7104 . 7674)))))
-STOP
-TAG.ARRAY 7854 . 8516) (INSERT.REF 8520 . 8889) (GET.REF 8893 . 9308) (TSP.LIST.REFS 9312 . 
-9730) (XREF.TAG.OBJECT 9734 . 10217) (TSP.GET.INCODE 10221 . 10753) (TSP.GETCODEVAL 10757 . 10984) (
-TSP.PUTCODE 10988 . 11179)) (11272 12087 (XREF.ADD.DISPLAYFN 11284 . 11708) (XREF.GET.DISPLAYFN 11712
- . 12084)) (12145 12817 (NGROUP.XREF.DISPLAYFN 12157 . 12487) (NOTE.XREF.DISPLAYFN 12491 . 12814)))))
-STOP
diff --git a/obsolete/lispusers/c150fonts/C150STREAM b/obsolete/lispusers/c150fonts/C150STREAM
deleted file mode 100644
index 44366442..00000000
--- a/obsolete/lispusers/c150fonts/C150STREAM
+++ /dev/null
@@ -1,2193 +0,0 @@
-(FILECREATED " 3-Apr-86 18:16:05" {ERIS}<LISPCORE>LIBRARY>C150STREAM.;15 139806 
-
-      changes to:  (FNS CREATEC150BUFFER)
-                   (VARS C150COLORMAP C150FONTDIRECTORIES)
-
-      previous date: " 3-Apr-86 16:05:11" {ERIS}<LISPCORE>LIBRARY>C150STREAM.;14)
-
-
-(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT C150STREAMCOMS)
-
-(RPAQQ C150STREAMCOMS 
-       ((CONSTANTS \C150PointsPerInch \C150RealBPP)
-        (FNS C150.SEPARATOR C150.SETMARGINS \C150.ALLWHITESPACE \C150.BUFFER.DOT \C150.MICROLINEFEED 
-             \C150.SENDLINE \C150.SENDLINEINFO \C150INIT \CREATECHARSET.C150)
-        (FNS CREATEC150BUFFER NEWLINE.C150 NEWPAGE.C150 OPENC150STREAM C150.RESET SEND.TO.C150 
-             STARTPAGE.C150 \BITBLT.C150 \BLTCHAR.C150 \BLTSHADE.C150 \C150.CRLF \CHANGECHARSET.C150 
-             \CHARWIDTH.C150 \CLOSEFN.C150 \CREATEC150FONT \READC150FONTFILE \DRAWCIRCLE.C150 
-             \DRAWCURVE.C150 \DRAWELLIPSE.C150 \DRAWLINE.C150 \DSPBACKCOLOR.C150 
-             \DSPCLIPPINGREGION.C150 \DSPCOLOR.C150 \C150.ASSURE.COLOR \C150.LOOKUPRGB \DSPFONT.C150 
-             \DSPLEFTMARGIN.C150 \DSPLINEFEED.C150 \DSPOPERATION.C150 \DSPPRINTCHAR.C150 
-             \DSPPRINTCR/LF.C150 \DSPRESET.C150 \DSPRIGHTMARGIN.C150 \DSPXPOSITION.C150 
-             \DSPYPOSITION.C150 \DUMPPAGEBUFFER.C150 \FILLCIRCLE.C150 \OUTCHARFN.C150 
-             \SEARCHC150FONTFILES \STRINGWIDTH.C150)
-        (VARS MISSINGC150FONTCOERCIONS (\C150COLORTABLE)
-              (\C150.FRAMEBUFFER)
-              (\C150STREAM)
-              C150COLORMAP C150FONTCOERCIONS C150FONTDIRECTORIES C150FONTEXTENSIONS)
-        (INITVARS (C150.CLIPBUFFER T)
-               (\C150DEFAULTDEVICE (QUOTE CENTRONICS)))
-        (FNS COLORMAP.TO.C150TABLE)
-        (FILES COLOR XXGEOM XXFILL)
-        [P (IF (NOT (GETD (QUOTE POLYSHADE.BLT)))
-               THEN
-               (* A fix for KOTO, which is not necessary in <lc>n>)
-               (MOVD (QUOTE POLYSHADE.DISPLAY)
-                     (QUOTE POLYSHADE.BLT]
-        (DECLARE: DONTEVAL@LOAD DOCOPY (P (\C150INIT))
-               (FILES CENTRONICS))
-        (DECLARE: EVAL@LOAD DONTCOPY (FILES (LOADFROM)
-                                            ADISPLAY LLDISPLAY))
-        (MACROS \C150BackingStream)))
-(DECLARE: EVAL@COMPILE 
-
-(RPAQQ \C150PointsPerInch 120)
-
-(RPAQQ \C150RealBPP 4)
-
-(CONSTANTS \C150PointsPerInch \C150RealBPP)
-)
-(DEFINEQ
-
-(C150.SEPARATOR
-  [LAMBDA (BACKINGSTREAM)                                                  (* hdj 
-                                                                           " 5-Sep-85 12:12")
-    (LET ((SEPR.LENGTH 30))
-         (for C instring (CONCAT "g0" SEPR.LENGTH " ") do (BOUT BACKINGSTREAM C))
-         (for DASH from 1 to SEPR.LENGTH do (BOUT BACKINGSTREAM 255])
-
-(C150.SETMARGINS
-  [LAMBDA (BACKINGSTREAM C150LEFT C150RIGHT)                               (* hdj 
-                                                                           " 5-Sep-85 12:21")
-            
-            (* * Set the left and right margins for the C150 printer)
-
-    (LET [[LEFTCODE (CONCAT (FIX (TIMES 10 (if (OR (EQ C150LEFT NIL)
-                                                   (LESSP C150LEFT .5)
-                                                   (GEQ C150LEFT 9.0)
-                                                   (GEQ C150LEFT C150RIGHT))
-                                               then .5
-                                             else C150LEFT]
-          (RIGHTCODE (CONCAT (FIX (TIMES 10 (if (OR (EQ C150RIGHT NIL)
-                                                    (GREATERP C150RIGHT 9)
-                                                    (LEQ C150RIGHT .5)
-                                                    (LEQ C150RIGHT C150LEFT))
-                                                then 9
-                                              else C150RIGHT]              (* send the left margin)
-         (BOUT BACKINGSTREAM (CHARCODE ESC))
-         (BOUT BACKINGSTREAM (CHARCODE l))
-         (for CHAR instring LEFTCODE do (BOUT BACKINGSTREAM CHAR))
-         (BOUT BACKINGSTREAM (CHARCODE CR))                                (* send the right 
-                                                                           margin)
-         (BOUT BACKINGSTREAM (CHARCODE ESC))
-         (BOUT BACKINGSTREAM (CHARCODE r))
-         (for CHAR instring RIGHTCODE do (BOUT BACKINGSTREAM CHAR))
-         (BOUT BACKINGSTREAM (CHARCODE CR])
-
-(\C150.ALLWHITESPACE
-  [LAMBDA (BITMAP TABLES STARTINGSCAN)                                     (* hdj 
-                                                                           " 6-Aug-85 15:50")
-                                                                           (* is there anything to 
-                                                                           print on the next 4 
-                                                                           scanlines?)
-    (LET*((MaxX (SUB1 (BITMAPWIDTH BITMAP)))
-          [MaxColor (SUB1 (EXPT 2 (BITSPERPIXEL BITMAP]
-          (COLORUSED? (ARRAY (ADD1 MaxColor)
-                             (QUOTE POINTER)
-                             NIL 0))
-          (BlackTable (ELT TABLES 0))
-          (MagentaTable (ELT TABLES 1))
-          (YellowTable (ELT TABLES 2))
-          (CyanTable (ELT TABLES 3)))
-     (for Scanline from STARTINGSCAN to (IDIFFERENCE STARTINGSCAN 3) by -1
-        do (for X from 0 to MaxX do (SETA COLORUSED? (BITMAPBIT BITMAP X Scanline)
-                                          T)))
-     (for Value from 0 to MaxColor never (AND (ELT COLORUSED? Value)
-                                              (OR (EQ (ELT BlackTable Value)
-                                                      1)
-                                                  (EQ (ELT MagentaTable Value)
-                                                      1)
-                                                  (EQ (ELT YellowTable Value)
-                                                      1)
-                                                  (EQ (ELT CyanTable Value)
-                                                      1])
-
-(\C150.BUFFER.DOT
-  [LAMBDA (DOT X BUFFER)                                                   (* hdj 
-                                                                           " 3-Aug-85 20:55")
-    (SETA BUFFER X DOT])
-
-(\C150.MICROLINEFEED
-  [LAMBDA (BACKINGSTREAM)                                                  (* hdj 
-                                                                           " 5-Sep-85 12:12")
-    (for CHAR instring "k1" do (BOUT BACKINGSTREAM CHAR])
-
-(\C150.SENDLINE
-  [LAMBDA (BACKINGSTREAM LINE# COLOR BUFFER)                               (* hdj 
-                                                                           " 5-Sep-85 12:13")
-    (for CHAR instring (CONCAT "g" (CHARACTER (IPLUS (ITIMES 4 COLOR)
-                                                      (IREMAINDER LINE# 4)
-                                                      (CHARCODE 0)))
-                              (FOLDHI (ARRAYSIZE BUFFER)
-                                     8)
-                              " ") do (BOUT BACKINGSTREAM CHAR))
-    (bind (BYTE.TO.SEND _ 0) for BYTE from 0 to (SUB1 (ARRAYSIZE BUFFER)) by 8
-       do [for BIT from 7 to 0 by -1 do (SETQ BYTE.TO.SEND (LOGOR BYTE.TO.SEND
-                                                                  (LLSH (ELT BUFFER (IPLUS BYTE BIT))
-                                                                        BIT]
-          (BOUT BACKINGSTREAM BYTE.TO.SEND])
-
-(\C150.SENDLINEINFO
-  [LAMBDA (BACKINGSTREAM COLOR LENGTHINBYTES LINE#)                        (* hdj 
-                                                                           " 5-Sep-85 12:13")
-    (for CHAR instring (CONCAT "g" (CHARACTER (IPLUS (UNFOLD COLOR 4)
-                                                      LINE#
-                                                      (CHARCODE 0)))
-                              LENGTHINBYTES " ") do (BOUT BACKINGSTREAM CHAR])
-
-(\C150INIT
-  [LAMBDA NIL                                                              (* gbn 
-                                                                           " 5-Nov-85 19:34")
-                                                                           (* Initializes global 
-                                                                           variables for the C150)
-    (DECLARE (GLOBALVARS \C150IMAGEOPS))
-    (SETQ \C150IMAGEOPS (create IMAGEOPS
-                               IMAGETYPE _(QUOTE C150)
-                               IMFONT _(FUNCTION \DSPFONT.C150)
-                               IMLEFTMARGIN _(FUNCTION \DSPLEFTMARGIN.C150)
-                               IMRIGHTMARGIN _(FUNCTION \DSPRIGHTMARGIN.C150)
-                               IMLINEFEED _(FUNCTION \DSPLINEFEED.C150)
-                               IMXPOSITION _(FUNCTION \DSPXPOSITION.C150)
-                               IMYPOSITION _(FUNCTION \DSPYPOSITION.C150)
-                               IMCLOSEFN _(FUNCTION \CLOSEFN.C150)
-                               IMDRAWCURVE _(FUNCTION \DRAWCURVE.C150)
-                               IMFILLCIRCLE _(QUOTE \FILLCIRCLE.C150)
-                               IMDRAWLINE _(FUNCTION \DRAWLINE.C150)
-                               IMDRAWELLIPSE _(FUNCTION \DRAWELLIPSE.C150)
-                               IMDRAWCIRCLE _(FUNCTION \DRAWCIRCLE.C150)
-                               IMBITBLT _(FUNCTION \BITBLT.C150)
-                               IMBLTSHADE _(FUNCTION \BLTSHADE.C150)
-                               IMNEWPAGE _(FUNCTION NEWPAGE.C150)
-                               IMSCALE _[FUNCTION (LAMBDA NIL
-                                                    (FQUOTIENT 120 72]
-                               IMSPACEFACTOR _(FUNCTION NILL)
-                               IMFONTCREATE _(QUOTE C150)
-                               IMCOLOR _(FUNCTION \DSPCOLOR.C150)
-                               IMBACKCOLOR _(FUNCTION \DSPBACKCOLOR.C150)
-                               IMOPERATION _(FUNCTION \DSPOPERATION.C150)
-                               IMSTRINGWIDTH _(FUNCTION \STRINGWIDTH.C150)
-                               IMCHARWIDTH _(FUNCTION \CHARWIDTH.C150)
-                               IMCLIPPINGREGION _(FUNCTION \DSPCLIPPINGREGION.C150)
-                               IMRESET _(FUNCTION \DSPRESET.C150)
-                               IMFILLPOLYGON _(FUNCTION POLYSHADE.BLT)))
-    [push IMAGESTREAMTYPES (LIST (QUOTE C150)
-                                 (LIST (QUOTE OPENSTREAM)
-                                       (FUNCTION OPENC150STREAM))
-                                 (LIST (QUOTE FONTCREATE)
-                                       (FUNCTION \CREATEC150FONT))
-                                 (LIST (QUOTE FONTSAVAILABLE)
-                                       (FUNCTION \SEARCHC150FONTFILES))
-                                 (LIST (QUOTE CREATECHARSET)
-                                       (FUNCTION \CREATECHARSET.C150]
-    (push PRINTERTYPES (LIST (LIST (QUOTE C150))
-                             (LIST (QUOTE CANPRINT)
-                                   (LIST (QUOTE C150)))
-                             (LIST (QUOTE STATUS)
-                                   (FUNCTION TRUE))
-                             (LIST (QUOTE PROPERTIES)
-                                   (FUNCTION NILL))
-                             (LIST (QUOTE SEND)
-                                   (FUNCTION SEND.TO.C150))
-                             (LIST (QUOTE BITMAPSCALE)
-                                   NIL)
-                             (LIST (QUOTE BITMAPFILE)
-                                   NIL)))
-    (ADDTOVAR DEFAULTPRINTINGHOST (C150 C150))
-    (PUTPROP (QUOTE C150)
-           (QUOTE PRINTERTYPE)
-           (QUOTE C150))
-    [push PRINTFILETYPES (LIST (QUOTE C150)
-                               (LIST (QUOTE TEST)
-                                     (FUNCTION NILL))
-                               (LIST (QUOTE EXTENSION)
-                                     (LIST (QUOTE C150]
-    (DEFAULTFONT (QUOTE C150)
-           (QUOTE (CLASSIC 10 MRR))
-           (QUOTE NEW))
-    T])
-
-(\CREATECHARSET.C150
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?)      (* gbn 
-                                                                           " 9-Jan-86 13:00")
-            
-            (* * tries to build the csinfo required for CHARSET.
-            Does the necessary coercions. Returns NIL when unsuccessful
-            (\CREATECHARSET will do the same))
-            
-            (* * NOSLUG? means don't create an empty
-            (slug) csinfo if the charset is not found, just return NIL)
-
-    (DECLARE (GLOBALVARS C150FONTCOERCIONS MISSINGC150FONTCOERCIONS))
-            
-            (* C150FONTCOERCIONS is a list of font coercions, in the form
-            ((user-font real-font) (user-font real-font) ...)%.
-            Each user-font is a list of FAMILY, and optionally SIZE and CHARSET,
-            (e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a 
-            similar list.)
-
-    (COND
-       ((PROG1 (for TRANSL in C150FONTCOERCIONS bind NEWCSINFO USERFONT REALFONT
-                  when (AND (SETQ USERFONT (CAR TRANSL))
-                            (EQ FAMILY (CAR USERFONT))
-                            (OR (NOT (CADR USERFONT))
-                                (EQ SIZE (CADR USERFONT)))
-                            (OR (NOT (CADDR USERFONT))
-                                (EQ CHARSET (CADDR USERFONT)))
-                            (SETQ REALFONT (CADR TRANSL))
-                            (SETQ NEWCSINFO (\CREATECHARSET.C150 (OR (CAR REALFONT)
-                                                                     FAMILY)
-                                                   (OR (CADR REALFONT)
-                                                       SIZE)
-                                                   FACE ROTATION DEVICE (OR (CADDR REALFONT)
-                                                                            CHARSET)
-                                                   FONTDESC NOSLUG?))) do (RETURN NEWCSINFO))
-                                                                           (* Just recursively 
-                                                                           call ourselves to 
-                                                                           handle entries in 
-                                                                           C150FONTCOERCIONS)
-               ))
-       ((AND (EQ ROTATION 0)                                               (* If it is available, 
-                                                                           this will force the 
-                                                                           appropriate file to be 
-                                                                           read to fill in the 
-                                                                           charset entry)
-             (\READC150FONTFILE FAMILY SIZE FACE ROTATION (QUOTE C150)
-                    CHARSET)))
-       (T   
-            (* * if we get here, the font is not directly available, either it needs 
-            to be rotated, boldified, or italicised "by hand")
-
-          (PROG (NEWFONT XFONT XLATEDFAM)
-                (RETURN (COND
-                           [(NEQ ROTATION 0)
-            
-            (* to make a rotated font (even if it is bold or whatnot), recursively 
-            call fontcreate to get the unrotated font
-            (maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.)
-
-                            (OR (MEMB ROTATION (QUOTE (90 270)))
-                                (ERROR "only implemented rotations are 0, 90 and 270." ROTATION))
-                            (COND
-                               ((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0 (QUOTE C150)
-                                                   T CHARSET))
-            
-            (* actually call FONTCREATE here, rather than \CREATEC150FONT or 
-            \CREATECHARSET.C150 so that the vanilla font that is built in this process 
-            will be cached and not repeated.)
-
-                                (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
-                                    then (\SFROTATECSINFO CSINFO ROTATION)
-                                  else NIL]
-                           ((AND (EQ (fetch WEIGHT of FACE)
-                                     (QUOTE BOLD))
-                                 (SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE
-                                                                        using FACE WEIGHT _(QUOTE
-                                                                                            MEDIUM))
-                                                    0
-                                                    (QUOTE C150)
-                                                    T CHARSET)))           (* if we want a bold 
-                                                                           font, and the medium 
-                                                                           weight font is 
-                                                                           available, build the 
-                                                                           medium weight version 
-                                                                           then call \SFMAKEBOLD 
-                                                                           on the csinfo)
-                            (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
-                                then (\SFMAKEBOLD CSINFO)
-                              else NIL))
-                           ((AND (EQ (fetch SLOPE of FACE)
-                                     (QUOTE ITALIC))
-                                 (SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE
-                                                                        using FACE SLOPE _(QUOTE
-                                                                                           REGULAR))
-                                                    0
-                                                    (QUOTE C150)
-                                                    T CHARSET)))
-                            (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T))
-                                then (\SFMAKEITALIC CSINFO)
-                              else NIL))
-                           ((for TRANSL in MISSINGC150FONTCOERCIONS bind NEWCSINFO USERFONT REALFONT
-                               when (AND (SETQ USERFONT (CAR TRANSL))
-                                         (EQ FAMILY (CAR USERFONT))
-                                         (OR (NOT (CADR USERFONT))
-                                             (EQ SIZE (CADR USERFONT)))
-                                         (OR (NOT (CADDR USERFONT))
-                                             (EQ CHARSET (CADDR USERFONT)))
-                                         (SETQ REALFONT (CADR TRANSL))
-                                         (SETQ NEWCSINFO (\CREATECHARSET.C150 (OR (CAR REALFONT)
-                                                                                  FAMILY)
-                                                                (OR (CADR REALFONT)
-                                                                    SIZE)
-                                                                FACE ROTATION DEVICE
-                                                                (OR (CADDR REALFONT)
-                                                                    CHARSET)
-                                                                FONTDESC NOSLUG?)))
-                               do (RETURN NEWCSINFO)))
-                           ((NOT NOSLUG?)
-                            (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTDESC)
-                                   (FONTPROP FONTDESC (QUOTE ASCENT))
-                                   (FONTPROP FONTDESC (QUOTE DESCENT))
-                                   (FONTPROP FONTDESC (QUOTE DEVICE])
-)
-(DEFINEQ
-
-(CREATEC150BUFFER
-  [LAMBDA (WIDTH HEIGHT)                                                   (* FS " 3-Apr-86 18:14")
-    (LET*((BITWIDTH (ITIMES WIDTH \C150RealBPP))
-          (RASTERWIDTH (FOLDHI BITWIDTH BITSPERWORD))
-          (PAGES (FOLDHI (ITIMES RASTERWIDTH HEIGHT)
-                        WORDSPERPAGE)))
-            
-            (* * (create BITMAP BITMAPBITSPERPIXEL _ \C150RealBPP BITMAPRASTERWIDTH _ 
-            RASTERWIDTH BITMAPWIDTH _ BITWIDTH BITMAPHEIGHT _ HEIGHT BITMAPBASE _
-            (OR (\ALLOCPAGEBLOCK PAGES) (HELP 
-            "Can't allocate C150 buffer - pages needed = " PAGES))))
-            
-            (* * Don't think code above is correct, commented out and added below, 
-            changing BITMAPWIDTH, and ignoring \MaxBitMapWords
-            (safe?????) * *)
-
-     (create BITMAP
-            BITMAPBITSPERPIXEL _ \C150RealBPP
-            BITMAPRASTERWIDTH _ RASTERWIDTH
-            BITMAPWIDTH _ WIDTH
-            BITMAPHEIGHT _ HEIGHT
-            BITMAPBASE _(OR (\ALLOCPAGEBLOCK PAGES)
-                            (HELP "Can't allocate C150 buffer - pages needed = " PAGES])
-
-(NEWLINE.C150
-  [LAMBDA (C150STREAM)                                                     (* hdj 
-                                                                           " 6-Jun-85 14:01")
-                                                                           (* Go to next line
-                                                                           (or next page if on 
-                                                                           last line))
-    (LET*[(C150DATA (fetch IMAGEDATA of C150STREAM))
-          (NEWYPOS (IPLUS (ffetch DDYPOSITION of C150DATA)
-                          (ffetch DDLINEFEED of C150DATA]
-     (COND
-        ((ILESSP NEWYPOS (ffetch DDClippingBottom of C150DATA))
-         (NEWPAGE.C150 C150STREAM))
-        (T (\DSPXPOSITION.C150 C150STREAM (ffetch DDLeftMargin of C150DATA))
-           (\DSPYPOSITION.C150 C150STREAM NEWYPOS])
-
-(NEWPAGE.C150
-  [LAMBDA (C150STREAM)                                                     (* hdj 
-                                                                           " 7-Aug-85 16:48")
-    (LET ((DD (fetch (STREAM IMAGEDATA) of C150STREAM)))
-         [\DUMPPAGEBUFFER.C150 (fetch DDDestination of DD)
-                C150STREAM
-                (OR \C150COLORTABLE (SETQ \C150COLORTABLE (COLORMAP.TO.C150TABLE C150COLORMAP]
-         (STARTPAGE.C150 C150STREAM])
-
-(OPENC150STREAM
-  [LAMBDA (C150FILE OPTIONS)                                               (* gbn 
-                                                                           " 6-Nov-85 19:08")
-                                                                           (* Opens a C150 stream)
-            
-            (* open a C150 stream. keep a permanent pointer to the frame buffer, 
-            because it can never be gc'ed any way, and we want to recycle it --
-            only allow one of them to be open at a time, due to global frame buffer)
-
-    (DECLARE (GLOBALVARS \C150IMAGEOPS C150BAUDRATE \C150STREAM))
-    (if (AND (STREAMP \C150STREAM)
-             (OPENP \C150STREAM))
-        then (ERROR "Sorry - you can only have one C150 stream open at one time" \C150STREAM)
-      else (if (EQ (FILENAMEFIELD C150FILE (QUOTE HOST))
-                   (QUOTE LPT))
-               then                                                        (* if the hardcopy 
-                                                                           interface is opening to 
-                                                                           the LPT pseudodevice, 
-                                                                           change it to be the 
-                                                                           device that the printer 
-                                                                           is actually connected 
-                                                                           to.)
-                    (SETQ C150FILE (PACKFILENAME (QUOTE HOST)
-                                          \C150DEFAULTDEVICE
-                                          (QUOTE BODY)
-                                          C150FILE)))
-           (LET*[(WIDTH (FIX (TIMES 8.5 \C150PointsPerInch)))
-                 (HEIGHT (FIX (TIMES 11 \C150PointsPerInch)))
-                 (BACKINGSTREAM (OPENSTREAM C150FILE (QUOTE OUTPUT)))
-                 (C150STREAM (SETQ \C150STREAM (DSPCREATE (OR \C150.FRAMEBUFFER (SETQ 
-                                                                                 \C150.FRAMEBUFFER
-                                                                                 (CREATEC150BUFFER
-                                                                                  WIDTH HEIGHT]
-            (replace (STREAM F1) of C150STREAM with BACKINGSTREAM)
-            (replace (STREAM OUTCHARFN) of C150STREAM with (FUNCTION \OUTCHARFN.C150))
-            (replace (STREAM STRMBOUTFN) of C150STREAM with (FUNCTION \DSPPRINTCHAR.C150))
-            (replace (STREAM USERCLOSEABLE) of C150STREAM with T)
-            (replace (STREAM IMAGEOPS) of C150STREAM with \C150IMAGEOPS)
-            (replace (\DISPLAYDATA DDClippingRegion) of (\GETDISPLAYDATA C150STREAM)
-               with (CREATEREGION 0 0 WIDTH HEIGHT))
-            (STREAMPROP C150STREAM (QUOTE COLORMAPCACHE)
-                   (LIST NIL))
-            (DSPLEFTMARGIN 0 C150STREAM)
-            (DSPRIGHTMARGIN WIDTH C150STREAM)
-            (DSPCOLOR 0 C150STREAM)
-            (DSPBACKCOLOR 7 C150STREAM)
-            (STARTPAGE.C150 C150STREAM)
-            C150STREAM])
-
-(C150.RESET
-  [LAMBDA NIL                                                              (* gbn 
-                                                                           " 7-Nov-85 22:42")
-            
-            (* * just does things that the user prob doesn't know about.)
-
-    (SETQ \C150STREAM)
-    (CLOSEF? (QUOTE {CENTRONICS}))
-    (CENTRONICS.RESET])
-
-(SEND.TO.C150
-  [LAMBDA (HOST FILE PRINTOPTIONS)                                         (* hdj 
-                                                                           " 6-Jun-85 15:37")
-    (COPYFILE FILE (PACKFILENAME (QUOTE HOST)
-                          (QUOTE LPT)
-                          (QUOTE NAME)
-                          HOST
-                          (QUOTE EXTENSION)
-                          (QUOTE C150])
-
-(STARTPAGE.C150
-  [LAMBDA (C150STREAM)                                                     (* hdj 
-                                                                           " 6-Aug-85 11:20")
-    (LET*((DD (\GETDISPLAYDATA C150STREAM))
-          (CREG (fetch DDClippingRegion of DD))
-          (FONTASCENT (FONTASCENT (fetch DDFONT of DD)))
-          (PAGEBUFFER (fetch DDDestination of DD)))
-     (BLTSHADE (DSPBACKCOLOR NIL C150STREAM)
-            PAGEBUFFER)
-     (\DSPXPOSITION.C150 C150STREAM (fetch DDLeftMargin of DD))
-     (\DSPYPOSITION.C150 C150STREAM (ADD1 (IDIFFERENCE (fetch TOP of CREG)
-                                                 FONTASCENT])
-
-(\BITBLT.C150
-  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH 
-                 HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
-                 CLIPPEDSOURCEBOTTOM)                                      (* hdj 
-                                                                           " 6-Jun-85 16:17")
-    (DECLARE (LOCALVARS . T))
-    (PROG (stodx stody left top bottom right DESTBITMAP DESTINATIONNBITS (SOURCENBITS
-                                                                          (fetch (BITMAP 
-                                                                                   BITMAPBITSPERPIXEL
-                                                                                        )
-                                                                             of SOURCEBITMAP))
-                 (DESTDD (fetch IMAGEDATA of DESTSTRM)))
-          (SETQ DESTBITMAP (fetch DDDestination of DESTDD))
-          [PROGN                                                           (* compute limits based 
-                                                                           on clipping regions.)
-                 (SETQ left (fetch DDClippingLeft of DESTDD))
-                 (SETQ bottom (fetch DDClippingBottom of DESTDD))
-                 (SETQ right (fetch DDClippingRight of DESTDD))
-                 (SETQ top (fetch DDClippingTop of DESTDD))
-                 (COND
-                    (CLIPPINGREGION                                        (* hard case, two 
-                                                                           destination clipping 
-                                                                           regions: do 
-                                                                           calculations to merge 
-                                                                           them.)
-                           (PROG (CRLEFT CRBOTTOM)
-                                 [SETQ left (IMAX left (SETQ CRLEFT (fetch LEFT of CLIPPINGREGION]
-                                 [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (fetch BOTTOM of 
-                                                                                       CLIPPINGREGION
-                                                                                 ]
-                                 [SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH of CLIPPINGREGION
-                                                                              ]
-                                 (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT of CLIPPINGREGION]
-          (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP))
-                                                                           (* left, right top and 
-                                                                           bottom are the limits 
-                                                                           in destination taking 
-                                                                           into account Clipping 
-                                                                           Regions. Clip to region 
-                                                                           in the arguments of 
-                                                                           this call.)
-          [PROGN (SETQ left (IMAX DESTINATIONLEFT left))
-                 (SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
-                 [COND
-                    (WIDTH                                                 (* WIDTH is optional)
-                           (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
-                                             right]
-                 (COND
-                    (HEIGHT                                                (* HEIGHT is optional)
-                           (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
-                                           top]                            (* Clip and translate 
-                                                                           coordinates.)
-          (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT))
-          (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM))
-            
-            (* compute the source dimensions (left right bottom top) by intersecting 
-            the source bit map, the source area to be moved with the limits of the 
-            region to be moved in the destination coordinates.)
-
-          [PROGN                                                           (* compute left margin)
-                 (SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx)
-                                  0))                                      (* compute bottom 
-                                                                           margin)
-                 (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom stody)
-                                    0))                                    (* compute right margin)
-                 (SETQ right (IMIN (\PIXELOFBITADDRESS SOURCENBITS (ffetch BITMAPWIDTH of 
-                                                                                         SOURCEBITMAP
-                                                                          ))
-                                   (IDIFFERENCE right stodx)
-                                   (IPLUS CLIPPEDSOURCELEFT WIDTH)))       (* compute top margin)
-                 (SETQ top (IMIN (ffetch BITMAPHEIGHT of SOURCEBITMAP)
-                                 (IDIFFERENCE top stody)
-                                 (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT]
-          (COND
-             ((AND (IGREATERP right left)
-                   (IGREATERP top bottom)))
-             (T                                                            (* there is nothing to 
-                                                                           move.)
-                (RETURN)))
-          (OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD)))
-            
-            (* We'd rather handle the slow case when we are interruptable, so we do it 
-            here as a heuristic. But we might get interrupted before we go 
-            interruptable, so we do it there too.)
-
-          (COND
-             [(EQ SOURCENBITS DESTINATIONNBITS)                            (* going from one to 
-                                                                           another of the same 
-                                                                           size.)
-                                                                           (* use LLSH with 
-                                                                           constant value rather 
-                                                                           than multiple because 
-                                                                           it compiles into 
-                                                                           opcodes.)
-              [COND
-                 ((EQ DESTINATIONNBITS 4)
-                  (SETQ left (LLSH left 2))
-                  (SETQ right (LLSH right 2))
-                  (SETQ stodx (LLSH stodx 2)))
-                 (T (SETQ left (LLSH left 3))
-                    (SETQ right (LLSH right 3))
-                    (SETQ stodx (LLSH stodx 3]                             (* set texture if it 
-                                                                           will ever get looked 
-                                                                           at.)
-              (AND (EQ SOURCETYPE (QUOTE MERGE))
-                   (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))
-                                                                           (* easy case of color 
-                                                                           to color)
-              (PROG ([PILOTBBT (COND
-                                  ((type? PILOTBBT \SYSPILOTBBT)
-                                   \SYSPILOTBBT)
-                                  (T (SETQ \SYSPILOTBBT (create PILOTBBT]
-                     (HEIGHT (IDIFFERENCE top bottom))
-                     (WIDTH (IDIFFERENCE right left))
-                     (DTY (\SFInvert DESTBITMAP (IPLUS top stody)))
-                     (DLX (IPLUS left stodx))
-                     (STY (\SFInvert SOURCEBITMAP top))
-                     (SLX left))
-                    (replace PBTWIDTH of PILOTBBT with WIDTH)
-                    (replace PBTHEIGHT of PILOTBBT with HEIGHT)
-                    (COND
-                       ((EQ SOURCETYPE (QUOTE MERGE))
-                        (\BITBLT.MERGE PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT 
-                               OPERATION TEXTURE))
-                       (T (\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT 
-                                 SOURCETYPE OPERATION TEXTURE]
-             [(EQ SOURCENBITS 1)                                           (* going from a black 
-                                                                           and white bitmap to a 
-                                                                           color map)
-              (AND SOURCETYPE (NEQ SOURCETYPE (QUOTE INPUT))
-                   (ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE))
-              (PROG ((HEIGHT (IDIFFERENCE top bottom))
-                     (WIDTH (IDIFFERENCE right left))
-                     (DBOT (IPLUS bottom stody))
-                     (DLFT (IPLUS left stodx)))
-                    (SELECTQ OPERATION
-                        ((NIL REPLACE) 
-                             (\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH 
-                                    HEIGHT (COLORNUMBERP (fetch (\DISPLAYDATA DDBACKGROUNDCOLOR)
-                                                            of DESTDD))
-                                    (COLORNUMBERP (fetch (\DISPLAYDATA DDFOREGROUNDCOLOR)
-                                                     of DESTDD))
-                                    DESTINATIONNBITS))
-                        (PAINT)
-                        (INVERT)
-                        (ERASE)
-                        (SHOULDNT]
-             (T                                                            (* going from color map 
-                                                                           into black and white 
-                                                                           map.)
-                (ERROR "not implemented to blt between bitmaps of different pixel size.")))
-          (RETURN T])
-
-(\BLTCHAR.C150
-  [LAMBDA (CHARCODE C150STREAM C150DATA)                                   (* hdj 
-                                                                           "19-Jul-85 13:32")
-            
-            (* * puts a character on a C150STREAM.
-            Since a C150STREAM is based on a color bitmap stream, we can use 
-            \SLOWBLTCHAR)
-
-    [COND
-       ((NEQ (ffetch DDCHARSET of C150DATA)
-             (\CHARSET CHARCODE))                                          (* The charset has 
-                                                                           changed.)
-        (\CHANGECHARSET.C150 C150DATA (\CHARSET CHARCODE]
-    (LET [(CHAR8CODE (\CHAR8CODE CHARCODE))
-          (ROTATION (ffetch (FONTDESCRIPTOR ROTATION) of (ffetch DDFONT of C150DATA]
-         (COND
-            [(EQ 0 ROTATION)
-             (PROG (NEWX LEFT RIGHT (CURX (ffetch DDXPOSITION of C150DATA)))
-                   [COND
-                      ((IGREATERP (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE C150DATA)))
-                              (ffetch DDRightMargin of C150DATA))          (* past RIGHT margin, 
-                                                                           force eol)
-                       (\DSPPRINTCR/LF.C150 (CHARCODE EOL)
-                              C150STREAM)
-                       (SETQ CURX (ffetch DDXPOSITION of C150DATA))
-                       (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE C150DATA]
-                                                                           (* update the x 
-                                                                           position.)
-                   (freplace DDXPOSITION of C150DATA with NEWX)
-                   (SETQ LEFT (IMAX (ffetch DDClippingLeft of C150DATA)
-                                    CURX))
-                   (SETQ RIGHT (IMIN (ffetch DDClippingRight of C150DATA)
-                                     NEWX))
-                   (COND
-                      ((AND (ILESSP LEFT RIGHT)
-                            (NEQ (ffetch PBTHEIGHT of (SETQ NEWX (ffetch DDPILOTBBT of C150DATA)))
-                                 0))
-                       (SELECTQ (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch (\DISPLAYDATA 
-                                                                                      DDDestination)
-                                                                          of C150DATA))
-                           (1 (freplace PBTDESTBIT of NEWX with LEFT)
-                              (freplace PBTWIDTH of NEWX with (IDIFFERENCE RIGHT LEFT))
-                              (freplace PBTSOURCEBIT of NEWX with (IDIFFERENCE (IPLUS (
-                                                                                    \DSPGETCHAROFFSET
-                                                                                       CHAR8CODE 
-                                                                                       C150DATA)
-                                                                                      LEFT)
-                                                                         CURX))
-                              (\PILOTBITBLT NEWX 0))
-                           (4 (freplace PBTDESTBIT of NEWX with (SETQ LEFT (LLSH LEFT 2)))
-                              (freplace PBTWIDTH of NEWX with (IDIFFERENCE (LLSH RIGHT 2)
-                                                                     LEFT))
-                              (freplace PBTSOURCEBIT of NEWX
-                                 with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET CHAR8CODE C150DATA
-                                                                       )
-                                                                2)
-                                                          LEFT)
-                                             (LLSH CURX 2)))
-                              (\PILOTBITBLT NEWX 0))
-                           (8 (freplace PBTDESTBIT of NEWX with (SETQ LEFT (LLSH LEFT 3)))
-                              (freplace PBTWIDTH of NEWX with (IDIFFERENCE (LLSH RIGHT 3)
-                                                                     LEFT))
-                              (freplace PBTSOURCEBIT of NEWX
-                                 with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET CHAR8CODE C150DATA
-                                                                       )
-                                                                3)
-                                                          LEFT)
-                                             (LLSH CURX 3)))
-                              (\PILOTBITBLT NEWX 0))
-                           (SHOULDNT))
-                       T]
-            (T                                                             (* handle rotated fonts)
-               (LET [(YPOS (ffetch DDYPOSITION of C150DATA))
-                     (HEIGHTMOVED (\DSPGETCHARWIDTH CHAR8CODE C150DATA))
-                     (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
-                                    (ffetch DDFONT of C150DATA]
-                    (COND
-                       ((EQ ROTATION 90)                                   (* don't force CR for 
-                                                                           rotated fonts.)
-                        (\DSPYPOSITION.C150 C150STREAM (IPLUS YPOS HEIGHTMOVED))
-                                                                           (* update the display 
-                                                                           stream x position.)
-                        (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
-                               0
-                               (\DSPGETCHAROFFSET CHAR8CODE C150DATA)
-                               C150STREAM
-                               (ADD1 (IDIFFERENCE (ffetch DDXPOSITION of C150DATA)
-                                            (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO)))
-                               YPOS
-                               (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO)
-                                      (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
-                               HEIGHTMOVED))
-                       ((EQ ROTATION 270)
-                        (\DSPYPOSITION.C150 C150STREAM (IDIFFERENCE YPOS HEIGHTMOVED))
-                        (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
-                               0
-                               (\DSPGETCHAROFFSET CHAR8CODE C150DATA)
-                               C150STREAM
-                               (IDIFFERENCE (ffetch DDXPOSITION of C150DATA)
-                                      (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
-                               (ffetch DDYPOSITION of C150STREAM)
-                               (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"])
-
-(\BLTSHADE.C150
-  [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)
-                                                                           (* gbn 
-                                                                           " 5-Nov-85 18:42")
-                                                                           (* BLTSHADE to C150 
-                                                                           color printer)
-    (DECLARE (LOCALVARS . T))
-    (PROG (left top bottom right DESTINATIONNBITS DESTINATIONBITMAP (DESTDD (fetch IMAGEDATA
-                                                                               of STREAM)))
-          (SETQ DESTINATIONLEFT DESTINATIONLEFT)
-          (SETQ DESTINATIONBOTTOM DESTINATIONBOTTOM)
-          [PROGN                                                           (* compute limits based 
-                                                                           on clipping regions.)
-                 (SETQ left (fetch DDClippingLeft of DESTDD))
-                 (SETQ bottom (fetch DDClippingBottom of DESTDD))
-                 (SETQ right (fetch DDClippingRight of DESTDD))
-                 (SETQ top (fetch DDClippingTop of DESTDD))
-                 (COND
-                    (CLIPPINGREGION                                        (* hard case, two 
-                                                                           destination clipping 
-                                                                           regions: do 
-                                                                           calculations to merge 
-                                                                           them.)
-                           (PROG (CRLEFT CRBOTTOM)
-                                 [SETQ left (IMAX left (SETQ CRLEFT (fetch LEFT of CLIPPINGREGION]
-                                 [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (fetch BOTTOM of 
-                                                                                       CLIPPINGREGION
-                                                                                 ]
-                                 [SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH of CLIPPINGREGION
-                                                                              ]
-                                 (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT of CLIPPINGREGION]
-          [SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of (SETQ DESTINATIONBITMAP
-                                                                        (fetch DDDestination
-                                                                           of DESTDD]
-                                                                           (* SETQ right
-                                                                           (\PIXELOFBITADDRESS 
-                                                                           DESTINATIONNBITS right))
-                                                                           (* left, right top and 
-                                                                           bottom are the limits 
-                                                                           in destination taking 
-                                                                           into account Clipping 
-                                                                           Regions. Clip to region 
-                                                                           in the arguments of 
-                                                                           this call.)
-          [PROGN (SETQ left (IMAX DESTINATIONLEFT left))
-                 (SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
-                 [COND
-                    (WIDTH                                                 (* WIDTH is optional)
-                           (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
-                                             right]
-                 (COND
-                    (HEIGHT                                                (* HEIGHT is optional)
-                           (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
-                                           top]
-          (COND
-             ((OR (ILEQ right left)
-                  (ILEQ top bottom))                                       (* there is nothing to 
-                                                                           move.)
-              (RETURN)))
-          [SETQ TEXTURE (COND
-                           ((NULL TEXTURE)
-                            (DSPBACKCOLOR NIL STREAM))
-                           [(FIXP TEXTURE)                                 (* if fixp use the low 
-                                                                           order bits as a color 
-                                                                           number. This picks up 
-                                                                           the case of BLACKSHADE 
-                                                                           being used to INVERT.)
-                            (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T)
-                                (LOGAND TEXTURE (COND
-                                                   ((EQ DESTINATIONNBITS 4)
-                                                    15)
-                                                   (T 255]
-                           (T (\C150.ASSURE.COLOR TEXTURE STREAM]          (* filling an area with 
-                                                                           a texture.)
-          (SETQ left (ITIMES DESTINATIONNBITS left))
-          (SETQ right (ITIMES DESTINATIONNBITS right))
-          (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)) (* easy case of black 
-                                                                           and white bitmap into 
-                                                                           black and white or 
-                                                                           color to color or 
-                                                                           texture filling.)
-            
-            (* We'd rather handle the slow case when we are interruptable, so we do it 
-            here as a heuristic. But we might get interrupted before we go 
-            interruptable, so we do it there too.)
-
-          (PROG ([PILOTBBT (COND
-                              ((type? PILOTBBT \SYSPILOTBBT)
-                               \SYSPILOTBBT)
-                              (T (SETQ \SYSPILOTBBT (create PILOTBBT]
-                 (HEIGHT (IDIFFERENCE top bottom)))
-                (replace PBTWIDTH of PILOTBBT with (IDIFFERENCE right left))
-                (replace PBTHEIGHT of PILOTBBT with HEIGHT)
-                (\BITBLTSUB PILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert DESTINATIONBITMAP 
-                                                                                top)
-                       HEIGHT
-                       (QUOTE TEXTURE)
-                       (OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))
-                       TEXTURE))
-          (RETURN T])
-
-(\C150.CRLF
-  [LAMBDA (STREAM)                                                         (* hdj 
-                                                                           "25-Jan-85 17:11")
-                                                                           (* Send a CRLF to the 
-                                                                           printer)
-    (BOUT STREAM (CHARCODE CR))
-    (BOUT STREAM (CHARCODE LF])
-
-(\CHANGECHARSET.C150
-  [LAMBDA (DISPLAYDATA CHARSET)                                            (* hdj 
-                                                                           "19-Jul-85 13:48")
-                                                                           (* Called when the 
-                                                                           character set 
-                                                                           information cached in a 
-                                                                           display stream doesn't 
-                                                                           correspond to CHARSET)
-    (PROG [BM (PBT (ffetch DDPILOTBBT of DISPLAYDATA))
-              (CSINFO (COND
-                         ((IEQP 1 (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (\DISPLAYDATA 
-                                                                                      DDDestination)
-                                                                           of DISPLAYDATA)))
-                          (\GETCHARSETINFO CHARSET (ffetch DDFONT of DISPLAYDATA)))
-                         (T (\GETCOLORCSINFO (fetch (\DISPLAYDATA DDFONT) of DISPLAYDATA)
-                                   (fetch DDFOREGROUNDCOLOR of DISPLAYDATA)
-                                   (fetch DDBACKGROUNDCOLOR of DISPLAYDATA)
-                                   (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (\DISPLAYDATA 
-                                                                                       DDDestination)
-                                                                            of DISPLAYDATA))
-                                   CHARSET]
-          (UNINTERRUPTABLY
-              (freplace DDWIDTHSCACHE of DISPLAYDATA with (ffetch (CHARSETINFO WIDTHS) of CSINFO))
-              (freplace DDOFFSETSCACHE of DISPLAYDATA with (ffetch (CHARSETINFO OFFSETS) of CSINFO))
-              (freplace DDCHARIMAGEWIDTHS of DISPLAYDATA with (ffetch (CHARSETINFO IMAGEWIDTHS)
-                                                                 of CSINFO))
-              (freplace DDCHARSET of DISPLAYDATA with CHARSET)
-              (SETQ BM (ffetch CHARSETBITMAP of CSINFO))
-              (freplace PBTSOURCEBPL of PBT with (UNFOLD (ffetch BITMAPRASTERWIDTH of BM)
-                                                        BITSPERWORD))
-              [if (OR (NEQ (ffetch DDCHARSETASCENT of DISPLAYDATA)
-                           (ffetch CHARSETASCENT of CSINFO))
-                      (NEQ (ffetch DDCHARSETDESCENT of DISPLAYDATA)
-                           (ffetch CHARSETDESCENT of CSINFO)))
-                  then (\SFFixY DISPLAYDATA CSINFO)
-                else (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE of BM)
-                                                            (ITIMES (ffetch BITMAPRASTERWIDTH
-                                                                       of BM)
-                                                                   (ffetch DDCHARHEIGHTDELTA
-                                                                      of DISPLAYDATA])])
-
-(\CHARWIDTH.C150
-  [LAMBDA (C150STREAM CHARCODE)                                            (* hdj 
-                                                                           " 5-Jun-85 12:56")
-                                                                           (* gets the width of a 
-                                                                           character code in a 
-                                                                           display stream.
-                                                                           Need to fix up for 
-                                                                           spacefactor.)
-    (\FGETWIDTH (ffetch (\DISPLAYDATA DDWIDTHSCACHE) of (ffetch IMAGEDATA of C150STREAM))
-           CHARCODE])
-
-(\CLOSEFN.C150
-  [LAMBDA (C150STREAM)                                                     (* hdj 
-                                                                           " 4-Oct-85 12:31")
-            
-            (* * do cleanup prefatory to closing. dump last buffer and close the 
-            backing stream)
-
-    (LET ((DD (fetch (STREAM IMAGEDATA) of C150STREAM)))
-         [\DUMPPAGEBUFFER.C150 (fetch DDDestination of DD)
-                C150STREAM
-                (OR \C150COLORTABLE (SETQ \C150COLORTABLE (COLORMAP.TO.C150TABLE C150COLORMAP]
-         (CLOSEF (\C150BackingStream C150STREAM])
-
-(\CREATEC150FONT
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)                       (* gbn 
-                                                                           " 8-Jan-86 17:09")
-            
-            (* * create a font for the C150, synthesizing it if we must)
-
-    (PROG [(FONTDESC (create FONTDESCRIPTOR
-                            FONTDEVICE _(QUOTE C150)
-                            FONTFAMILY _ FAMILY
-                            FONTSIZE _ SIZE
-                            FONTFACE _ FACE
-                            \SFAscent _ 0
-                            \SFDescent _ 0
-                            \SFHeight _ 0
-                            ROTATION _ ROTATION
-                            FONTDEVICESPEC _(LIST FAMILY SIZE FACE ROTATION (QUOTE C150]
-          (if (\GETCHARSETINFO CHARSET FONTDESC T)
-              then (RETURN FONTDESC)
-            else (RETURN NIL])
-
-(\READC150FONTFILE
-  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)                       (* hdj 
-                                                                           "26-Sep-85 21:49")
-    (DECLARE (GLOBALVARS C150FONTEXTENSIONS C150FONTDIRECTORIES))
-    (bind FONTFILE CSINFO STRM for EXT inside C150FONTEXTENSIONS
-       when (SETQ FONTFILE (FINDFILE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET)
-                                  T C150FONTDIRECTORIES))
-       do (SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT)))
-          (RESETLST (SETQ CSINFO (\READACFONTFILE STRM FAMILY SIZE FACE))) 
-            
-            (* 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.)
-
-          (RETURN CSINFO])
-
-(\DRAWCIRCLE.C150
-  [LAMBDA (C150STREAM CENTERX CENTERY RADIUS BRUSH DASHING)                (* gbn 
-                                                                           " 9-Jan-86 13:36")
-                                                                           (* \DRAWCIRCLE.C150 
-                                                                           extended for color.
-                                                                           Color is specified by 
-                                                                           either BRUSH or the 
-                                                                           DSPCOLOR of DS.)
-            
-            (* * how is a litatom passed in as brush?)
-
-    (DECLARE (LOCALVARS . T))
-    (COND
-       ((OR (NOT (NUMBERP RADIUS))
-            (ILESSP (SETQ RADIUS (FIXR RADIUS))
-                   0))
-        (\ILLEGAL.ARG RADIUS))
-       ((EQ RADIUS 0)                                                      (* don't draw anything.)
-        NIL)
-       (T (GLOBALRESOURCE \BRUSHBBT
-                 (PROG ((BRUSH (create BRUSH using BRUSH BRUSHCOLOR _(\C150.ASSURE.COLOR (fetch
-                                                                                          BRUSHCOLOR
-                                                                                            of BRUSH)
-                                                                            C150STREAM)))
-                        (X 0)
-                        (Y RADIUS)
-                        (D (ITIMES 2 (IDIFFERENCE 1 RADIUS)))
-                        DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT 
-                        LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE 
-                        BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION HEIGHTMINUS1 
-                        CX CY (BBT \BRUSHBBT)
-                        COLOR COLORBRUSHBASE NBITS (DISPLAYDATA (fetch IMAGEDATA of C150STREAM))
-                        (USERFN (AND (LITATOM BRUSH)
-                                     BRUSH)))                              (* many of these 
-                                                                           variables are used by 
-                                                                           the macro for \CURVEPT 
-                                                                           that passes them to 
-                                                                           \BBTCURVEPT and 
-                                                                           .SETUP.FOR.\BBTCURVEPT.
-                                                                           sets them up.)
-                       (COND
-                          (USERFN                                          (* if calling user fn, 
-                                                                           don't bother with set 
-                                                                           up and leave points in 
-                                                                           stream coordinates.)
-                                 (SETQ CX CENTERX)
-                                 (SETQ CY CENTERY))
-                          (T (.SETUP.FOR.\BBTCURVEPT.)
-                             (SELECTQ NBITS
-                                 (1 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH 2))))
-                                 (4 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 2)
-                                                                         2))))
-                                 (8 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 3)
-                                                                         2))))
-                                 (SHOULDNT))                               (* take into account 
-                                                                           the brush thickness.)
-                             (SETQ CY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2)))
-                                                                           (* Move the window to 
-                                                                           top while 
-                                                                           interruptable, but 
-                                                                           verify that it is still 
-                                                                           there uninterruptably 
-                                                                           with drawing points)
-                             ))
-                       [COND
-                          ((EQ RADIUS 1)                                   (* put a single brush 
-                                                                           down.)
-                                                                           (* draw the top and 
-                                                                           bottom most points.)
-                           (COND
-                              (USERFN (APPLY* USERFN CX CY C150STREAM))
-                              (T (\CURVEPT CX CY)))
-                           (RETURN))
-                          (T                                               (* draw the top and 
-                                                                           bottom most points.)
-                             (COND
-                                (USERFN (APPLY* USERFN CX (IPLUS CY RADIUS)
-                                               C150STREAM)
-                                       (APPLY* USERFN CX (IDIFFERENCE CY RADIUS)
-                                              C150STREAM))
-                                (T (\CURVEPT CX (IPLUS CY RADIUS))
-                                   (\CURVEPT CX (IDIFFERENCE CY RADIUS]
-                   LP                                                      (* (UNFOLD x 2) is used 
-                                                                           instead of (ITIMES x 2))
-                       [COND
-                          [(IGREATERP 0 D)
-                           (SETQ X (ADD1 X))
-                           (COND
-                              ((IGREATERP (UNFOLD (IPLUS D Y)
-                                                 2)
-                                      1)
-                               (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
-                                                       2)
-                                              4))
-                               (SETQ Y (SUB1 Y)))
-                              (T (SETQ D (IPLUS D (UNFOLD X 2)
-                                                1]
-                          ((OR (EQ 0 D)
-                               (IGREATERP X D))
-                           (SETQ X (ADD1 X))
-                           (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
-                                                   2)
-                                          4))
-                           (SETQ Y (SUB1 Y)))
-                          (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2))
-                                            3))
-                             (SETQ Y (SUB1 Y]
-                       (COND
-                          [(EQ Y 0)                                        (* left most and right 
-                                                                           most points are drawn 
-                                                                           specially so that they 
-                                                                           are not duplicated 
-                                                                           which leaves a hole in 
-                                                                           XOR mode.)
-                           (COND
-                              (USERFN (APPLY* USERFN (IPLUS CX X)
-                                             CY C150STREAM)
-                                     (APPLY* USERFN (IDIFFERENCE CX X)
-                                            CY C150STREAM))
-                              (T (\CURVEPT (IPLUS CX X)
-                                        CY)
-                                 (\CURVEPT (IDIFFERENCE CX X)
-                                        CY]
-                          (T (COND
-                                (USERFN (APPLY* USERFN (IPLUS CX X)
-                                               (IPLUS CY Y)
-                                               C150STREAM)
-                                       (APPLY* USERFN (IDIFFERENCE CX X)
-                                              (IPLUS CY Y)
-                                              C150STREAM)
-                                       (APPLY* USERFN (IPLUS CX X)
-                                              (IDIFFERENCE CY Y)
-                                              C150STREAM)
-                                       (APPLY* USERFN (IDIFFERENCE CX X)
-                                              (IDIFFERENCE CY Y)
-                                              C150STREAM))
-                                (T (\CIRCLEPTS CX CY X Y)))
-                             (GO LP)))
-                       (MOVETO CENTERX CENTERY C150STREAM)
-                       (RETURN NIL])
-
-(\DRAWCURVE.C150
-  [LAMBDA (C150STREAM KNOTS CLOSED BRUSH DASHING)                          (* gbn 
-                                                                           "12-Jan-86 15:03")
-                                                                           (* draws a spline curve 
-                                                                           with a given brush.)
-    (GLOBALRESOURCE \BRUSHBBT (PROG ([DASHLST (AND DASHING
-                                                   (OR (AND (LISTP DASHING)
-                                                            (EVERY DASHING (FUNCTION FIXP))
-                                                            DASHING)
-                                                       (\ILLEGAL.ARG DASHING]
-                                     (BBT \BRUSHBBT)
-                                     (CBRUSH (CREATE BRUSH USING BRUSH BRUSHCOLOR _(
-                                                                                   \C150.ASSURE.COLOR
-                                                                                    (FETCH BRUSHCOLOR
-                                                                                       OF BRUSH)
-                                                                                    C150STREAM)))
-                                     LKNOT)
-                                    (SELECTQ (LENGTH KNOTS)
-                                        (0                                 (* No knots => empty 
-                                                                           curve rather than 
-                                                                           error?)
-                                           NIL)
-                                        (1                                 (* only one knot, put 
-                                                                           down a brush shape)
-                                           (OR (type? POSITION (CAR KNOTS))
-                                               (ERROR "bad knot" (CAR KNOTS)))
-                                           (DRAWPOINT (fetch XCOORD of (CAR KNOTS))
-                                                  (fetch YCOORD of (CAR KNOTS))
-                                                  BRUSH C150STREAM))
-                                        (2 (OR (type? POSITION (CAR KNOTS))
-                                               (ERROR "bad knot" (CAR KNOTS)))
-                                           (OR (type? POSITION (CADR KNOTS))
-                                               (ERROR "bad knot" (CADR KNOTS)))
-                                           (\LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS))
-                                                  (fetch YCOORD of (CAR KNOTS))
-                                                  (fetch XCOORD of (CADR KNOTS))
-                                                  (fetch YCOORD of (CADR KNOTS))
-                                                  BRUSH DASHLST C150STREAM BBT))
-                                        (\CURVE2 (PARAMETRICSPLINE KNOTS CLOSED)
-                                               CBRUSH DASHLST BBT C150STREAM))
-                                    (RETURN C150STREAM])
-
-(\DRAWELLIPSE.C150
-  [LAMBDA (DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING)
-                                                                           (* hdj 
-                                                                           " 6-Jun-85 16:17")
-    (DECLARE (LOCALVARS . T))
-            
-            (* Draws an ellipse. At ORIENTATION 0, the semimajor axis is horizontal, 
-            the semiminor axis vertical. Orientation is positive in the 
-            counterclockwise direction. The current location in the stream is left at 
-            the center of the ellipse.)
-
-    (PROG ((CENTERX (FIXR CENTERX))
-           (CENTERY (FIXR CENTERY))
-           (SEMIMINORRADIUS (FIXR SEMIMINORRADIUS))
-           (SEMIMAJORRADIUS (FIXR SEMIMAJORRADIUS)))
-          (COND
-             ((OR (EQ 0 SEMIMINORRADIUS)
-                  (EQ 0 SEMIMAJORRADIUS))
-              (MOVETO CENTERX CENTERY DISPLAYSTREAM)
-              (RETURN)))
-          (COND
-             ((ILESSP SEMIMINORRADIUS 1)
-              (\ILLEGAL.ARG SEMIMINORRADIUS))
-             ((ILESSP SEMIMAJORRADIUS 1)
-              (\ILLEGAL.ARG SEMIMAJORRADIUS))
-             ((OR (NULL ORIENTATION)
-                  (EQ SEMIMINORRADIUS SEMIMAJORRADIUS))
-              (SETQ ORIENTATION 0))
-             ((NULL (NUMBERP ORIENTATION))
-              (\ILLEGAL.ARG ORIENTATION)))
-            
-            (* This function is the implementation of the algorithm given in 
-            "Algorithm for drawing ellipses or hyperbolae with a digital plotter" by 
-            Pitteway appearing in Computer Journal 10:
-            (3) Nov 1967.0 The input parameters are used to determine the ellipse 
-            equation (1/8) Ayy+ (1/8) Bxx+ (1/4) Gxy+
-            (1/4) Ux+ (1/4) Vy= (1/4) K which specifies a translated version of the 
-            desired ellipse. This ellipse passes through the mesh point
-            (0,0), the initial point of the algorithm.
-            The power of 2 factors reflect an implementation convenience.)
-
-          (GLOBALRESOURCE \BRUSHBBT
-                 (PROG (DestinationBitMap LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH TOPMINUSBRUSH 
-                              LEFTMINUSBRUSH DESTINATIONBASE BRUSHBASE BRUSHHEIGHT BRUSHWIDTH 
-                              RASTERWIDTH BRUSHRASTERWIDTH BRUSHBM OPERATION HEIGHTMINUS1
-                              (BBT \BRUSHBBT)
-                              (cosOrientation (COS ORIENTATION))
-                              (sinOrientation (SIN ORIENTATION))
-                              (SEMIMINORRADIUSSQUARED (ITIMES SEMIMINORRADIUS SEMIMINORRADIUS))
-                              (SEMIMAJORRADIUSSQUARED (ITIMES SEMIMAJORRADIUS SEMIMAJORRADIUS))
-                              (x 0)
-                              (y 0)
-                              (x2 1)
-                              x1 y1 y2 k1 k2 k3 a b d w A B G U V K CX CY yOffset CYPlusOffset 
-                              CYMinusOffset NBITSRIGHTPLUS1 COLORBRUSHBASE COLOR NBITS
-                              (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
-                              (USERFN (AND (LITATOM BRUSH)
-                                           BRUSH)))                        (* many of these 
-                                                                           variables are used by 
-                                                                           the macro for \CURVEPT 
-                                                                           that passes them to 
-                                                                           \BBTCURVEPT and 
-                                                                           .SETUP.FOR.\BBTCURVEPT.
-                                                                           sets them up.)
-                       (COND
-                          (USERFN                                          (* if calling user fn, 
-                                                                           don't bother with set 
-                                                                           up and leave points in 
-                                                                           window coordinates.)
-                                 (SETQ CX CENTERX)
-                                 (SETQ CY CENTERY))
-                          (T (.SETUP.FOR.\BBTCURVEPT.)                     (* take into account 
-                                                                           the brush thickness.)
-                             (SELECTQ NBITS
-                                 (1 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH 2))))
-                                 (4 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 2)
-                                                                         2))))
-                                 (8 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 3)
-                                                                         2))))
-                                 (SHOULDNT))
-                             (SETQ CY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2)))
-                                                                           (* Move the window to 
-                                                                           top while 
-                                                                           interruptable, but 
-                                                                           verify that it is still 
-                                                                           there uninterruptably 
-                                                                           with drawing points)
-                             ))
-                       (SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED cosOrientation cosOrientation)
-                                      (FTIMES SEMIMINORRADIUSSQUARED sinOrientation sinOrientation)))
-                       (SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED cosOrientation 
-                                                        cosOrientation)
-                                                 (FTIMES SEMIMAJORRADIUSSQUARED sinOrientation 
-                                                        sinOrientation)))
-                                    3))
-                       (SETQ G (FTIMES cosOrientation sinOrientation (LSH (IDIFFERENCE 
-                                                                               SEMIMINORRADIUSSQUARED 
-                                                                               SEMIMAJORRADIUSSQUARED
-                                                                                 )
-                                                                          1)))
-                       [SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS SEMIMAJORRADIUS)
-                                                  (SQRT A]
-                       (SETQ CYPlusOffset (IPLUS CY yOffset))
-                       (SETQ CYMinusOffset (IDIFFERENCE CY yOffset))
-                       (SETQ U (LSH (FIXR (FTIMES A (LSH yOffset 1)))
-                                    2))
-                       (SETQ V (LSH (FIXR (FTIMES G yOffset))
-                                    2))
-                       (SETQ K (LSH [FIXR (FDIFFERENCE (ITIMES SEMIMINORRADIUSSQUARED 
-                                                              SEMIMAJORRADIUSSQUARED)
-                                                 (FTIMES A (ITIMES yOffset yOffset]
-                                    2))
-                       (SETQ A (LSH (FIXR A)
-                                    3))
-                       (SETQ G (LSH (FIXR G)
-                                    2))
-            
-            (* The algorithm is incremental and iterates through the octants of a 
-            cartesian plane. The octants are labeled from 1 through 8 beginning above 
-            the positive X axis and proceeding counterclockwise.
-            Decisions in making the incremental steps are determined according to the 
-            error term d which is updated according to the curvature terms a and b.
-            k1, k2, and k3 are used to correct the error and curvature terms at octant 
-            boundaries. The initial values of these terms depends on the octant in 
-            which drawing begins. The initial move steps
-            (x1,y1) and (x2,y2) also depend on the starting octant.)
-
-                       [COND
-                          [(ILESSP (ABS U)
-                                  (ABS V))
-                           (SETQ x1 0)
-                           (COND
-                              [(MINUSP V)                                  (* start in octant 2)
-                               (SETQ y1 1)
-                               (SETQ y2 1)
-                               (SETQ k1 (IMINUS A))
-                               (SETQ k2 (IDIFFERENCE k1 G))
-                               (SETQ k3 (IDIFFERENCE k2 (IPLUS B G)))
-                               (SETQ b (IPLUS U (RSH (IPLUS A G)
-                                                     1)))
-                               (SETQ a (IMINUS (IPLUS b V)))
-                               (SETQ d (IPLUS b (RSH B 3)
-                                              (RSH V 1)
-                                              (IMINUS K]
-                              (T                                           (* start in octant 7)
-                                 (SETQ y1 -1)
-                                 (SETQ y2 -1)
-                                 (SETQ k1 A)
-                                 (SETQ k2 (IDIFFERENCE k1 G))
-                                 (SETQ k3 (IPLUS k2 B (IMINUS G)))
-                                 (SETQ b (IPLUS U (RSH (IDIFFERENCE G A)
-                                                       1)))
-                                 (SETQ a (IDIFFERENCE V b))
-                                 (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH V 1)
-                                                                   (RSH B 3]
-                          (T (SETQ x1 1)
-                             (SETQ y1 0)
-                             (COND
-                                [(MINUSP V)                                (* start in octant 1)
-                                 (SETQ y2 1)
-                                 (SETQ k1 B)
-                                 (SETQ k2 (IPLUS k1 G))
-                                 (SETQ k3 (IPLUS k2 A G))
-                                 [SETQ b (IMINUS (IPLUS V (RSH (IPLUS B G)
-                                                               1]
-                                 (SETQ a (IDIFFERENCE U b))
-                                 (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH A 3)
-                                                                   (RSH U 1]
-                                (T                                         (* start in octant 8)
-                                   (SETQ y2 -1)
-                                   (SETQ k1 (IMINUS B))
-                                   (SETQ k2 (IPLUS k1 G))
-                                   (SETQ k3 (IPLUS k2 G (IMINUS A)))
-                                   (SETQ b (IPLUS V (RSH (IDIFFERENCE B G)
-                                                         1)))
-                                   (SETQ a (IDIFFERENCE U b))
-                                   (SETQ d (IPLUS b (RSH A 3)
-                                                  (IMINUS (IPLUS K (RSH U 1]
-            
-            (* The ellipse equation describes an ellipse of the desired size and 
-            ORIENTATION centered at (0,0) and then dropped yOffset mesh points so that 
-            it will pass through (0,0)%. Thus, the intended starting point is
-            (CX, CY+yOffset) where (CX, CY) is the center of the desired ellipse.
-            Drawing is accomplished with point relative steps.
-            In each octant, the error term d is used to choose between move 1
-            (an axis move) and move 2 (a diagonal move)%.)
-
-                   MOVE
-                       [COND
-                          ((MINUSP d)                                      (* move 1)
-                           (SETQ x (IPLUS x x1))
-                           (SETQ y (IPLUS y y1))
-                           (SETQ b (IDIFFERENCE b k1))
-                           (SETQ a (IPLUS a k2))
-                           (SETQ d (IPLUS b d)))
-                          (T                                               (* move 2)
-                             (SETQ x (IPLUS x x2))
-                             (SETQ y (IPLUS y y2))
-                             (SETQ b (IDIFFERENCE b k2))
-                             (SETQ a (IPLUS a k3))
-                             (SETQ d (IDIFFERENCE d a]
-                       (COND
-                          ((MINUSP x)
-                           (MOVETO CENTERX CENTERY DISPLAYSTREAM)
-                           (RETURN NIL)))
-                       [COND
-                          (USERFN (APPLY* USERFN (IPLUS CX x)
-                                         (IPLUS CYPlusOffset y)
-                                         DISPLAYSTREAM)
-                                 (APPLY* USERFN (IDIFFERENCE CX x)
-                                        (IDIFFERENCE CYMinusOffset y)
-                                        DISPLAYSTREAM))
-                          (T (\CURVEPT (IPLUS CX x)
-                                    (IPLUS CYPlusOffset y))
-                             (\CURVEPT (IDIFFERENCE CX x)
-                                    (IDIFFERENCE CYMinusOffset y]
-                       (AND (MINUSP b)
-                            (GO SQUARE))
-                   DIAGONAL
-                       (OR (MINUSP a)
-                           (GO MOVE))                                      (* diagonal octant 
-                                                                           change)
-                       (SETQ x1 (IDIFFERENCE x2 x1))
-                       (SETQ y1 (IDIFFERENCE y2 y1))
-                       (SETQ w (IDIFFERENCE (LSH k2 1)
-                                      k3))
-                       (SETQ k1 (IDIFFERENCE w k1))
-                       (SETQ k2 (IDIFFERENCE k2 k3))
-                       (SETQ k3 (IMINUS k3))
-                       [SETQ b (IPLUS b a (IMINUS (RSH (ADD1 k2)
-                                                       1]
-                       [SETQ d (IPLUS b (RSH (IPLUS k3 4)
-                                             3)
-                                      (IMINUS d)
-                                      (IMINUS (RSH (ADD1 a)
-                                                   1]
-                       (SETQ a (IDIFFERENCE (RSH (ADD1 w)
-                                                 1)
-                                      a))
-                       (OR (MINUSP b)
-                           (GO MOVE))
-                   SQUARE
-                                                                           (* square octant change)
-                       [COND
-                          ((EQ 0 x1)
-                           (SETQ x2 (IMINUS x2)))
-                          (T (SETQ y2 (IMINUS y2]
-                       (SETQ w (IDIFFERENCE k2 k1))
-                       (SETQ k1 (IMINUS k1))
-                       (SETQ k2 (IPLUS w k1))
-                       (SETQ k3 (IDIFFERENCE (LSH w 2)
-                                       k3))
-                       (SETQ b (IDIFFERENCE (IMINUS b)
-                                      w))
-                       (SETQ d (IDIFFERENCE (IDIFFERENCE b a)
-                                      d))
-                       (SETQ a (IDIFFERENCE (IDIFFERENCE a w)
-                                      (LSH b 1)))
-                       (GO DIAGONAL])
-
-(\DRAWLINE.C150
-  [LAMBDA (C150STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR)                   (* gbn 
-                                                                           " 5-Nov-85 13:39")
-                                                                           (* C150STREAM is 
-                                                                           guaranteed to be a 
-                                                                           C150STREAM Draws a line 
-                                                                           from x1,y1 to x2,y2 
-                                                                           leaving the position at 
-                                                                           x2,y2)
-    (PROG ((DD (fetch IMAGEDATA of C150STREAM)))
-          (\CLIPANDDRAWLINE (OR (FIXP X1)
-                                (FIXR X1))
-                 (OR (FIXP Y1)
-                     (FIXR Y1))
-                 (OR (FIXP X2)
-                     (FIXR X2))
-                 (OR (FIXP Y2)
-                     (FIXR Y2))
-                 [COND
-                    ((NULL WIDTH)
-                     1)
-                    ((OR (FIXP WIDTH)
-                         (FIXR WIDTH]
-                 (SELECTQ OPERATION
-                     (NIL (ffetch DDOPERATION of DD))
-                     ((REPLACE PAINT INVERT ERASE) 
-                          OPERATION)
-                     (\ILLEGAL.ARG OPERATION))
-                 (ffetch DDDestination of DD)
-                 (ffetch DDClippingLeft of DD)
-                 (SUB1 (ffetch DDClippingRight of DD))
-                 (ffetch DDClippingBottom of DD)
-                 (SUB1 (ffetch DDClippingTop of DD))
-                 C150STREAM
-                 (\C150.ASSURE.COLOR COLOR C150STREAM)))                   (* the generic case of 
-                                                                           MOVETO is used so that 
-                                                                           the hardcopy streams 
-                                                                           get handled as well.)
-    (MOVETO X2 Y2 C150STREAM])
-
-(\DSPBACKCOLOR.C150
-  [LAMBDA (STREAM COLOR)                                                  (* rmk: 
-                                                                          "12-Sep-84 09:54")
-                                                                          (* sets and returns a 
-                                                                          display stream's 
-                                                                          background color.)
-    (PROG (COLORCELL (DD (\GETDISPLAYDATA STREAM)))
-          (SETQ COLORCELL (fetch DDCOLOR of DD))
-          (RETURN (COND
-                     (COLOR (OR (\POSSIBLECOLOR COLOR)
-                                (\ILLEGAL.ARG COLOR))
-                            (PROG1 (COND
-                                      (COLORCELL (PROG1 (CDR COLORCELL)
-                                                        (RPLACD COLORCELL COLOR)))
-                                      (T                                  (* no color cell yet, 
-                                                                          make one.)
-                                         (replace DDCOLOR of DD with (CONS WHITECOLOR COLOR))
-                                         BLACKCOLOR))
-                                   (\SFFixFont STREAM DD)))
-                     (T (OR (CDR COLORCELL)
-                            BLACKCOLOR])
-
-(\DSPCLIPPINGREGION.C150
-  [LAMBDA (C150STREAM REGION)                                              (* hdj 
-                                                                           " 5-Jun-85 12:56")
-                                                                           (* sets the clipping 
-                                                                           region of a display 
-                                                                           stream.)
-    (PROG ((DD (\GETDISPLAYDATA C150STREAM)))
-          (RETURN (PROG1 (ffetch DDClippingRegion of DD)
-                         (COND
-                            (REGION (OR (type? REGION REGION)
-                                        (ERROR REGION " is not a REGION."))
-                                   (UNINTERRUPTABLY
-                                       (freplace DDClippingRegion of DD with REGION)
-                                       (\SFFixClippingRegion DD)
-                                       (\SFFixY DD))])
-
-(\DSPCOLOR.C150
-  [LAMBDA (STREAM COLOR)                                                   (* gbn 
-                                                                           "13-Jan-86 12:08")
-                                                                           (* sets and returns a 
-                                                                           display stream's 
-                                                                           foreground color.)
-    (LET (CURRENTCOLOR NEWCOLOR (DD (\GETDISPLAYDATA STREAM)))
-         (SETQ CURRENTCOLOR (fetch DDCOLOR of DD))
-         (COND
-            (COLOR (SETQ NEWCOLOR (\C150.ASSURE.COLOR COLOR STREAM))
-                   (PROG1 (COND
-                             (CURRENTCOLOR (PROG1 (CAR CURRENTCOLOR)
-                                                  (RPLACA CURRENTCOLOR NEWCOLOR)))
-                             (T                                            (* no color cell yet, 
-                                                                           make one.)
-                                (replace DDCOLOR of DD with (CONS NEWCOLOR BLACKCOLOR))
-                                WHITECOLOR))
-                          (\SFFixFont STREAM DD)))
-            (T (OR (CAR CURRENTCOLOR)
-                   WHITECOLOR])
-
-(\C150.ASSURE.COLOR
-  [LAMBDA (COLOR# C150STREAM)                                              (* gbn 
-                                                                           " 7-Jan-86 17:44")
-    (PROG (LEVELS)
-          (AND (COND
-                  ((NULL COLOR)
-                   (RETURN (DSPCOLOR NIL C150STREAM)))
-                  [(FIXP COLOR#)
-                   (RETURN (COND
-                              ((AND (IGEQ COLOR# 0)
-                                    (ILESSP COLOR# 8)
-                                    COLOR#))
-                              (T (\ILLEGAL.ARG COLOR#]
-                  [(LITATOM COLOR#)
-                   (RETURN (COND
-                              ((SETQ LEVELS (\LOOKUPCOLORNAME COLOR#))     (* recursively look up 
-                                                                           color number)
-                               (\C150.ASSURE.COLOR (CDR LEVELS)
-                                      C150STREAM))
-                              (T (ERROR "Unknown color name" COLOR#]
-                  ((EQ (LENGTH COLOR#)
-                       2)                                                  (* temporarily, handle 
-                                                                           the case of being given 
-                                                                           a texture and a color, 
-                                                                           by using the color)
-                   (RETURN (\C150.ASSURE.COLOR (CADR COLOR#)
-                                  C150STREAM)))
-                  ((HLSP COLOR#)                                           (* HLS form convert to 
-                                                                           RGB)
-                   (SETQ LEVELS (HLSTORGB COLOR#)))
-                  ((RGBP COLOR#)                                           (* check for RGB or HLS)
-                   (SETQ LEVELS COLOR#))
-                  ((TYPENAMEP COLOR# (QUOTE BITMAP))                       (* just a hack to not 
-                                                                           blow up)
-                   (RETURN (IMOD (for I from 1 to (BITMAPWIDTH COLOR#)
-                                    sum (BITMAPBIT COLOR# I 1))
-                                 8)))
-                  (T (\ILLEGAL.ARG COLOR#)))
-               (RETURN (COND
-                          ((\C150.LOOKUPRGB LEVELS C150STREAM))
-                          (T (ERROR COLOR# "not available in color map"])
-
-(\C150.LOOKUPRGB
-  [LAMBDA (RGB C150STREAM)                                                 (* gbn 
-                                                                           " 5-Nov-85 15:47")
-            
-            (* * returns the colormap index whose value is RGB.
-            Looks first in the cache, then runs through the colormap.
-            Returns NIL if RGB NOT found)
-
-    (DECLARE (GLOBALVARS C150COLORMAP))
-    (PROG [INDEX (CACHE (STREAMPROP C150STREAM (QUOTE COLORMAPCACHE]
-          (RETURN (if (SETQ INDEX (SASSOC RGB CACHE))
-                      then (CDR INDEX)
-                    else [SETQ INDEX (bind (CM _ C150COLORMAP) for I from 0
-                                        to (SUB1 (EXPT 2 3))
-                                        thereis (AND (EQ (\GENERIC.COLORLEVEL CM I (QUOTE RED))
-                                                         (fetch (RGB RED) of LEVELS))
-                                                     (EQ (\GENERIC.COLORLEVEL CM I (QUOTE GREEN))
-                                                         (fetch (RGB GREEN) of LEVELS))
-                                                     (EQ (\GENERIC.COLORLEVEL CM I (QUOTE BLUE))
-                                                         (fetch (RGB BLUE) of LEVELS]
-                         (if INDEX
-                             then (PUTASSOC RGB INDEX CACHE))
-                         INDEX])
-
-(\DSPFONT.C150
-  [LAMBDA (C150STREAM FONT)                                                (* hdj 
-                                                                           " 4-Oct-85 11:55")
-                                                                           (* sets the font that a 
-                                                                           display stream uses to 
-                                                                           print characters.
-                                                                           C150STREAM is 
-                                                                           guaranteed to be a 
-                                                                           stream of type C150)
-    (PROG (XFONT OLDFONT (DD (fetch IMAGEDATA of C150STREAM)))             (* save old value to 
-                                                                           return, smash new value 
-                                                                           and update the bitchar 
-                                                                           portion of the record.)
-          (RETURN (PROG1 (SETQ OLDFONT (fetch DDFONT of DD))
-                         (COND
-                            (FONT (SETQ XFONT (OR (\GETFONTDESC FONT (QUOTE C150)
-                                                         T)
-                                                  (FONTCOPY (ffetch DDFONT of DD)
-                                                         FONT)))           (* color case, create a 
-                                                                           font with the current 
-                                                                           foreground and 
-                                                                           background colors.)
-            
-            (* (SETQ XFONT (\GETCOLORFONT XFONT (DSPCOLOR NIL C150STREAM)
-            (DSPBACKCOLOR NIL C150STREAM) (ffetch (BITMAP BITMAPBITSPERPIXEL) of
-            (ffetch (\DISPLAYDATA DDDestination) of DD)))))
-                                                                           (* updating font 
-                                                                           information is fairly 
-                                                                           expensive operation.
-                                                                           Don't bother unless 
-                                                                           font has changed.)
-                                  (OR (EQ XFONT OLDFONT)
-                                      (UNINTERRUPTABLY
-                                          (freplace DDFONT of DD with XFONT)
-                                          (freplace DDLINEFEED of DD
-                                             with (IMINUS (fetch \SFHeight of XFONT)))
-                                          (\SFFixFont C150STREAM DD))])
-
-(\DSPLEFTMARGIN.C150
-  [LAMBDA (C150STREAM XPOSITION)                                           (* hdj 
-                                                                           " 5-Jun-85 12:56")
-                                                                           (* sets the xposition 
-                                                                           that a carriage return 
-                                                                           returns to.)
-    (PROG ((DD (fetch IMAGEDATA of C150STREAM)))
-          (RETURN (PROG1 (ffetch DDLeftMargin of DD)
-                         (AND XPOSITION (COND
-                                           ((AND (SMALLP XPOSITION)
-                                                 (IGREATERP XPOSITION -1))
-                                            (UNINTERRUPTABLY
-                                                (freplace DDLeftMargin of DD with XPOSITION)
-                                                (\SFFIXLINELENGTH C150STREAM)))
-                                           (T (\ILLEGAL.ARG XPOSITION])
-
-(\DSPLINEFEED.C150
-  [LAMBDA (C150STREAM DELTAY)                                              (* hdj 
-                                                                           " 5-Jun-85 12:56")
-                                                                           (* sets the amount that 
-                                                                           a line feed increases 
-                                                                           the y coordinate by.)
-    (PROG ((DD (fetch IMAGEDATA of C150STREAM)))
-          (RETURN (PROG1 (ffetch DDLINEFEED of DD)
-                         (AND DELTAY (COND
-                                        ((NUMBERP DELTAY)
-                                         (freplace DDLINEFEED of DD with DELTAY))
-                                        (T (\ILLEGAL.ARG DELTAY])
-
-(\DSPOPERATION.C150
-  [LAMBDA (C150STREAM OPERATION)                                           (* hdj 
-                                                                           " 5-Jun-85 12:56")
-                                                                           (* sets the operation 
-                                                                           field of a display 
-                                                                           stream)
-    (PROG ((DD (\GETDISPLAYDATA C150STREAM)))
-          (RETURN (PROG1 (fetch DDOPERATION of DD)
-                         (COND
-                            (OPERATION (OR (FMEMB OPERATION (QUOTE (PAINT REPLACE INVERT ERASE)))
-                                           (LISPERROR "ILLEGAL ARG" OPERATION))
-                                   (UNINTERRUPTABLY
-                                       (freplace DDOPERATION of DD with OPERATION)
-                                                                           (* update other fields 
-                                                                           that depend on 
-                                                                           operation.)
-                                       (\SETPBTFUNCTION (fetch DDPILOTBBT of DD)
-                                              (fetch DDSOURCETYPE of DD)
-                                              OPERATION))])
-
-(\DSPPRINTCHAR.C150
-  [LAMBDA (STREAM CHARCODE)                                                (* hdj 
-                                                                           " 5-Jun-85 12:56")
-                                                                           (* Displays the 
-                                                                           character and 
-                                                                           increments the 
-                                                                           Xposition. STREAM is 
-                                                                           guaranteed to be of 
-                                                                           type display.)
-    (PROG ((DD (fetch IMAGEDATA of STREAM)))
-          (SELCHARQ CHARCODE
-               ((EOL CR LF) 
-                    (\DSPPRINTCR/LF.C150 CHARCODE STREAM)
-                    (replace CHARPOSITION of STREAM with 0))
-               (LF (\DSPPRINTCR/LF.C150 CHARCODE STREAM))
-               (TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE)
-                                                       STREAM)))
-                          (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
-                          (if (IGREATERP (\DISPLAYSTREAMINCRXPOSITION
-                                          (SETQ TABWIDTH (IDIFFERENCE TABWIDTH
-                                                                (MOD (IDIFFERENCE (fetch DDXPOSITION
-                                                                                     of DD)
-                                                                            (ffetch DDLeftMargin
-                                                                               of DD))
-                                                                     TABWIDTH)))
-                                          DD)
-                                     (ffetch DDRightMargin of DD))
-                              then                                         (* tab was past 
-                                                                           rightmargin, force cr.)
-                                   (\DSPPRINTCR/LF.C150 (CHARCODE EOL)
-                                          STREAM))                         (* return the number of 
-                                                                           spaces taken.)
-                          (add (fetch CHARPOSITION of STREAM)
-                               (IQUOTIENT TABWIDTH SPACEWIDTH))))
-               (add (fetch CHARPOSITION of STREAM)
-                    (IPLUS (if (ILESSP CHARCODE 32)
-                               then                                        (* CONTROL character)
-                                    (\BLTCHAR.C150 CHARCODE STREAM DD)
-                                    0
-                             else (\BLTCHAR.C150 CHARCODE STREAM DD)
-                                  1])
-
-(\DSPPRINTCR/LF.C150
-  [LAMBDA (CHARCODE DS)                                                    (* hdj 
-                                                                           " 6-Jun-85 14:08")
-                                                                           (* CHARCODE is EOL, CR, 
-                                                                           or LF Assumes that DS 
-                                                                           has been checked by 
-                                                                           \DSPPRINTCHAR)
-    (PROG (BTM AMOUNT/BELOW Y ROTATION FONT (DD (fetch IMAGEDATA of DS)))
-          (COND
-             ((AND (fetch DDSlowPrintingCase of DD)
-                   (NEQ (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of (fetch DDFONT of DD)))
-                        0))
-              (PROG ((CLIPREG (ffetch DDClippingRegion of DD))
-                     X)
-                    [COND
-                       ((EQ CHARCODE (CHARCODE EOL))                       (* on LF, no change in 
-                                                                           X)
-                        (COND
-                           ((SETQ Y (fetch DDEOLFN of DD))                 (* call the eol 
-                                                                           function for ds.)
-                            (APPLY* Y DS)))
-                        (\DSPYPOSITION.C150 DS (SELECTQ ROTATION
-                                                   (90 (fetch (REGION BOTTOM) of CLIPREG))
-                                                   (270 (fetch (REGION TOP) of CLIPREG))
-                                                   (ERROR 
-                                                         "Only rotations supported are 0, 90 and 270"
-                                                          ]
-                    [SETQ X (IPLUS (fetch DDXPOSITION of DD)
-                                   (SELECTQ ROTATION
-                                       (90 (IMINUS (ffetch DDLINEFEED of DD)))
-                                       (270 (ffetch DDLINEFEED of DD))
-                                       (ERROR "Only rotations supported are 0, 90 and 270"]
-                    (DSPXPOSITION X DS)))
-             (T (COND
-                   ((EQ CHARCODE (CHARCODE EOL))                           (* on LF, no change in 
-                                                                           X)
-                    (COND
-                       ((SETQ Y (fetch DDEOLFN of DD))                     (* call the eol 
-                                                                           function for ds.)
-                        (APPLY* Y DS)))
-                    (DSPXPOSITION (ffetch DDLeftMargin of DD)
-                           DS)))
-                (SETQ Y (IPLUS (ffetch DDYPOSITION of DD)
-                               (ffetch DDLINEFEED of DD)))
-                (DSPYPOSITION Y DS])
-
-(\DSPRESET.C150
-  [LAMBDA (C150STREAM)                                                     (* hdj 
-                                                                           " 5-Aug-85 18:57")
-    (DECLARE (GLOBALVARS \CURRENTDISPLAYLINE))                             (* resets a display 
-                                                                           stream)
-    (PROG (CREG FONT FONTASCENT (DD (\GETDISPLAYDATA C150STREAM)))
-          (SETQ CREG (ffetch DDClippingRegion of DD))
-          (SETQ FONT (fetch DDFONT of DD))
-          (SETQ FONTASCENT (FONTASCENT FONT))
-          (SELECTQ (fetch (FONTDESCRIPTOR ROTATION) of FONT)
-              (0 (\DSPXPOSITION.C150 C150STREAM (ffetch DDLeftMargin of DD))
-                 (\DSPYPOSITION.C150 C150STREAM (ADD1 (IDIFFERENCE (fetch TOP of CREG)
-                                                             FONTASCENT))))
-              (90 (\DSPXPOSITION.C150 C150STREAM (IPLUS (fetch LEFT of CREG)
-                                                        FONTASCENT))
-                  (\DSPYPOSITION.C150 C150STREAM (fetch BOTTOM of CREG)))
-              (270 (\DSPXPOSITION.C150 C150STREAM (IDIFFERENCE (fetch RIGHT of CREG)
-                                                         FONTASCENT))
-                   (\DSPYPOSITION.C150 C150STREAM (fetch TOP of CREG)))
-              (ERROR "only supported rotations are 0, 90 and 270"))
-          (\CLEARBM (ffetch (\DISPLAYDATA DDDestination) of DD)
-                 (DSPBACKCOLOR NIL C150STREAM)
-                 CREG])
-
-(\DSPRIGHTMARGIN.C150
-  [LAMBDA (C150STREAM XPOSITION)                                           (* hdj 
-                                                                           " 5-Jun-85 12:56")
-                                                                           (* Sets the right 
-                                                                           margin that determines 
-                                                                           when a cr is inserted 
-                                                                           by print.)
-    (PROG (OLDRM (DD (fetch IMAGEDATA of C150STREAM)))
-          (SETQ OLDRM (ffetch DDRightMargin of DD))
-          (COND
-             ((NULL XPOSITION))
-             [(AND (SMALLP XPOSITION)
-                   (IGREATERP XPOSITION -1))                               (* Avoid fixing 
-                                                                           linelength if right 
-                                                                           margin hasn't changed.)
-              (OR (EQ XPOSITION OLDRM)
-                  (UNINTERRUPTABLY
-                      (freplace DDRightMargin of DD with XPOSITION)
-                      (\SFFIXLINELENGTH C150STREAM))]
-             (T (\ILLEGAL.ARG XPOSITION)))
-          (RETURN OLDRM])
-
-(\DSPXPOSITION.C150
-  [LAMBDA (C150STREAM XPOSITION)                                           (* hdj 
-                                                                           " 5-Jun-85 12:56")
-                                                                           (* coordinate position 
-                                                                           is stored in 15 bits in 
-                                                                           the range -2^15 to 
-                                                                           +2^15.)
-    (PROG ((DD (fetch IMAGEDATA of C150STREAM)))
-          (RETURN (PROG1 (fetch DDXPOSITION of DD)
-                         (COND
-                            ((NULL XPOSITION))
-                            ((NUMBERP XPOSITION)
-                             (freplace DDXPOSITION of DD with XPOSITION)   (* reset the 
-                                                                           charposition field so 
-                                                                           that PRINT etc.
-                                                                           won't put out eols.)
-                             (freplace (STREAM CHARPOSITION) of C150STREAM with 0))
-                            (T (\ILLEGAL.ARG XPOSITION])
-
-(\DSPYPOSITION.C150
-  [LAMBDA (DISPLAYSTREAM YPOSITION)                                        (* hdj 
-                                                                           " 3-Oct-85 17:57")
-    (LET ((DD (fetch IMAGEDATA of DISPLAYSTREAM)))
-         (PROG1 (ffetch DDYPOSITION of DD)
-                (COND
-                   ((NULL YPOSITION))
-                   ((NUMBERP YPOSITION)
-                    (UNINTERRUPTABLY
-                        (freplace DDYPOSITION of DD with YPOSITION)
-                        (\INVALIDATEDISPLAYCACHE DD)))
-                   (T (\ILLEGAL.ARG YPOSITION])
-
-(\DUMPPAGEBUFFER.C150
-  [LAMBDA (BITMAP C150STREAM COLOR.TABLES)                                 (* gbn 
-                                                                           "13-Jan-86 21:37")
-    (CENTRONICS.RESET C150STREAM)
-    (LET*[(BACKINGSTREAM (\C150BackingStream C150STREAM))
-          (MAXX (SUB1 (BITMAPWIDTH BITMAP)))
-          (MAXY (SUB1 (BITMAPHEIGHT BITMAP)))
-          (LINEBYTES (FOLDHI (BITMAPWIDTH BITMAP)
-                            BITSPERBYTE))
-          (PrintingTimeInSeconds 1)
-          (PrintingTimer (SETUPTIMER PrintingTimeInSeconds NIL (QUOTE SECONDS]
-     (C150.SETMARGINS BACKINGSTREAM)
-     (C150.SEPARATOR BACKINGSTREAM)
-     (bind (BLANKLINES _ 0)
-           (FIRSTLINE _ T) for SCANLINE from MAXY to 0 by -4
-        do
-        (if (\C150.ALLWHITESPACE BITMAP COLOR.TABLES SCANLINE)
-            then (add BLANKLINES 1)
-                 (BLOCK)
-          else
-            
-            (* * First dump the buffered microlinefeeds)
-
-          (if (AND FIRSTLINE C150.CLIPBUFFER)
-              then                                                         (* don't bother 
-                                                                           printing these 
-                                                                           microlinefeeds, since 
-                                                                           they are just the 
-                                                                           blanks at the top of 
-                                                                           the buffer)
-                   (SETQ FIRSTLINE NIL)
-            else (for I to BLANKLINES do (\C150.MICROLINEFEED BACKINGSTREAM)))
-          (SETQ BLANKLINES 0)
-          [for SUBSCAN from 0 to 3
-             do
-             (if (TIMEREXPIRED? PrintingTimer (QUOTE SECONDS))
-                 then (BLOCK)
-                      (SETUPTIMER PrintingTimeInSeconds PrintingTimer (QUOTE SECONDS)))
-             (for COLOR from 0 to 3
-                do                                                         (* loop over (black 
-                                                                           magenta yellow cyan))
-                   (LET [(COLOR.ARRAY.BASE (fetch (ARRAYP BASE) of (ELT COLOR.TABLES COLOR]
-                        (\C150.SENDLINEINFO BACKINGSTREAM COLOR LINEBYTES SUBSCAN)
-                        (for XPOSITION from 0 to MAXX by 8
-                           do (BOUT BACKINGSTREAM (for BIT from 0 to 7
-                                                     sum (LLSH (\GETBASE COLOR.ARRAY.BASE
-                                                                      (BITMAPBIT BITMAP
-                                                                             (IPLUS XPOSITION BIT)
-                                                                             (IDIFFERENCE SCANLINE 
-                                                                                    SUBSCAN)))
-                                                               (IDIFFERENCE 7 BIT]
-          (\C150.MICROLINEFEED BACKINGSTREAM))
-        finally (if (NOT C150.CLIPBUFFER)
-                    then                                                   (* print out the 
-                                                                           remaining 
-                                                                           microlinefeeds)
-                         (for I from 1 to BLANKLINES do (\C150.MICROLINEFEED BACKINGSTREAM])
-
-(\FILLCIRCLE.C150
-  [LAMBDA (C150STREAM CENTERX CENTERY RADIUS TEXTURE)                      (* hdj 
-                                                                           " 6-Jun-85 16:17")
-    (COND
-       ((OR (NOT (NUMBERP RADIUS))
-            (ILESSP (SETQ RADIUS (FIXR RADIUS))
-                   0))
-        (\ILLEGAL.ARG RADIUS))
-       (T (GLOBALRESOURCE \BRUSHBBT
-                 (PROG (TOP BOTTOM RIGHT LEFT OPERATION DestinationBitMap
-                            (DISPLAYDATA (fetch IMAGEDATA of C150STREAM))
-                            (X 0)
-                            (Y RADIUS)
-                            (D (ITIMES 2 (IDIFFERENCE 1 RADIUS)))
-                            DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH GRAYBASE 
-                            NBITS (FCBBT \BRUSHBBT))
-                       (SETQ TOP (SUB1 (fetch DDClippingTop of DISPLAYDATA)))
-                       (SETQ BOTTOM (fetch DDClippingBottom of DISPLAYDATA))
-                       (SETQ LEFT (fetch DDClippingLeft of DISPLAYDATA))
-                       (SETQ RIGHT (SUB1 (fetch DDClippingRight of DISPLAYDATA)))
-                       (SETQ OPERATION (ffetch DDOPERATION of DISPLAYDATA))
-                       (SETQ DestinationBitMap (fetch DDDestination of DISPLAYDATA))
-                       (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap))
-                       [SETQ TEXTUREBM (COND
-                                          ((BITMAPP TEXTURE))
-                                          [(AND (NEQ NBITS 1)
-                                                (BITMAPP (COLORTEXTUREFROMCOLOR#
-                                                          (COLORNUMBERP (OR TEXTURE (DSPCOLOR NIL 
-                                                                                           C150STREAM
-                                                                                           ]
-                                          [(AND (NULL TEXTURE)
-                                                (BITMAPP (ffetch DDTexture of DISPLAYDATA]
-                                          ([OR (FIXP TEXTURE)
-                                               (AND (NULL TEXTURE)
-                                                    (SETQ TEXTURE (ffetch DDTexture of DISPLAYDATA]
-                                                                           (* create bitmap for 
-                                                                           the texture. Could 
-                                                                           reuse a bitmap but for 
-                                                                           now this is good 
-                                                                           enough.)
-                                           (SETQ TEXTUREBM (BITMAPCREATE 16 4))
-                                           (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM))
-                                           (\PUTBASE GRAYBASE 0 (\SFReplicate (LOGAND (LRSH TEXTURE 
-                                                                                            12)
-                                                                                     15)))
-                                           (\PUTBASE GRAYBASE 1 (\SFReplicate (LOGAND (LRSH TEXTURE 8
-                                                                                            )
-                                                                                     15)))
-                                           (\PUTBASE GRAYBASE 2 (\SFReplicate (LOGAND (LRSH TEXTURE 4
-                                                                                            )
-                                                                                     15)))
-                                           (\PUTBASE GRAYBASE 3 (\SFReplicate (LOGAND TEXTURE 15)))
-                                           TEXTUREBM)
-                                          (T (\ILLEGAL.ARG TEXTURE]
-                       (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM))
-                       (SETQ DESTINATIONBASE (fetch BITMAPBASE of DestinationBitMap))
-                       (SETQ RASTERWIDTH (fetch BITMAPRASTERWIDTH of DestinationBitMap))
-                                                                           (* update as many 
-                                                                           fields in the brush 
-                                                                           bitblt table as 
-                                                                           possible from DS.)
-                       (replace PBTFLAGS of FCBBT with 0)
-                       (replace PBTDESTBPL of FCBBT with (UNFOLD RASTERWIDTH BITSPERWORD))
-                                                                           (* clear gray 
-                                                                           information. 
-                                                                           PBTSOURCEBPL is used 
-                                                                           for gray information 
-                                                                           too.)
-                       (replace PBTSOURCEBPL of FCBBT with 0)
-                       (replace PBTUSEGRAY of FCBBT with T)
-                       [replace PBTGRAYWIDTHLESSONE of FCBBT
-                          with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH) of TEXTUREBM)
-                                                           16]
-                       [replace PBTGRAYHEIGHTLESSONE of FCBBT
-                          with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT) of TEXTUREBM
-                                                                   )
-                                                            16]
-                       (replace PBTDISJOINT of FCBBT with T)
-                       (\SETPBTFUNCTION FCBBT (QUOTE TEXTURE)
-                              OPERATION)
-                       (replace PBTHEIGHT of FCBBT with 1)                 (* take into account 
-                                                                           the brush thickness.)
-                       (SETQ CX CENTERX)
-                       (SETQ CY CENTERY)                                   (* change Y TOP and 
-                                                                           BOTTOM to be in bitmap 
-                                                                           coordinates)
-                       (SETQ CY (\SFInvert DestinationBitMap CY))
-                       [SETQ BOTTOM (PROG1 (SUB1 (\SFInvert DestinationBitMap TOP))
-                                           (SETQ TOP (SUB1 (\SFInvert DestinationBitMap BOTTOM]
-                       (COND
-                          ((EQ RADIUS 0)                                   (* put a single point 
-                                                                           down. Use \LINEBLT to 
-                                                                           get proper texture.
-                                                                           NIL)
-                           (\LINEBLT FCBBT CX CY CX DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP 
-                                  GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)
-                           (RETURN)))
-                   LP                                                      (* (UNFOLD x 2) is used 
-                                                                           instead of (ITIMES x 2))
-                       [COND
-                          [(IGREATERP 0 D)
-                           (SETQ X (ADD1 X))
-                           (COND
-                              ((IGREATERP (UNFOLD (IPLUS D Y)
-                                                 2)
-                                      1)
-                               (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
-                                                       2)
-                                              4)))
-                              (T (SETQ D (IPLUS D (UNFOLD X 2)
-                                                1))                        (* don't draw unless Y 
-                                                                           changes.)
-                                 (GO LP]
-                          ((OR (EQ 0 D)
-                               (IGREATERP X D))
-                           (SETQ X (ADD1 X))
-                           (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
-                                                   2)
-                                          4)))
-                          (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2))
-                                            3]
-                       (COND
-                          ((EQ Y 0)                                        (* draw the middle line 
-                                                                           differently to avoid 
-                                                                           duplication.)
-                           (\LINEBLT FCBBT (IDIFFERENCE CX X)
-                                  CY
-                                  (IPLUS CX X)
-                                  DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH 
-                                  GRAYHEIGHT GRAYBASE NBITS))
-                          (T (\FILLCIRCLEBLT CX CY X Y)
-                             (SETQ Y (SUB1 Y))
-                             (GO LP)))
-                       (MOVETO CENTERX CENTERY C150STREAM)
-                       (RETURN NIL])
-
-(\OUTCHARFN.C150
-  [LAMBDA (C150STREAM CHARCODE)                                            (* hdj 
-                                                                           "10-Jun-85 15:14")
-    (SELCHARQ CHARCODE
-         (EOL                                                              (* New Line)
-              (NEWLINE.C150 C150STREAM)
-              (replace (STREAM CHARPOSITION) of C150STREAM with 0))
-         (LF                                                               (* Line feed--move 
-                                                                           down, but not over)
-             (\DSPXPOSITION.C150 C150STREAM (PROG1 (\DSPXPOSITION.C150 C150STREAM)
-                                                   (NEWLINE.C150 C150STREAM))))
-         (^L                                                               (* Form Feed)
-             (replace (STREAM CHARPOSITION) of C150STREAM with 0)
-             (NEWPAGE.C150 C150STREAM))
-         (\BOUT C150STREAM CHARCODE])
-
-(\SEARCHC150FONTFILES
-  [LAMBDA (FAMILY SIZE FACE ROTATION)                                      (* hdj 
-                                                                           " 5-Jun-85 14:19")
-            
-            (* * returns a list of the fonts that can be read in for the C150 device.
-            Rotation is ignored because it is assumed that all devices support 0 90 
-            and 270)
-
-    (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
-    (SELECTQ (SYSTEMTYPE)
-        (D (for E FILENAMEPATTERN FONTSFOUND THISFONT inside DISPLAYFONTEXTENSIONS
-              do (SETQ FILENAMEPATTERN (\FONTFILENAME FAMILY SIZE FACE E))
-                 [for DIR inside DISPLAYFONTDIRECTORIES
-                    do (for FONTFILE in (DIRECTORY (PACKFILENAME (QUOTE DIRECTORY)
-                                                          DIR
-                                                          (QUOTE BODY)
-                                                          FILENAMEPATTERN))
-                          do (OR (MEMBER (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE (QUOTE 
-                                                                                              DISPLAY
-                                                                                               )))
-                                        FONTSFOUND)
-                                 (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND]
-              finally (RETURN FONTSFOUND)))
-        (SHOULDNT])
-
-(\STRINGWIDTH.C150
-  [LAMBDA (C150STREAM STR RDTBL)                                           (* hdj 
-                                                                           " 5-Jun-85 12:56")
-                                                                           (* Returns the width of 
-                                                                           for the current 
-                                                                           font/spacefactor in 
-                                                                           STREAM.)
-    (PROG (WIDTHSBASE)
-          (RETURN (\STRINGWIDTH.GENERIC STR (SETQ WIDTHSBASE (ffetch (\DISPLAYDATA DDWIDTHSCACHE)
-                                                                of (ffetch IMAGEDATA of C150STREAM)))
-                         RDTBL
-                         (\FGETWIDTH WIDTHSBASE (CHARCODE SPACE])
-)
-
-(RPAQQ MISSINGC150FONTCOERCIONS (((GACHA)
-                                  (MODERN))
-                                 ((TIMESROMAN)
-                                  (MODERN))
-                                 ((HELVETICA)
-                                  (MODERN))))
-
-(RPAQQ \C150COLORTABLE NIL)
-
-(RPAQQ \C150.FRAMEBUFFER NIL)
-
-(RPAQQ \C150STREAM NIL)
-
-(RPAQ C150COLORMAP (READARRAY 16 (QUOTE POINTER) 0))
-((0 0 0)
-(0 0 255)
-(0 255 0)
-(255 0 0)
-(255 255 0)
-(255 0 255)
-(0 255 255)
-(255 255 255)
-(0 0 0)
-(0 0 255)
-(0 255 0)
-(255 0 0)
-(255 255 0)
-(255 0 255)
-(0 255 255)
-(255 255 255)
-NIL
-)
-
-(RPAQQ C150FONTCOERCIONS (((CLASSIC 8)
-                           (CLASSIC 10))
-                          ((MODERN 8)
-                           (MODERN 10))
-                          ((MODERN 24)
-                           (MODERN 18))
-                          ((MODERN 18)
-                           (CLASSIC 18))
-                          ((CLASSIC 24)
-                           (CLASSIC 18))
-                          ((CLASSIC 12)
-                           (CLASSIC 14))))
-
-(RPAQQ C150FONTDIRECTORIES ({ERIS}<LISPCORE>LIBRARY>))
-
-(RPAQQ C150FONTEXTENSIONS (C150FONT))
-
-(RPAQ? C150.CLIPBUFFER T)
-
-(RPAQ? \C150DEFAULTDEVICE (QUOTE CENTRONICS))
-(DEFINEQ
-
-(COLORMAP.TO.C150TABLE
-  [LAMBDA (COLORMAP)                                                       (* hdj 
-                                                                           " 3-Aug-85 21:36")
-    (LET*((SIZE (ARRAYSIZE COLORMAP))
-          (TABLETABLE (ARRAY 4 (QUOTE POINTER)
-                             NIL 0))
-          (BLACKTABLE (ARRAY SIZE (QUOTE SMALLP)
-                             0 0))
-          (CYANTABLE (ARRAY SIZE (QUOTE SMALLP)
-                            0 0))
-          (MAGENTATABLE (ARRAY SIZE (QUOTE SMALLP)
-                               0 0))
-          (YELLOWTABLE (ARRAY SIZE (QUOTE SMALLP)
-                              0 0)))
-     (bind CYAN MAGENTA YELLOW for PIXELVAL from 0 to (SUB1 SIZE)
-        do [SETQ CYAN (SETA CYANTABLE PIXELVAL (IDIFFERENCE 1 (IQUOTIENT (fetch (RGB RED)
-                                                                            of (COLORMAPENTRY 
-                                                                                      COLORMAP 
-                                                                                      PIXELVAL))
-                                                                     128]
-           [SETQ MAGENTA (SETA MAGENTATABLE PIXELVAL (IDIFFERENCE 1 (IQUOTIENT (fetch (RGB GREEN)
-                                                                                  of (COLORMAPENTRY
-                                                                                      COLORMAP 
-                                                                                      PIXELVAL))
-                                                                           128]
-           [SETQ YELLOW (SETA YELLOWTABLE PIXELVAL (IDIFFERENCE 1 (IQUOTIENT (fetch (RGB BLUE)
-                                                                                of (COLORMAPENTRY
-                                                                                    COLORMAP PIXELVAL
-                                                                                    ))
-                                                                         128]
-           (if (AND (EQ CYAN 1)
-                    (EQ MAGENTA 1)
-                    (EQ YELLOW 1))
-               then (SETA CYANTABLE PIXELVAL 0)
-                    (SETA MAGENTATABLE PIXELVAL 0)
-                    (SETA YELLOWTABLE PIXELVAL 0)
-                    (SETA BLACKTABLE PIXELVAL 1)))
-     (SETA TABLETABLE 0 BLACKTABLE)
-     (SETA TABLETABLE 1 MAGENTATABLE)
-     (SETA TABLETABLE 2 YELLOWTABLE)
-     (SETA TABLETABLE 3 CYANTABLE)
-     TABLETABLE])
-)
-(FILESLOAD COLOR XXGEOM XXFILL)
-(IF (NOT (GETD (QUOTE POLYSHADE.BLT)))
-    THEN
-    (* A fix for KOTO, which is not necessary in <lc>n>)
-    (MOVD (QUOTE POLYSHADE.DISPLAY)
-          (QUOTE POLYSHADE.BLT)))
-(DECLARE: DONTEVAL@LOAD DOCOPY 
-(\C150INIT)
-
-(FILESLOAD CENTRONICS)
-)
-(DECLARE: EVAL@LOAD DONTCOPY 
-(FILESLOAD (LOADFROM)
-       ADISPLAY LLDISPLAY)
-)
-(DECLARE: EVAL@COMPILE 
-(DEFMACRO \C150BackingStream (C150STREAM)
-       (BQUOTE (fetch (STREAM F1)
-                      of , C150STREAM)))
-)
-(PUTPROPS C150STREAM COPYRIGHT ("Xerox Corporation" 1985 1986))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (2416 20778 (C150.SEPARATOR 2426 . 2839) (C150.SETMARGINS 2841 . 4574) (
-\C150.ALLWHITESPACE 4576 . 6320) (\C150.BUFFER.DOT 6322 . 6553) (\C150.MICROLINEFEED 6555 . 6835) (
-\C150.SENDLINE 6837 . 7856) (\C150.SENDLINEINFO 7858 . 8357) (\C150INIT 8359 . 12525) (
-\CREATECHARSET.C150 12527 . 20776)) (20779 135286 (CREATEC150BUFFER 20789 . 21931) (NEWLINE.C150 21933
- . 22878) (NEWPAGE.C150 22880 . 23386) (OPENC150STREAM 23388 . 26698) (C150.RESET 26700 . 27074) (
-SEND.TO.C150 27076 . 27516) (STARTPAGE.C150 27518 . 28241) (\BITBLT.C150 28243 . 39228) (\BLTCHAR.C150
- 39230 . 46739) (\BLTSHADE.C150 46741 . 54213) (\C150.CRLF 54215 . 54665) (\CHANGECHARSET.C150 54667
- . 58079) (\CHARWIDTH.C150 58081 . 58888) (\CLOSEFN.C150 58890 . 59533) (\CREATEC150FONT 59535 . 60463
-) (\READC150FONTFILE 60465 . 61352) (\DRAWCIRCLE.C150 61354 . 70823) (\DRAWCURVE.C150 70825 . 74177) (
-\DRAWELLIPSE.C150 74179 . 90084) (\DRAWLINE.C150 90086 . 92331) (\DSPBACKCOLOR.C150 92333 . 93755) (
-\DSPCLIPPINGREGION.C150 93757 . 94804) (\DSPCOLOR.C150 94806 . 96147) (\C150.ASSURE.COLOR 96149 . 
-98725) (\C150.LOOKUPRGB 98727 . 100214) (\DSPFONT.C150 100216 . 103285) (\DSPLEFTMARGIN.C150 103287 . 
-104410) (\DSPLINEFEED.C150 104412 . 105295) (\DSPOPERATION.C150 105297 . 106757) (\DSPPRINTCHAR.C150 
-106759 . 109848) (\DSPPRINTCR/LF.C150 109850 . 112967) (\DSPRESET.C150 112969 . 114625) (
-\DSPRIGHTMARGIN.C150 114627 . 115995) (\DSPXPOSITION.C150 115997 . 117372) (\DSPYPOSITION.C150 117374
- . 118012) (\DUMPPAGEBUFFER.C150 118014 . 121744) (\FILLCIRCLE.C150 121746 . 131735) (\OUTCHARFN.C150 
-131737 . 132803) (\SEARCHC150FONTFILES 132805 . 134363) (\STRINGWIDTH.C150 134365 . 135284)) (136566 
-139219 (COLORMAP.TO.C150TABLE 136576 . 139217)))))
-STOP
diff --git a/obsolete/lispusers/c150fonts/CLASSIC10-C0.C150FONT b/obsolete/lispusers/c150fonts/CLASSIC10-C0.C150FONT
deleted file mode 100644
index 007e5c75..00000000
Binary files a/obsolete/lispusers/c150fonts/CLASSIC10-C0.C150FONT and /dev/null differ
diff --git a/obsolete/lispusers/c150fonts/CLASSIC14-C0.C150FONT b/obsolete/lispusers/c150fonts/CLASSIC14-C0.C150FONT
deleted file mode 100644
index 1cb874ad..00000000
Binary files a/obsolete/lispusers/c150fonts/CLASSIC14-C0.C150FONT and /dev/null differ
diff --git a/obsolete/lispusers/c150fonts/CLASSIC18-C0.C150FONT b/obsolete/lispusers/c150fonts/CLASSIC18-C0.C150FONT
deleted file mode 100644
index efe7862d..00000000
Binary files a/obsolete/lispusers/c150fonts/CLASSIC18-C0.C150FONT and /dev/null differ
diff --git a/obsolete/lispusers/c150fonts/TIMESROMAN10-C0.C150FONT b/obsolete/lispusers/c150fonts/TIMESROMAN10-C0.C150FONT
deleted file mode 100644
index 5ec6b0a0..00000000
Binary files a/obsolete/lispusers/c150fonts/TIMESROMAN10-C0.C150FONT and /dev/null differ
diff --git a/obsolete/lispusers/c150fonts/TIMESROMAN12-C0.C150FONT b/obsolete/lispusers/c150fonts/TIMESROMAN12-C0.C150FONT
deleted file mode 100644
index 06761504..00000000
Binary files a/obsolete/lispusers/c150fonts/TIMESROMAN12-C0.C150FONT and /dev/null differ
diff --git a/obsolete/lispusers/c150fonts/TIMESROMAN14-C0.C150FONT b/obsolete/lispusers/c150fonts/TIMESROMAN14-C0.C150FONT
deleted file mode 100644
index 06917afa..00000000
Binary files a/obsolete/lispusers/c150fonts/TIMESROMAN14-C0.C150FONT and /dev/null differ
diff --git a/obsolete/lispusers/mathserverplot b/obsolete/lispusers/mathserverplot
deleted file mode 100644
index 2e7f18fd..00000000
--- a/obsolete/lispusers/mathserverplot
+++ /dev/null
@@ -1,1567 +0,0 @@
-(FILECREATED "15-Dec-86 11:35:38" {INDIGO}<GSLWS>KOTO>LIBRARY>MATHSERVERPLOT.;4 49010  
-
-      changes to:  (FNS MAPL.Simple.MakePlot MAPL.ExpandFilename MAPL.Meta.MakePlot MAPL.Gen.MakePlot)
-		   (VARS MATHSERVERPLOTCOMS)
-
-      previous date: " 8-Dec-86 09:46:39" {INDIGO}<GSLWS>KOTO>LIBRARY>MATHSERVERPLOT.;3)
-
-
-(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
-
-(PRETTYCOMPRINT MATHSERVERPLOTCOMS)
-
-(RPAQQ MATHSERVERPLOTCOMS ((* * ALL PLOTS)
-			     (* Files for Log functions)
-			     (FILES plotexamples.dcom {INDIGO}<GSLWS>IDLPLOT>FIXES>LOGPATCH.DCOM)
-			     (* Low-level I/0 functions)
-			     (FNS MAPL.TopLevel MAPL.MakeReadtable MAPL.ReadASCIILine 
-				  MAPL.ExpandFilename)
-			     (* * METACODE PLOT STUFF)
-			     (* Menu and window functions)
-			     (FNS MAPL.Meta.TopLevel MAPL.Meta.FreeMenu MAPL.Meta.MakeIconWindow)
-			     (* Plot functions)
-			     (FNS MAPL.Meta.MakePlot MAPL.Meta.Plot MAPL.Meta.ASCIIToLisp)
-			     (* Metaplot functions)
-			     (FNS MAPL.Meta.NewPlotCom MAPL.Meta.MoveCom MAPL.Meta.DrawCom 
-				  MAPL.Meta.EndPlotCom MAPL.Meta.NewPenCom)
-			     (* Icon bitmaps)
-			     (BITMAPS MAPL.Meta.Icon MAPL.Meta.IconMask)
-			     (* * SIMPLE PLOT STUFF)
-			     (* Menu and window functions)
-			     (FNS MAPL.Simple.TopLevel MAPL.Simple.FreeMenu 
-				  MAPL.Simple.MakeIconWindow)
-			     (* Plot functions)
-			     (FNS MAPL.Simple.MakePlot MAPL.Simple.Plot)
-			     (* Icon bitmaps)
-			     (BITMAPS MAPL.Simple.Icon MAPL.Simple.IconMask)
-			     (* * GENERAL PLOT STUFF)
-			     (* Menu and window functions)
-			     (FNS MAPL.Gen.TopLevel MAPL.Gen.FreeMenu MAPL.Gen.MakeIconWindow)
-			     (* Plot functions)
-			     (FNS MAPL.Gen.MakePlot MAPL.Gen.Plot MAPL.Gen.ASCIIToLisp 
-				  MAPL.Gen.NewPlot MAPL.Gen.PlotObject MAPL.Gen.EndPlot 
-				  MAPL.Gen.NewPen MAPL.Gen.CollectData)
-			     (* Icon bitmaps)
-			     (BITMAPS MAPL.Gen.Icon MAPL.Gen.IconMask)
-			     (* vars)
-			     (P (MAPL.MakeReadtable))
-			     (GLOBALVARS MAPL.ASCIIRDTBL)
-			     (ADDVARS (BackgroundMenuCommands (Plot% Menus
-								(QUOTE (MAPL.TopLevel))
-								"Opens all Plot Menus"
-								(SUBITEMS (General% PlotMenu
-									    (QUOTE (MAPL.Gen.TopLevel)
-										   )
-									    
-								       "Open a General Plot Menu")
-									  (Simple% PlotMenu
-									    (QUOTE (
-MAPL.Simple.TopLevel))
-									    "Open a Simple Plot Menu")
-									  (Meta% PlotMenu
-									    (QUOTE (MAPL.Meta.TopLevel
-										     ))
-									    
-								      "Open a MetaCode Plot Menu")))))
-			     (VARS (BackgroundMenu NIL))))
-(* * ALL PLOTS)
-
-
-
-
-(* Files for Log functions)
-
-(FILESLOAD plotexamples.dcom {INDIGO}<GSLWS>IDLPLOT>FIXES>LOGPATCH.DCOM)
-
-
-
-(* Low-level I/0 functions)
-
-(DEFINEQ
-
-(MAPL.TopLevel
-  (LAMBDA NIL                                                (* DSB " 5-Dec-86 11:39")
-                                                             (* opens all plot menus)
-    (MAPL.Gen.TopLevel)
-    (MAPL.Simple.TopLevel)
-    (MAPL.Meta.TopLevel)))
-
-(MAPL.MakeReadtable
-  (LAMBDA NIL                                                (* DSB "24-Nov-86 09:53")
-
-          (* * Makes a readtable that reads ASCII records which end in carriage returns as strings, recognizing only CR as a 
-	  separator character)
-
-
-    (SETQ MAPL.ASCIIRDTBL (COPYREADTABLE FILERDTBL))
-    (SETSEPR (QUOTE (13))
-	       NIL MAPL.ASCIIRDTBL)))
-
-(MAPL.ReadASCIILine
-  (LAMBDA (fileStream)                                       (* DSB "24-Nov-86 13:27")
-
-          (* * reads one record from a free-form ASCII file and returns a list of the data items in that record)
-
-
-    (LET ((stringstream (OPENSTRINGSTREAM (RSTRING fileStream MAPL.ASCIIRDTBL)))
-	  newChar)
-         (READC fileStream)
-         (while (NOT (EOFP stringstream)) collect (READ stringstream)))))
-
-(MAPL.ExpandFilename
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Dec-86 11:21")
-                                                             (* if filename is fullFilename, expand it into the 
-							     separate slots)
-    (PROG ((state (FM.READSTATE WINDOW))
-	     filename host directory name extension version shortName)
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (SETQ host (UNPACKFILENAME filename (QUOTE HOST)))
-	    (COND
-	      (host (SETQ directory (UNPACKFILENAME filename (QUOTE DIRECTORY)))
-		    (SETQ name (UNPACKFILENAME filename (QUOTE NAME)))
-		    (SETQ extension (UNPACKFILENAME filename (QUOTE EXTENSION)))
-		    (SETQ version (UNPACKFILENAME filename (QUOTE VERSION)))
-		    (SETQ shortName (PACKFILENAME (QUOTE NAME)
-						      name
-						      (QUOTE EXTENSION)
-						      extension
-						      (QUOTE VERSION)
-						      version))
-		    (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE FILENAME))
-				      WINDOW shortName)
-		    (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE DIRECTORY))
-				      WINDOW directory)
-		    (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE HOST))
-				      WINDOW host)
-		    (SETQ state (FM.READSTATE WINDOW))))
-	    (RETURN state))))
-)
-(* * METACODE PLOT STUFF)
-
-
-
-
-(* Menu and window functions)
-
-(DEFINEQ
-
-(MAPL.Meta.TopLevel
-  (LAMBDA NIL                                                (* DSB " 5-Dec-86 11:49")
-                                                             (* Sets up the MetaCode Plot Free Menu)
-    (PROG (menuWindow)
-	    (SETQ menuWindow (MAPL.Meta.FreeMenu))       (* initialize to PenFlag ON)
-	    (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE PEN))
-			      menuWindow)                    (* set up menu window)
-	    (WINDOWPROP menuWindow (QUOTE ICONFN)
-			  (FUNCTION MAPL.Meta.MakeIconWindow))
-	    (SHAPEW menuWindow (QUOTE (200 420 271 127)))
-	    (OPENW menuWindow))))
-
-(MAPL.Meta.FreeMenu
-  (LAMBDA (LEFT BOTTOM)                                      (* DSB " 3-Dec-86 12:33")
-                                                             (* returns a free menu window for MetaCode plots at 
-							     specified position)
-    (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL Command: FONT (MODERN 12 BOLD))
-				 (LABEL MakePlot SELECTEDFN MAPL.Meta.MakePlot))
-				((TYPE TITLE LABEL "FILE INFO" FONT (MODERN 12 BOLD)))
-				((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (FILENAME))
-				 (TYPE EDIT ID FILENAME LABEL ""))
-				((TYPE EDITSTART LABEL Directory: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (DIRECTORY))
-				 (TYPE EDIT ID DIRECTORY LABEL ""))
-				((TYPE EDITSTART LABEL Host: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (HOST))
-				 (TYPE EDIT ID HOST LABEL ""))
-				((TYPE TITLE LABEL "PLOT INFO" FONT (MODERN 12 BOLD)))
-				((TYPE TITLE LABEL PenWidth: FONT (MODERN 12 BOLD))
-				 (TYPE NWAY ID PEN LABEL ON)
-				 (TYPE NWAY ID PEN LABEL OFF))
-				(WINDOWPROPS TITLE "MetaCode Plot Menu" LEFT , LEFT BOTTOM , BOTTOM)))
-		     )))
-
-(MAPL.Meta.MakeIconWindow
-  (LAMBDA (WINDOW OLDICON)                                   (* DSB " 5-Dec-86 18:01")
-
-          (* * Creates a shrink window with an icon formed by two bit maps.)
-
-
-    (OR OLDICON (ICONW MAPL.Meta.Icon MAPL.Meta.IconMask))))
-)
-
-
-
-(* Plot functions)
-
-(DEFINEQ
-
-(MAPL.Meta.MakePlot
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Dec-86 11:32")
-                                                             (* checks that required data is specified and that the
-							     fullFilename is valid, and makes the MetaCode plot.)
-    (PROG ((promptW (GETPROMPTWINDOW WINDOW))
-	     state filename directory host penFlag fullFilename)
-
-          (* * check that all required data is specified)
-
-
-	    (CLEARW promptW)
-	    (SETQ state (MAPL.ExpandFilename ITEM WINDOW BUTTONS))
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (COND
-	      ((EQUAL filename "")
-		(PRIN1 "Unspecified file name." promptW)
-		(RETURN)))
-	    (SETQ directory (LISTGET state (QUOTE DIRECTORY)))
-	    (COND
-	      ((EQUAL directory "")
-		(PRIN1 "Unspecified directory." promptW)
-		(RETURN)))
-	    (SETQ host (LISTGET state (QUOTE HOST)))
-	    (COND
-	      ((EQUAL host "")
-		(PRIN1 "Unspecified host (DSK,IVY,etc.)" promptW)
-		(RETURN)))
-	    (SETQ penFlag (EQ (QUOTE ON)
-				  (LISTGET state (QUOTE PEN))))
-
-          (* * make fullFilename)
-
-
-	    (SETQ fullFilename (PACKFILENAME (QUOTE HOST)
-						 host
-						 (QUOTE DIRECTORY)
-						 directory
-						 (QUOTE BODY)
-						 filename))
-
-          (* * if fullFilename is valid, then make plot)
-
-
-	    (COND
-	      ((NOT (INFILEP fullFilename))
-		(PRIN1 "File not found" promptW)
-		(RETURN))
-	      (T (PRIN1 "Making plot ..." promptW)
-		 (MAPL.Meta.Plot fullFilename penFlag)
-		 (CLEARW promptW)
-		 (PRIN1 "Done" promptW)
-		 (RETURN))))))
-
-(MAPL.Meta.Plot
-  (LAMBDA (file penFlag)                                     (* DSB " 3-Dec-86 13:14")
-
-          (* * makes a PLOT of the metacode file)
-
-
-    (PROG (dataList plot code newVal1 newVal2 curveList pen)
-	    (SETQ dataList (MAPL.Meta.ASCIIToLisp file))
-                                                             (* (PRIN1 dataList PROMPTWINDOW))
-	    (COND
-	      ((NOT dataList)
-		(RETURN (PROMPTPRINT "There is no data"))))
-	    (for item in dataList
-	       do (SETQ code (CAR item))
-		    (SETQ newVal1 (CADR item))
-		    (SETQ newVal2 (CADDR item))
-		    (SELECTQ code
-			       (1 (SETQ plot (MAPL.Meta.NewPlotCom))
-                                                             (* New plot)
-				  )
-			       (2 (SETQ curveList (MAPL.Meta.DrawCom curveList newVal1 newVal2)))
-			       (3 (SETQ curveList (MAPL.Meta.MoveCom plot curveList pen newVal1 
-									 newVal2)))
-			       (4 (MAPL.Meta.EndPlotCom plot curveList pen)
-                                                             (* End of plot)
-				  )
-			       (5 (SETQ pen (MAPL.Meta.NewPenCom newVal1 penFlag))
-                                                             (* New pen)
-				  )
-			       NIL)))))
-
-(MAPL.Meta.ASCIIToLisp
-  (LAMBDA (file)                                             (* DSB "25-Nov-86 09:54")
-
-          (* * returns ASCII data from a file in a list, with one sub-list per line. The file must end in a CR.)
-
-
-    (PROG ((tempFile (QUOTE {core}tempplot.dat))
-	     fileStream dataList)
-	    (COND
-	      ((NOT (INFILEP file))
-		(RETURN NIL)))
-	    (COPYFILE file tempFile)                       (* copy to {core} because reads from filestream to 
-							     {core} are much faster than reads from filestream to a
-							     VAX on the network.)
-	    (SETQ fileStream (OPENSTREAM tempFile (QUOTE INPUT)))
-	    (SETQ dataList (while (NOT (EOFP tempFile)) collect (MAPL.ReadASCIILine
-									    fileStream)))
-	    (CLOSEF fileStream)
-	    (DELFILE tempFile)
-	    (RETURN dataList))))
-)
-
-
-
-(* Metaplot functions)
-
-(DEFINEQ
-
-(MAPL.Meta.NewPlotCom
-  (LAMBDA NIL                                                (* DSB " 5-Dec-86 11:51")
-
-          (* * starts a new plot)
-
-
-    (PROG NIL
-	    (SETQ curveList NIL)
-	    (RETURN (CREATEPLOT NIL (QUOTE (471 420 250 250))
-				    "MetaCode Plot")))))
-
-(MAPL.Meta.MoveCom
-  (LAMBDA (plot curveList pen newVal1 newVal2)               (* DSB "25-Nov-86 09:01")
-
-          (* * Plots the previous curve, and moves to a new position, starting a new curve)
-
-
-    (PROG NIL
-	    (COND
-	      ((AND curveList (GREATERP (LENGTH curveList)
-					    1))
-		(PLOTCURVE plot curveList NIL pen NIL T)))
-	    (SETQ curveList (LIST (CONS newVal1 newVal2)))
-	    (RETURN curveList))))
-
-(MAPL.Meta.DrawCom
-  (LAMBDA (curveList newVal1 newVal2)                        (* DSB "24-Nov-86 13:31")
-
-          (* * adds a new set of points to the curveList)
-
-
-    (PROG NIL
-	    (SETQ curveList (CONS (CONS newVal1 newVal2)
-				      curveList))
-	    (RETURN curveList))))
-
-(MAPL.Meta.EndPlotCom
-  (LAMBDA (plot curveList pen)                               (* DSB "25-Nov-86 09:01")
-
-          (* * plots the last curve and opens the plot. It is expected that no more curves will be drawn to the plot)
-
-
-    (PROG NIL
-	    (COND
-	      ((AND curveList (GREATERP (LENGTH curveList)
-					    1))
-		(PLOTCURVE plot curveList NIL pen NIL T)))
-	    (OPENPLOTWINDOW plot))))
-
-(MAPL.Meta.NewPenCom
-  (LAMBDA (newVal1 penFlag)                                  (* DSB " 3-Dec-86 15:25")
-
-          (* * If penFlag is OFF, sets pen to 1)
-
-
-
-          (* * if penFlag is ON, sets the pen to INT ((PEN + 1) /2))
-
-
-    (PROG (pen)
-	    (COND
-	      (penFlag (SETQ pen (IQUOTIENT (PLUS newVal1 1)
-						2)))
-	      (T (SETQ pen 1)))
-	    (RETURN pen))))
-)
-
-
-
-(* Icon bitmaps)
-
-
-(RPAQ MAPL.Meta.Icon (READBITMAP))
-(70 70
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"L@@@@@@@@@ON@@@@@L@@"
-"L@@@@@@@@@GO@@@@@L@@"
-"LGOH@COOOOOOOOOOLL@@"
-"LDLH@B@@@@AOH@@@DL@@"
-"LDLH@B@@@@@OL@@@DL@@"
-"LD@H@B@@@@@GN@@@DL@@"
-"LD@H@BB@@@@CO@@@DL@@"
-"LNAL@BB@@@@AOH@@DL@@"
-"L@@@@BF@@@@@OH@@DL@@"
-"L@@@@BB@@@@@GL@@DL@@"
-"L@A@@BB@@@@@CL@@DL@@"
-"LCO@@BB@@@@@AN@@DL@@"
-"LBA@@BF@@@@@@F@@DL@@"
-"LB@@@BB@@@@@@C@@DL@@"
-"LCH@@BB@@@@@@AH@DL@@"
-"LCH@@BB@@CL@@GH@DL@@"
-"LB@@@BF@@FF@AL@@DL@@"
-"LBAAOBB@@LC@C@@@DL@@"
-"LCOAOBB@AHAHN@@@DL@@"
-"L@A@@BB@C@@OH@@@DL@@"
-"L@@@@BF@F@@@@@@@DL@@"
-"L@@@@BB@L@@@@@@@DL@@"
-"LCO@@BB@H@@@@@@@DL@@"
-"L@L@@BBAH@@@@@@@DL@@"
-"L@L@@BFA@@@@@@@@DL@@"
-"L@L@@BBC@@@@@@@@DL@@"
-"L@L@@BBB@@@@@@@@DL@@"
-"L@L@@BBF@@@@@@@@DL@@"
-"L@@@@BFD@@@@@@@@DL@@"
-"L@@@@BB@@@@@@@@@DL@@"
-"L@L@@BB@@@@@@@@@DL@@"
-"LAN@@BB@@@@@@@@@DL@@"
-"LAB@@BGOOOOOOOONDL@@"
-"LCO@@BBBBBBBBBBBDL@@"
-"LBA@@B@@@@@@@@@@DL@@"
-"LFAH@COOOOOOOOOOLL@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"LOOOOOH@@@@@@@@@@L@@"
-"L@LOLL@@@@@@@@@@@L@@"
-"LAHGHF@@@@@@@@@@@L@@"
-"LC@C@C@@@@@@@@@@@L@@"
-"LC@C@C@@@@@@@@@@@L@@"
-"LC@C@C@@@@@@@@@@@L@@"
-"LC@C@C@@ON@OO@NALL@@"
-"LC@C@C@@NF@NG@FAHL@@"
-"LC@C@C@@LB@LC@FAHL@@"
-"LC@C@C@@H@@LC@FAHL@@"
-"LC@C@C@@LH@LC@FAHL@@"
-"LC@C@C@@OH@LC@FAHL@@"
-"LC@C@C@@LH@LC@FAHL@@"
-"LC@GHC@@H@@LC@FAHL@@"
-"LC@@@C@@LB@LC@FAHL@@"
-"LC@@@C@@NF@LC@GCHL@@"
-"LC@@@C@@ONALCHGOHL@@"
-"LC@@@C@@@@@@@@@@@L@@"
-"LOH@@GL@@@@@@@@@@L@@"
-"LOH@@GL@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@")
-
-(RPAQ MAPL.Meta.IconMask (READBITMAP))
-(70 70
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@")
-(* * SIMPLE PLOT STUFF)
-
-
-
-
-(* Menu and window functions)
-
-(DEFINEQ
-
-(MAPL.Simple.TopLevel
-  (LAMBDA NIL                                                (* DSB " 8-Dec-86 08:00")
-                                                             (* Sets up the Simple Plot Free Menu)
-    (PROG (menuWindow)
-	    (SETQ menuWindow (MAPL.Simple.FreeMenu 200 250))
-
-          (* * initialize plot defaults)
-
-
-	    (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE TYPE))
-			      menuWindow)
-	    (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE REP))
-			      menuWindow)
-	    (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE DEST))
-			      menuWindow)
-
-          (* * finish setup of free menu)
-
-
-	    (WINDOWPROP menuWindow (QUOTE ICONFN)
-			  (FUNCTION MAPL.Simple.MakeIconWindow))
-	    (OPENW menuWindow))))
-
-(MAPL.Simple.FreeMenu
-  (LAMBDA (LEFT BOTTOM)                                      (* DSB " 8-Dec-86 07:59")
-                                                             (* returns a free menu window for simple plots at 
-							     specified position)
-    (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL Command: FONT (MODERN 12 BOLD))
-				 (LABEL MakePlot SELECTEDFN MAPL.Simple.MakePlot))
-				((TYPE TITLE LABEL "FILE INFO" FONT (MODERN 12 BOLD)))
-				((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (FILENAME))
-				 (TYPE EDIT ID FILENAME LABEL ""))
-				((TYPE EDITSTART LABEL Directory: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (DIRECTORY))
-				 (TYPE EDIT ID DIRECTORY LABEL ""))
-				((TYPE EDITSTART LABEL Host: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (HOST))
-				 (TYPE EDIT ID HOST LABEL ""))
-				((TYPE TITLE LABEL "PLOT INFO" FONT (MODERN 12 BOLD)))
-				((TYPE TITLE LABEL PlotType: FONT (MODERN 12 BOLD))
-				 (TYPE NWAY ID TYPE LABEL X-Y CLASSNAME XY)
-				 (TYPE NWAY ID TYPE LABEL X-LogY CLASSNAME X-LogY)
-				 (TYPE NWAY ID TYPE LABEL LogX-Y CLASSNAME LogX-Y)
-				 (TYPE NWAY ID TYPE LABEL LogX-LogY CLASSNAME LogX-LogY))
-				((TYPE TITLE LABEL Representation: FONT (MODERN 12 BOLD))
-				 (TYPE NWAY ID REP LABEL Curve CLASSNAME Curve)
-				 (TYPE NWAY ID REP LABEL Points CLASSNAME Points)
-				 (TYPE NWAY ID REP LABEL Both CLASSNAME Both))
-				((TYPE EDITSTART LABEL PenWidth: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (PEN))
-				 (TYPE EDIT ID PEN LABEL "1"))
-				((TYPE TITLE LABEL Destination: FONT (MODERN 12 BOLD))
-				 (TYPE NWAY ID DEST LABEL New CLASSNAME New)
-				 (TYPE NWAY ID DEST LABEL Previous CLASSNAME Previous))
-				(WINDOWPROPS TITLE "Simple Plot Menu" LEFT , LEFT BOTTOM , BOTTOM)))))
-)
-
-(MAPL.Simple.MakeIconWindow
-  (LAMBDA (WINDOW OLDICON)                                   (* DSB " 5-Dec-86 18:00")
-
-          (* * Creates a window with an icon formed by two bit maps.)
-
-
-    (OR OLDICON (ICONW MAPL.Simple.Icon MAPL.Simple.IconMask))))
-)
-
-
-
-(* Plot functions)
-
-(DEFINEQ
-
-(MAPL.Simple.MakePlot
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Dec-86 11:27")
-                                                             (* checks that required data is specified and that the
-							     fullFilename is valid, and makes the simple plot.)
-    (PROG ((promptW (GETPROMPTWINDOW WINDOW))
-	     state filename directory host type rep penWidth dest fullFilename)
-
-          (* * check that all required data is specified)
-
-
-	    (CLEARW promptW)
-	    (SETQ state (MAPL.ExpandFilename ITEM WINDOW BUTTONS))
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (COND
-	      ((EQUAL filename "")
-		(PRIN1 "Unspecified file name." promptW)
-		(RETURN)))
-	    (SETQ directory (LISTGET state (QUOTE DIRECTORY)))
-	    (COND
-	      ((EQUAL directory "")
-		(PRIN1 "Unspecified directory." promptW)
-		(RETURN)))
-	    (SETQ host (LISTGET state (QUOTE HOST)))
-	    (COND
-	      ((EQUAL host "")
-		(PRIN1 "Unspecified host (DSK,IVY,etc.)" promptW)
-		(RETURN)))
-	    (SETQ type (LISTGET state (QUOTE TYPE)))
-	    (COND
-	      ((NOT type)
-		(PRIN1 "Unspecified plot type (XY, etc)." promptW)
-		(RETURN)))
-	    (SETQ rep (LISTGET state (QUOTE REP)))
-	    (COND
-	      ((NOT rep)
-		(PRIN1 "Unspecified represent. (Points,etc.)" promptW)
-		(RETURN)))
-	    (SETQ penWidth (MKATOM (LISTGET state (QUOTE PEN))))
-	    (COND
-	      ((AND (NUMBERP penWidth)
-		      (GREATERP penWidth 0))
-		(SETQ penWidth (FIX penWidth)))
-	      (T (PRIN1 "PenWidth must be integer > 0" promptW)
-		 (RETURN)))
-	    (SETQ dest (LISTGET state (QUOTE DEST)))
-	    (COND
-	      ((NOT dest)
-		(PRIN1 "Unspecified destination (New, etc.)" promptW)
-		(RETURN)))
-
-          (* * make fullFilename)
-
-
-	    (SETQ fullFilename (PACKFILENAME (QUOTE HOST)
-						 host
-						 (QUOTE DIRECTORY)
-						 directory
-						 (QUOTE BODY)
-						 filename))
-
-          (* * if fullFilename is valid, then make plot)
-
-
-	    (COND
-	      ((NOT (INFILEP fullFilename))
-		(PRIN1 "File not found" promptW)
-		(RETURN))
-	      (T (PRIN1 "Making plot ..." promptW)
-		 (MAPL.Simple.Plot fullFilename promptW rep type penWidth dest)
-		 (CLEARW promptW)
-		 (PRIN1 "Done" promptW)
-		 (RETURN))))))
-
-(MAPL.Simple.Plot
-  (LAMBDA (filename promptW rep type penWidth dest)          (* DSB " 8-Dec-86 08:53")
-                                                             (* Makes the plot and puts it into the appropriate 
-							     window)
-
-          (* * takes an ASCII file of pairs of X-Y values, converts it into list format, and then converts it into a list of 
-	  dotted pairs of data for requested plot.)
-
-
-    (PROG ((rightMenuItems (QUOTE ((Logscale SCAT.LOGSCALE "Toggle exponential tics"
-						 (SUBITEMS (X% axis (SCAT.LOGSCALE (QUOTE X))
-								    "X axis only")
-							   (Y% axis (SCAT.LOGSCALE (QUOTE Y))
-								    "Y axis only")))
-					(Coordinates SCAT.WORLDCOORD 
-						   "Display world coordinates at cursor position"))))
-	     (pointMenuItems (QUOTE ((Coordinates SCAT.POINTCOORDS "Display point coordinates"))))
-	     (tempFile (QUOTE {core}tempplot.dat))
-	     data first second mouseDown? fileStream dataList newPlot)
-
-          (* * copy to {core} and read into a list, with each line in the original file becoming a sub-list)
-
-
-	    (COPYFILE filename tempFile)
-	    (SETQ fileStream (OPENSTREAM tempFile (QUOTE INPUT)))
-	    (SETQ dataList (while (NOT (EOFP tempFile)) collect (MAPL.ReadASCIILine
-									    fileStream)))
-	    (CLOSEF fileStream)
-	    (DELFILE tempFile)
-
-          (* * translate to list of dotted pairs, depending on type of plot to be made)
-
-
-	    (SETQ data NIL)
-	    (COND
-	      ((EQUAL type (QUOTE X-Y))
-		(for item in dataList
-		   do (SETQ first (CAR item))
-			(SETQ second (CADR item))
-			(COND
-			  ((AND (NUMBERP first)
-				  (NUMBERP second))
-			    (SETQ data (CONS (CONS first second)
-						 data))))))
-	      ((EQUAL type (QUOTE X-LogY))
-		(for item in dataList
-		   do (SETQ first (CAR item))
-			(SETQ second (CADR item))
-			(COND
-			  ((AND (NUMBERP first)
-				  (NUMBERP second)
-				  (GREATERP second 0))
-			    (SETQ data (CONS (CONS first (PLOT.LOG10 second))
-						 data))))))
-	      ((EQUAL type (QUOTE LogX-Y))
-		(for item in dataList
-		   do (SETQ first (CAR item))
-			(SETQ second (CADR item))
-			(COND
-			  ((AND (NUMBERP first)
-				  (GREATERP first 0)
-				  (NUMBERP second))
-			    (SETQ data (CONS (CONS (PLOT.LOG10 first)
-							 second)
-						 data))))))
-	      ((EQUAL type (QUOTE LogX-LogY))
-		(for item in dataList
-		   do (SETQ first (CAR item))
-			(SETQ second (CADR item))
-			(COND
-			  ((AND (NUMBERP first)
-				  (GREATERP first 0)
-				  (NUMBERP second)
-				  (GREATERP second 0))
-			    (SETQ data (CONS (CONS (PLOT.LOG10 first)
-							 (PLOT.LOG10 second))
-						 data))))))
-	      (T (CLEARW promptW)
-		 (PRIN1 "Error: Unknown plot type" promptW)
-		 (RETURN)))
-	    (CLEARW promptW)
-
-          (* * If the new data is to be put on a previous plot, the user has 20 seconds to button in the desired plot window)
-
-
-
-          (* * otherwise, the data goes into a new plot)
-
-
-	    (COND
-	      ((EQUAL dest (QUOTE Previous))
-		(PRIN1 "Button in desired plot window" promptW)
-		(SETQ mouseDown? (UNTILMOUSESTATE LEFT 20000))
-		(COND
-		  (mouseDown? (COND
-				((EQUAL rep (QUOTE Points))
-				  (PLOTPOINTS (WHICHPLOT)
-						data)
-				  (RETURN))
-				((EQUAL rep (QUOTE Curve))
-				  (PLOTCURVE (WHICHPLOT)
-					       data NIL penWidth)
-				  (RETURN))
-				((EQUAL rep (QUOTE Both))
-				  (PLOTPOINTS (WHICHPLOT)
-						data)
-				  (PLOTCURVE (WHICHPLOT)
-					       data NIL penWidth)
-				  (RETURN))
-				(T (PRIN1 "Error: Unknown represent." promptW)
-				   (RETURN))))
-		  (T (PRIN1 "Making a new plot." promptW)))))
-	    (SETQ newPlot (CREATEPLOT NIL (QUOTE (471 250 250 250))
-					  "Simple Plot"))
-	    (PLOTADDMENUITEMS newPlot (QUOTE RIGHT)
-				rightMenuItems)
-	    (PLOTMENUITEMS newPlot (QUOTE POINTMENU)
-			     (APPEND (PLOTMENUITEMS newPlot (QUOTE MIDDLE))
-				       pointMenuItems))
-	    (COND
-	      ((EQUAL rep (QUOTE Curve))
-		(PLOTCURVE newPlot data NIL penWidth))
-	      ((EQUAL rep (QUOTE Points))
-		(PLOTPOINTS newPlot data))
-	      ((EQUAL rep (QUOTE Both))
-		(PLOTCURVE newPlot data NIL penWidth)
-		(PLOTPOINTS newPlot data))
-	      (T (PRIN1 "Error: Unknown represent." promptW)
-		 (RETURN)))
-	    (OPENPLOTWINDOW newPlot))))
-)
-
-
-
-(* Icon bitmaps)
-
-
-(RPAQ MAPL.Simple.Icon (READBITMAP))
-(70 70
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"L@@@@@@@@@ON@@@@@L@@"
-"L@@@@@@@@@GO@@@@@L@@"
-"L@@@@COOOOOOOOOOLL@@"
-"L@@@@B@@@@AOH@@@DL@@"
-"L@@@@B@@@@@OL@@@DL@@"
-"L@@@@B@@@@@GN@@@DL@@"
-"L@@@@BB@@@@CO@@@DL@@"
-"L@@@@BB@@@@AOH@@DL@@"
-"L@@@@BF@@@@@OH@@DL@@"
-"L@@@@BB@@@@@GL@@DL@@"
-"L@@@@BB@@@@@CL@@DL@@"
-"LOO@@BB@@@@@AN@@DL@@"
-"LLC@@BF@@@@@@F@@DL@@"
-"LLC@@BB@@@@@@C@@DL@@"
-"LL@@@BB@@@@@@AH@DL@@"
-"LL@@@BB@@CL@@GH@DL@@"
-"LL@@@BF@@FF@AL@@DL@@"
-"LL@CNBB@@LC@C@@@DL@@"
-"LOOCNBB@AHAHN@@@DL@@"
-"L@C@@BB@C@@OH@@@DL@@"
-"L@C@@BF@F@@@@@@@DL@@"
-"L@C@@BB@L@@@@@@@DL@@"
-"L@C@@BB@H@@@@@@@DL@@"
-"LLC@@BBAH@@@@@@@DL@@"
-"LLC@@BFA@@@@@@@@DL@@"
-"LOO@@BBC@@@@@@@@DL@@"
-"L@@@@BBB@@@@@@@@DL@@"
-"L@@@@BBF@@@@@@@@DL@@"
-"L@@@@BFD@@@@@@@@DL@@"
-"L@@@@BB@@@@@@@@@DL@@"
-"L@@@@BB@@@@@@@@@DL@@"
-"L@@@@BB@@@@@@@@@DL@@"
-"L@@@@BGOOOOOOOONDL@@"
-"L@@@@BBBBBBBBBBBDL@@"
-"L@@@@B@@@@@@@@@@DL@@"
-"L@@@@COOOOOOOOOOLL@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"LOOOOOH@@@@@@@@@@L@@"
-"L@LOLL@@@@@@@@@@@L@@"
-"LAHGHF@@@@@@@@@@@L@@"
-"LC@C@C@@@@@@@@@@@L@@"
-"LC@C@C@@@@@@@@@@@L@@"
-"LC@C@C@@@@@@@@@@@L@@"
-"LC@C@C@@ON@OO@NALL@@"
-"LC@C@C@@NF@NG@FAHL@@"
-"LC@C@C@@LB@LC@FAHL@@"
-"LC@C@C@@H@@LC@FAHL@@"
-"LC@C@C@@LH@LC@FAHL@@"
-"LC@C@C@@OH@LC@FAHL@@"
-"LC@C@C@@LH@LC@FAHL@@"
-"LC@GHC@@H@@LC@FAHL@@"
-"LC@@@C@@LB@LC@FAHL@@"
-"LC@@@C@@NF@LC@GCHL@@"
-"LC@@@C@@ONALCHGOHL@@"
-"LC@@@C@@@@@@@@@@@L@@"
-"LOH@@GL@@@@@@@@@@L@@"
-"LOH@@GL@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@")
-
-(RPAQ MAPL.Simple.IconMask (READBITMAP))
-(70 70
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@")
-(* * GENERAL PLOT STUFF)
-
-
-
-
-(* Menu and window functions)
-
-(DEFINEQ
-
-(MAPL.Gen.TopLevel
-  (LAMBDA NIL                                                (* DSB " 5-Dec-86 11:45")
-                                                             (* Sets up the General Plot Free Menu)
-    (PROG (menuWindow)
-	    (SETQ menuWindow (MAPL.Gen.FreeMenu 200 50))
-
-          (* * initialize plot defaults)
-
-
-	    (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE TYPE))
-			      menuWindow)
-	    (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE REP))
-			      menuWindow)
-	    (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE PEN))
-			      menuWindow)
-
-          (* * finish setup of free menu)
-
-
-	    (WINDOWPROP menuWindow (QUOTE ICONFN)
-			  (FUNCTION MAPL.Gen.MakeIconWindow))
-	    (OPENW menuWindow))))
-
-(MAPL.Gen.FreeMenu
-  (LAMBDA (LEFT BOTTOM)                                      (* DSB " 4-Dec-86 13:09")
-                                                             (* returns a free menu window for simple plots at 
-							     specified position)
-    (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL Command: FONT (MODERN 12 BOLD))
-				 (LABEL MakePlot SELECTEDFN MAPL.Gen.MakePlot))
-				((TYPE TITLE LABEL "FILE INFO" FONT (MODERN 12 BOLD)))
-				((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (FILENAME))
-				 (TYPE EDIT ID FILENAME LABEL ""))
-				((TYPE EDITSTART LABEL Directory: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (DIRECTORY))
-				 (TYPE EDIT ID DIRECTORY LABEL ""))
-				((TYPE EDITSTART LABEL Host: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (HOST))
-				 (TYPE EDIT ID HOST LABEL ""))
-				((TYPE TITLE LABEL "PLOT INFO" FONT (MODERN 12 BOLD)))
-				((TYPE EDITSTART LABEL X-Position: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (XPOS))
-				 (TYPE EDIT ID XPOS LABEL "1"))
-				((TYPE EDITSTART LABEL Y-Position: FONT (MODERN 12 BOLD)
-				       ITEMS
-				       (YPOS))
-				 (TYPE EDIT ID YPOS LABEL "2"))
-				((TYPE TITLE LABEL PlotType: FONT (MODERN 12 BOLD))
-				 (TYPE NWAY ID TYPE LABEL X-Y CLASSNAME XY)
-				 (TYPE NWAY ID TYPE LABEL X-LogY CLASSNAME X-LogY)
-				 (TYPE NWAY ID TYPE LABEL LogX-Y CLASSNAME LogX-Y)
-				 (TYPE NWAY ID TYPE LABEL LogX-LogY CLASSNAME LogX-LogY))
-				((TYPE TITLE LABEL Representation: FONT (MODERN 12 BOLD))
-				 (TYPE NWAY ID REP LABEL Curve CLASSNAME Curve)
-				 (TYPE NWAY ID REP LABEL Points CLASSNAME Points)
-				 (TYPE NWAY ID REP LABEL Both CLASSNAME Both))
-				((TYPE TITLE LABEL PenWidth: FONT (MODERN 12 BOLD))
-				 (TYPE NWAY ID PEN LABEL ON)
-				 (TYPE NWAY ID PEN LABEL OFF))
-				(WINDOWPROPS TITLE "General Plot Menu" LEFT , LEFT BOTTOM , BOTTOM))))
-    ))
-
-(MAPL.Gen.MakeIconWindow
-  (LAMBDA (WINDOW OLDICON)                                   (* DSB " 5-Dec-86 17:42")
-
-          (* * Creates a shrink window with an icon formed by two bit maps.)
-
-
-    (OR OLDICON (ICONW MAPL.Gen.Icon MAPL.Gen.IconMask))))
-)
-
-
-
-(* Plot functions)
-
-(DEFINEQ
-
-(MAPL.Gen.MakePlot
-  (LAMBDA (ITEM WINDOW BUTTONS)                              (* DSB "15-Dec-86 11:30")
-                                                             (* checks that required data is specified and that the
-							     fullFilename is valid, and makes the simple plot.)
-    (PROG ((promptW (GETPROMPTWINDOW WINDOW))
-	     state filename directory host type rep xPos yPos penFlag fullFilename)
-
-          (* * check that all required data is specified)
-
-
-	    (CLEARW promptW)
-	    (SETQ state (MAPL.ExpandFilename ITEM WINDOW BUTTONS))
-	    (SETQ filename (LISTGET state (QUOTE FILENAME)))
-	    (COND
-	      ((EQUAL filename "")
-		(PRIN1 "Unspecified file name." promptW)
-		(RETURN)))
-	    (SETQ directory (LISTGET state (QUOTE DIRECTORY)))
-	    (COND
-	      ((EQUAL directory "")
-		(PRIN1 "Unspecified directory." promptW)
-		(RETURN)))
-	    (SETQ host (LISTGET state (QUOTE HOST)))
-	    (COND
-	      ((EQUAL host "")
-		(PRIN1 "Unspecified host (DSK,IVY,etc.)" promptW)
-		(RETURN)))
-	    (SETQ xPos (MKATOM (LISTGET state (QUOTE XPOS))))
-                                                             (* if xPos is not a number, set it to NIL for a 
-							     Time-Series plot)
-	    (COND
-	      ((NOT (NUMBERP xPos))
-		(SETQ xPos (NUMBERP xPos))
-		(PRIN1 "Time-series plot..." promptW)))
-	    (SETQ yPos (MKATOM (LISTGET state (QUOTE YPOS))))
-	    (COND
-	      ((NOT (NUMBERP yPos))
-		(PRIN1 "Unspecified position of 'Y' variable" promptW)
-		(RETURN)))
-	    (SETQ type (LISTGET state (QUOTE TYPE)))
-	    (COND
-	      ((NOT type)
-		(PRIN1 "Unspecified plot type (XY, etc)." promptW)
-		(RETURN)))                                 (* if xPos is NIL, do not allow Logs of the "time")
-	    (COND
-	      ((AND (NOT xPos)
-		      (OR (EQUAL type (QUOTE LogX-Y))
-			    (EQUAL type (QUOTE LogX-LogY))))
-		(PRIN1 "Log of X (time) not permitted" promptW)
-		(RETURN)))
-	    (SETQ rep (LISTGET state (QUOTE REP)))
-	    (COND
-	      ((NOT rep)
-		(PRIN1 "Unspecified represent. (Points,etc.)" promptW)
-		(RETURN)))
-	    (SETQ penFlag (EQ (QUOTE ON)
-				  (LISTGET state (QUOTE PEN))))
-
-          (* * make fullFilename)
-
-
-	    (SETQ fullFilename (PACKFILENAME (QUOTE HOST)
-						 host
-						 (QUOTE DIRECTORY)
-						 directory
-						 (QUOTE BODY)
-						 filename))
-
-          (* * if fullFilename is valid, then make plot)
-
-
-	    (COND
-	      ((NOT (INFILEP fullFilename))
-		(PRIN1 "File not found" promptW)
-		(RETURN))
-	      (T (PRIN1 "Making plot ..." promptW)
-		 (MAPL.Gen.Plot fullFilename promptW xPos yPos rep type penFlag)
-		 (CLEARW promptW)
-		 (PRIN1 "Done" promptW)
-		 (RETURN))))))
-
-(MAPL.Gen.Plot
-  (LAMBDA (file promptW xPos yPos rep type penFlag)          (* DSB " 5-Dec-86 17:41")
-
-          (* * makes a plot from the general plot input format)
-
-
-    (PROG (dataList keyword plot objectList (pen 1)
-		      (plotNumber 1))
-
-          (* * get a data list of those pairs of data you want to plot)
-
-
-	    (SETQ dataList (MAPL.Gen.ASCIIToLisp file xPos yPos))
-                                                             (* (PRIN1 dataList PROMPTWINDOW))
-
-          (* * parse and plot)
-
-
-	    (COND
-	      ((NOT dataList)
-		(RETURN (PRIN1 "There is no data" promptW))))
-	    (for item in dataList
-	       do (SETQ keyword (CAR item))
-		    (SELECTQ keyword
-			       (NEWPLOT (SETQ plot (MAPL.Gen.NewPlot plotNumber))
-                                                             (* New plot)
-					)
-			       (START (SETQ objectList NIL)
-                                                             (* Start new object)
-				      )
-			       (END (SETQ objectList (MAPL.Gen.PlotObject plot objectList pen rep)
-				      )                      (* Plot the object)
-				    )
-			       (ENDPLOT (SETQ plotNumber (MAPL.Gen.EndPlot plot plotNumber))
-                                                             (* End of plot)
-					)
-			       (NEWPEN (SETQ pen (MAPL.Gen.NewPen item penFlag))
-                                                             (* New pen)
-				       )
-			       (SETQ objectList (MAPL.Gen.CollectData objectList item type)))))))
-
-(MAPL.Gen.ASCIIToLisp
-  (LAMBDA (file xPos yPos)                                   (* DSB " 5-Dec-86 17:34")
-
-          (* * returns ASCII data from a file in a list, with one sub-list per line. The file must end in a CR.)
-
-
-    (PROG ((tempFile (QUOTE {core}tempplot.dat))
-	     (keywordList (QUOTE (NEWPLOT ENDPLOT START END NEWPEN)))
-	     fileStream dataList lineList key shortList)
-	    (COND
-	      ((NOT (INFILEP file))
-		(RETURN NIL)))
-	    (COPYFILE file tempFile)
-
-          (* * copy to {core} because reads from filestream to {core} are much faster than reads from filestream to a VAX on 
-	  the network.)
-
-
-
-          (* * if Keyword, return the line as is; otherwise, only include the numbers in the positions requested.)
-
-
-
-          (* * if xPos is NIL, put NIL in the first position of the short list)
-
-
-	    (SETQ fileStream (OPENSTREAM tempFile (QUOTE INPUT)))
-	    (while (NOT (EOFP tempFile))
-	       do (SETQ lineList (MAPL.ReadASCIILine fileStream))
-		    (SETQ key (CAR lineList))
-		    (COND
-		      ((MEMBER key keywordList)
-			(SETQ shortList lineList))
-		      ((NOT xPos)
-			(SETQ shortList (LIST NIL (CAR (NTH lineList yPos)))))
-		      (T (SETQ shortList (LIST (CAR (NTH lineList xPos))
-						   (CAR (NTH lineList yPos))))))
-		    (SETQ dataList (CONS shortList dataList)))
-	    (CLOSEF fileStream)
-	    (DELFILE tempFile)
-	    (RETURN (REVERSE dataList)))))
-
-(MAPL.Gen.NewPlot
-  (LAMBDA (plotNumber)                                       (* DSB " 5-Dec-86 11:44")
-
-          (* * starts a new plot with Log scaling)
-
-
-    (PROG (newPlot (leftFirst 471)
-		     left
-		     (bottomFirst 50)
-		     bottom region (rightMenuItems (QUOTE
-						     ((Logscale SCAT.LOGSCALE 
-								"Toggle exponential tics"
-								(SUBITEMS (X% axis
-									    (SCAT.LOGSCALE
-									      (QUOTE X))
-									    "X axis only")
-									  (Y% axis
-									    (SCAT.LOGSCALE
-									      (QUOTE Y))
-									    "Y axis only")))
-						       (Coordinates SCAT.WORLDCOORD 
-						   "Display world coordinates at cursor position"))))
-		     (pointMenuItems (QUOTE ((Coordinates SCAT.POINTCOORDS 
-							    "Display point coordinates")))))
-	    (SETQ left (PLUS leftFirst (TIMES 25 (DIFFERENCE plotNumber 1))))
-	    (SETQ bottom (PLUS bottomFirst (TIMES 25 (DIFFERENCE plotNumber 1))))
-	    (SETQ region (CREATEREGION left bottom 250 250))
-	    (SETQ newPlot (CREATEPLOT NIL region "General Plot"))
-	    (PLOTADDMENUITEMS newPlot (QUOTE RIGHT)
-				rightMenuItems)
-	    (PLOTMENUITEMS newPlot (QUOTE POINTMENU)
-			     (APPEND (PLOTMENUITEMS newPlot (QUOTE MIDDLE))
-				       pointMenuItems))
-	    (RETURN newPlot))))
-
-(MAPL.Gen.PlotObject
-  (LAMBDA (plot objectList pen rep)                          (* DSB " 8-Dec-86 07:28")
-
-          (* * plots the objectList, with specified pen and according to the chosen representation (e.g., points, curve, 
-	  both))
-
-
-
-          (* * when plotting points, ignore the pen size)
-
-
-    (PROG NIL
-	    (COND
-	      ((NOT plot)
-		(RETURN (PRIN1 "ERROR:  NEWPLOT command omitted.  " PROMPTWINDOW))))
-	    (COND
-	      ((AND objectList (GREATERP (LENGTH objectList)
-					     0))
-		(COND
-		  ((EQUAL rep (QUOTE Curve))
-		    (PLOTCURVE plot objectList NIL pen NIL T))
-		  ((EQUAL rep (QUOTE Points))
-		    (PLOTPOINTS plot objectList NIL NIL NIL T))
-		  ((EQUAL rep (QUOTE Both))
-		    (PLOTCURVE plot objectList NIL pen NIL T)
-		    (PLOTPOINTS plot objectList NIL NIL NIL T))))
-	      (T (PROMPTPRINT "ERROR:  PlotObject is NIL and not drawn")))
-	    (RETURN NIL))))
-
-(MAPL.Gen.EndPlot
-  (LAMBDA (plot plotNumber)                                  (* DSB " 4-Dec-86 14:17")
-
-          (* * opens the plotwindow, and returns a new increment for the next plot position)
-
-
-    (PROG NIL
-	    (OPENPLOTWINDOW plot)
-	    (RETURN (PLUS plotNumber 1)))))
-
-(MAPL.Gen.NewPen
-  (LAMBDA (item penFlag)                                     (* DSB " 8-Dec-86 07:30")
-
-          (* * If penFlag is OFF, sets pen to 1; otherwise, sets pen width as instructed.)
-
-
-    (PROG (pen)
-	    (COND
-	      (penFlag (SETQ pen (CADR item)))
-	      (T (SETQ pen 1)))
-	    (RETURN pen))))
-
-(MAPL.Gen.CollectData
-  (LAMBDA (objectList item type)                             (* DSB " 8-Dec-86 09:43")
-
-          (* * adds the appropriate dotted pair (determined by dest and the input item) to the objectList.)
-
-
-    (PROG ((xVal (CAR item))
-	     (yVal (CADR item))
-	     newItem)
-
-          (* * not numbers; don't do anything)
-
-
-	    (COND
-	      ((NOT (NUMBERP yVal))
-		(RETURN objectList)))
-
-          (* * if xVal is NIL (not a number) but yVal is a number, then assume the user is asking for a time sequence.
-	  However, LogX is not allowed. This will slip past MAPL.Gen.MakePlot if the X-position is given as a 
-	  (too large) number. We stop that here.)
-
-
-	    (COND
-	      ((AND (NOT (NUMBERP xVal))
-		      (NUMBERP yVal))
-		(COND
-		  ((OR (EQUAL type (QUOTE LogX-Y))
-			 (EQUAL type (QUOTE LogX-LogY)))
-		    (PROMPTPRINT "Log X for X=time-sequence not allowed")
-		    (RETURN objectList)))
-		(COND
-		  ((NOT objectList)
-		    (SETQ xVal 0))
-		  (T (SETQ xVal (PLUS 1 (CAAR objectList)))))))
-
-          (* * non time-series plot)
-
-
-	    (COND
-	      ((EQUAL type (QUOTE X-Y))
-		(SETQ newItem (CONS xVal yVal)))
-	      ((EQUAL type (QUOTE X-LogY))
-		(COND
-		  ((GREATERP yVal 0)
-		    (SETQ newItem (CONS xVal (PLOT.LOG10 yVal))))
-		  (T (PROMPTPRINT "ERROR: Attempt to take Log of negative number " yVal))))
-	      ((EQUAL type (QUOTE LogX-Y))
-		(COND
-		  ((GREATERP xVal 0)
-		    (SETQ newItem (CONS (PLOT.LOG10 xVal)
-					    yVal)))
-		  (T (PROMPTPRINT "ERROR: Attempt to take Log of negative number " xVal))))
-	      ((EQUAL type (QUOTE LogX-LogY))
-		(COND
-		  ((AND (GREATERP xVal 0)
-			  (GREATERP yVal 0))
-		    (SETQ newItem (CONS (PLOT.LOG10 xVal)
-					    (PLOT.LOG10 yVal))))
-		  (T (PROMPTPRINT "ERROR: Attempt to take Log of neg. number at point (" xVal "," 
-				    yVal ")"))))
-	      (T (PRIN1 "ERROR: Unknown plot type requested" PROMPTWINDOW)))
-	    (COND
-	      (newItem (SETQ objectList (CONS newItem objectList))))
-	    (RETURN objectList))))
-)
-
-
-
-(* Icon bitmaps)
-
-
-(RPAQ MAPL.Gen.Icon (READBITMAP))
-(70 70
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"L@@@@@@@@@ON@@@@@L@@"
-"L@@@@@@@@@GO@@@@@L@@"
-"L@@@@COOOOOOOOOOLL@@"
-"L@@@@B@@@@AOH@@@DL@@"
-"L@@@@B@@@@@OL@@@DL@@"
-"L@@@@B@@@@@GN@@@DL@@"
-"L@@@@BB@@@@CO@@@DL@@"
-"L@@@@BB@@@@AOH@@DL@@"
-"L@@@@BF@@@@@OH@@DL@@"
-"L@@@@BB@@@@@GL@@DL@@"
-"L@@@@BB@@@@@CL@@DL@@"
-"LOOH@BB@@@@@AN@@DL@@"
-"LLAH@BF@@@@@@F@@DL@@"
-"LLAH@BB@@@@@@C@@DL@@"
-"LL@@@BB@@@@@@AH@DL@@"
-"LL@@@BB@@CL@@GH@DL@@"
-"LL@@@BF@@FF@AL@@DL@@"
-"LL@AOBB@@LC@C@@@DL@@"
-"LLOIOBB@AHAHN@@@DL@@"
-"LLMH@BB@C@@OH@@@DL@@"
-"LLMH@BF@F@@@@@@@DL@@"
-"LLAH@BB@L@@@@@@@DL@@"
-"LLAH@BB@H@@@@@@@DL@@"
-"LLAH@BBAH@@@@@@@DL@@"
-"LLAH@BFA@@@@@@@@DL@@"
-"LOOH@BBC@@@@@@@@DL@@"
-"L@@@@BBB@@@@@@@@DL@@"
-"L@@@@BBF@@@@@@@@DL@@"
-"L@@@@BFD@@@@@@@@DL@@"
-"L@@@@BB@@@@@@@@@DL@@"
-"L@@@@BB@@@@@@@@@DL@@"
-"L@@@@BB@@@@@@@@@DL@@"
-"L@@@@BGOOOOOOOONDL@@"
-"L@@@@BBBBBBBBBBBDL@@"
-"L@@@@B@@@@@@@@@@DL@@"
-"L@@@@COOOOOOOOOOLL@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"LOOOOOH@@@@@@@@@@L@@"
-"L@LOLL@@@@@@@@@@@L@@"
-"LAHGHF@@@@@@@@@@@L@@"
-"LC@C@C@@@@@@@@@@@L@@"
-"LC@C@C@@@@@@@@@@@L@@"
-"LC@C@C@@@@@@@@@@@L@@"
-"LC@C@C@@ON@OO@NALL@@"
-"LC@C@C@@NF@NG@FAHL@@"
-"LC@C@C@@LB@LC@FAHL@@"
-"LC@C@C@@H@@LC@FAHL@@"
-"LC@C@C@@LH@LC@FAHL@@"
-"LC@C@C@@OH@LC@FAHL@@"
-"LC@C@C@@LH@LC@FAHL@@"
-"LC@GHC@@H@@LC@FAHL@@"
-"LC@@@C@@LB@LC@FAHL@@"
-"LC@@@C@@NF@LC@GCHL@@"
-"LC@@@C@@ONALCHGOHL@@"
-"LC@@@C@@@@@@@@@@@L@@"
-"LOH@@GL@@@@@@@@@@L@@"
-"LOH@@GL@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"L@@@@@@@@@@@@@@@@L@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@")
-
-(RPAQ MAPL.Gen.IconMask (READBITMAP))
-(70 70
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@"
-"OOOOOOOOOOOOOOOOOL@@")
-
-
-
-(* vars)
-
-(MAPL.MakeReadtable)
-(DECLARE: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS MAPL.ASCIIRDTBL)
-)
-
-(ADDTOVAR BackgroundMenuCommands (Plot% Menus (QUOTE (MAPL.TopLevel))
-						"Opens all Plot Menus"
-						(SUBITEMS (General% PlotMenu (QUOTE (MAPL.Gen.TopLevel
-										      ))
-									     
-								       "Open a General Plot Menu")
-							  (Simple% PlotMenu (QUOTE (
-MAPL.Simple.TopLevel))
-									    "Open a Simple Plot Menu")
-							  (Meta% PlotMenu (QUOTE (MAPL.Meta.TopLevel))
-									  "Open a MetaCode Plot Menu")
-							  )))
-
-(RPAQQ BackgroundMenu NIL)
-(PUTPROPS MATHSERVERPLOT COPYRIGHT ("Xerox Corporation" 1986))
-(DECLARE: DONTCOPY
-  (FILEMAP (NIL (2744 5312 (MAPL.TopLevel 2754 . 3043) (MAPL.MakeReadtable 3045 . 3446) (
-MAPL.ReadASCIILine 3448 . 3909) (MAPL.ExpandFilename 3911 . 5310)) (5383 7480 (MAPL.Meta.TopLevel 5393
- . 6056) (MAPL.Meta.FreeMenu 6058 . 7203) (MAPL.Meta.MakeIconWindow 7205 . 7478)) (7508 11497 (
-MAPL.Meta.MakePlot 7518 . 9264) (MAPL.Meta.Plot 9266 . 10593) (MAPL.Meta.ASCIIToLisp 10595 . 11495)) (
-11529 13474 (MAPL.Meta.NewPlotCom 11539 . 11840) (MAPL.Meta.MoveCom 11842 . 12308) (MAPL.Meta.DrawCom 
-12310 . 12621) (MAPL.Meta.EndPlotCom 12623 . 13057) (MAPL.Meta.NewPenCom 13059 . 13472)) (16880 19790 
-(MAPL.Simple.TopLevel 16890 . 17706) (MAPL.Simple.FreeMenu 17708 . 19514) (MAPL.Simple.MakeIconWindow 
-19516 . 19788)) (19818 27100 (MAPL.Simple.MakePlot 19828 . 22323) (MAPL.Simple.Plot 22325 . 27098)) (
-30511 33501 (MAPL.Gen.TopLevel 30521 . 31327) (MAPL.Gen.FreeMenu 31329 . 33227) (
-MAPL.Gen.MakeIconWindow 33229 . 33499)) (33529 45006 (MAPL.Gen.MakePlot 33539 . 36529) (MAPL.Gen.Plot 
-36531 . 38142) (MAPL.Gen.ASCIIToLisp 38144 . 39718) (MAPL.Gen.NewPlot 39720 . 41084) (
-MAPL.Gen.PlotObject 41086 . 42080) (MAPL.Gen.EndPlot 42082 . 42388) (MAPL.Gen.NewPen 42390 . 42736) (
-MAPL.Gen.CollectData 42738 . 45004)))))
-STOP
diff --git a/obsolete/lispusers/microtek.tedit b/obsolete/lispusers/microtek.tedit
deleted file mode 100644
index 579d1909..00000000
Binary files a/obsolete/lispusers/microtek.tedit and /dev/null differ
diff --git a/obsolete/lispusers/splinefonts/GACHAE.LC1-SF b/obsolete/lispusers/splinefonts/GACHAE.LC1-SF
deleted file mode 100644
index 79c03e55..00000000
--- a/obsolete/lispusers/splinefonts/GACHAE.LC1-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY gacha)
 (CHARACTER 141Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 14:22:31)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((3
    ((93 182) (93 182) (143 182))
    NIL
    ((-12.5 0 0 0 75. 0 )
     (25. 0 75. 0 -75. 0 ))
    NATURAL)
   (19
    ((143 182) (147 197) (170 215) (225 221) (290 213) (309 194)
     (287 165) (191 156) (122 142) (100 128) (85 110) (75 78)
     (81 46) (96 25) (118 9) (153 -4) (199 -8) (247 -2)
     (313 14))
    NIL
    ((0.804730058 13.568931 0 0 19.171619 8.5864067 )
     (10.390539 17.862133 19.171619 8.5864067 18.1419029 -24.932033 )
     (38.63311 13.9825229 37.313522 -16.3456268 -13.7392387 1.14173698 )
     (69.07701 -1.79223466 23.574283 -15.2038898 -95.184936 8.36507798 )
     (45.058822 -12.813585 -71.610656 -6.83881188 58.47901 -16.602043 )
     (2.68767023 -27.953422 -13.131645 -23.440856 -108.73107 64.043106 )
     (-64.809524 -19.372722 -121.8627 40.602249 178.4453 -59.570404 )
     (-97.44955 -8.5556755 56.58264 -18.968154 0.949485779 24.238521 )
     (-40.39218 -15.404567 57.532127 5.27036858 -62.243286 -7.38368893 )
     (-13.981699 -13.826044 -4.7111616 -2.11332083 8.02367784 -18.703762 )
     (-14.6810188 -25.291248 3.31251764 -20.817085 18.148567 22.19876 )
     (-2.29421711 -35.008949 21.461086 1.38167786 -14.617956 13.908697 )
     (11.857891 -26.672924 6.8431301 15.290376 -1.67673778 -11.8335666 )
     (17.862651 -17.299331 5.16639233 3.45680857 9.3249073 -2.57442284 )
     (27.691497 -15.1297359 14.4913 0.882385612 0.377099991 10.1312599 )
     (42.371345 -9.1817188 14.8684 11.013647 -22.833305 -1.95062256 )
     (45.823097 0.856617928 -7.9649067 9.0630245 36.956123 3.67121887 )
     (56.336258 11.7552509 28.991222 12.734243 -28.991222 -12.734243 ))
    NATURAL)
   (5
    ((313 14) (329 6) (358 -1) (378 0) (397 2))
    NIL
    ((11.8928566 -7.7142849 0 0 24.642856 -1.71428537 )
     (24.214283 -8.5714283 24.642856 -1.71428537 -45.214279 14.571426 )
     (26.249996 -2.99999952 -20.571426 12.857141 24.214283 -14.571426 )
     (17.785713 2.5714283 3.6428566 -1.71428561 -3.6428566 1.71428561 ))
    NATURAL)
   (2
    ((397 2) (397 36))
    NIL
    ((0 34. 0 0 0 0 ))
    NATURAL)
   (4
    ((397 36) (378 36) (361 41) (355 51))
    NIL
    ((-18.799999 -1. 0 0 -1.19999981 6. )
     (-19.399997 2. -1.19999981 6. 17.999996 0 )
     (-11.599998 8. 16.799999 6. -16.799999 -6. ))
    NATURAL)
   (2
    ((355 51) (355 185))
    NIL
    ((0 134. 0 0 0 0 ))
    NATURAL)
   (6
    ((355 185) (348 212) (328 232) (304 245) (271 252) (229 256))
    NIL
    ((-3.67464113 28.473682 0 0 -19.952152 -8.84210397 )
     (-13.6507168 24.052627 -19.952152 -8.84210397 21.760761 2.21052551 )
     (-22.722484 16.315788 1.80861187 -6.63157845 -13.090906 0 )
     (-27.459327 9.6842098 -11.282295 -6.63157845 0.602870941 3.78947353 )
     (-38.440185 4.94736767 -10.679424 -2.84210491 10.679424 2.84210491 ))
    NATURAL)
   (6
    ((229 256) (177 253) (135 241) (115 228) (99 209) (93 182))
    NIL
    ((-53.12918 -0.583732248 0 0 6.77511979 -14.497606 )
     (-49.741623 -7.83253575 6.77511979 -14.497606 26.1244 18.488033 )
     (-29.904304 -13.086122 32.89952 3.99043036 -39.27272 -11.454544 )
     (-16.641147 -14.822965 -6.37320519 -7.46411515 22.966503 -2.66985512 )
     (-11.531099 -23.622009 16.5932998 -10.13397 -16.5932998 10.13397 ))
    NATURAL))

  ((11
    ((308 127) (235 123) (180 115) (142 101) (127 74) (139 46)
     (174 32) (223 30) (290 45) (308 80) (308 127))
    NIL
    ((-76.935379 -3.13017798 0 0 23.612281 -5.21893215 )
     (-65.129226 -5.73964405 23.612281 -5.21893215 -10.061409 2.09466267 )
     (-46.54766 -9.91124536 13.5508728 -3.12426949 10.63335 -15.159719 )
     (-27.68011 -20.615371 24.184223 -18.2839889 3.5280075 16.544212 )
     (-1.73188519 -30.627254 27.71223 -1.73977589 -0.745380402 20.982864 )
     (25.607654 -21.875595 26.96685 19.243091 -24.546482 -10.4756908 )
     (40.30126 -7.87034989 2.42036581 8.76740075 44.931312 8.9199009 )
     (65.187286 5.35700226 47.351684 17.687301 -131.1788 4.79608155 )
     (46.949569 25.442344 -83.827118 22.483383 77.783889 -10.1042308 )
     (2.0144062 42.87361 -6.04321957 12.379152 6.04321957 -12.379152 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 142Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 14:29:14)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((3
    ((73 337) (73 337) (73 0))
    NIL
    ((0 84.25 0 0 0 -505.5 )
     (0 -168.5 0 -505.5 0 505.5 ))
    NATURAL)
   (2
    ((73 0) (122 0))
    NIL
    ((49. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((122 0) (122 19))
    NIL
    ((0 19. 0 0 0 0 ))
    NATURAL)
   (19
    ((122 19) (145 7) (186 -3) (223 -6) (274 -2) (306 10)
     (330 24) (346 42) (358 66) (367 124) (358 182) (346 206)
     (330 224) (306 238) (274 250) (223 254) (186 251) (145 241)
     (122 229))
    NIL
    ((17.530986 -12.1277828 0 0 32.814079 0.766703606 )
     (33.938026 -11.74443 32.814079 0.766703606 -56.070419 8.166481 )
     (38.716896 -6.89448739 -23.25634 8.93318559 59.467628 -3.43263149 )
     (45.194366 0.322382927 36.211288 5.50055409 -73.800094 5.56404019 )
     (44.505607 8.60495759 -37.588813 11.064594 37.732772 -12.823528 )
     (25.783184 13.2577877 0.143964797 -1.75893473 -11.131006 9.73007585 )
     (20.361644 16.363891 -10.987041 7.97114278 6.79124547 -14.0967788 )
     (12.770227 17.286644 -4.195796 -6.12563706 7.96602345 58.657035 )
     (12.5574417 40.489532 3.77022743 52.531402 -32.655334 -52.531402 )
     (-3.20374965E-7 66.755233 -28.885112 0 32.655334 -52.531402 )
     (-12.5574417 40.489524 3.77022743 -52.531402 -7.96602345 58.657035 )
     (-12.770227 17.286644 -4.195796 6.12563706 -6.79124547 -14.0967788 )
     (-20.361644 16.363891 -10.987041 -7.97114278 11.131006 9.73007585 )
     (-25.783184 13.2577858 0.143965035 1.75893426 -37.732772 -12.823528 )
     (-44.505607 8.60495568 -37.588813 -11.064594 73.800094 5.56404019 )
     (-45.194366 0.322382271 36.211288 -5.50055409 -59.467628 -3.43263149 )
     (-38.716896 -6.89448739 -23.25634 -8.93318559 56.070419 8.166481 )
     (-33.938026 -11.74443 32.814079 -0.766703487 -32.814079 0.766703487 ))
    NATURAL)
   (2
    ((122 229) (122 337))
    NIL
    ((0 108. 0 0 0 0 ))
    NATURAL)
   (2
    ((122 337) (73 337))
    NIL
    ((-49. 0 0 0 0 0 ))
    NATURAL))

  ((11
    ((315 124) (312 86) (300 53) (275 34) (240 28) (220 28)
     (200 28) (165 34) (140 53) (128 86) (125 124))
    NIL
    ((-1.25837326 -38.552482 0 0 -10.44976 3.31491756 )
     (-6.48325349 -36.895027 -10.44976 3.31491756 -1.75119591 13.425411 )
     (-17.808612 -26.8674 -12.200956 16.740329 -6.54545403 -3.01657295 )
     (-33.282295 -11.6353588 -18.74641 13.7237568 45.933013 -7.35911656 )
     (-29.062198 -1.59116006 27.186603 6.36464024 -27.186603 -9.5469589 )
     (-15.4688987 0 0 -3.18232012 -27.186603 9.5469589 )
     (-29.062198 1.5911603 -27.186603 6.36464024 45.933013 7.35911656 )
     (-33.282295 11.6353588 18.74641 13.7237568 -6.54545403 3.01657295 )
     (-17.808609 26.8674 12.200956 16.740329 -1.75119781 -13.425413 )
     (-6.48325253 36.895027 10.4497585 3.3149166 -10.4497585 -3.3149166 ))
    NATURAL)
   (11
    ((125 124) (128 162) (140 195) (165 214) (200 220) (220 220)
     (240 220) (275 214) (300 195) (312 162) (315 124))
    NIL
    ((1.25837326 38.552482 0 0 10.44976 -3.31491756 )
     (6.48325349 36.895027 10.44976 -3.31491756 1.75119591 -13.425411 )
     (17.808612 26.8674 12.200956 -16.740329 6.54545403 3.01657295 )
     (33.282295 11.6353588 18.74641 -13.7237568 -45.933013 7.35911656 )
     (29.062198 1.59116006 -27.186603 -6.36464024 27.186603 9.5469589 )
     (15.4688987 0 0 3.18232012 27.186603 -9.5469589 )
     (29.062198 -1.5911603 27.186603 -6.36464024 -45.933013 -7.35911656 )
     (33.282295 -11.6353588 -18.74641 -13.7237568 6.54545403 -3.01657295 )
     (17.808609 -26.8674 -12.200956 -16.740329 1.75119781 13.425413 )
     (6.48325253 -36.895027 -10.4497585 -3.3149166 10.4497585 3.3149166 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 143Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  7:26:59)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((24
    ((379 184) (360 219) (330 239) (291 250) (247 253) (199 250)
     (165 243) (128 229) (105 209) (87 184) (76 148) (73 124)
     (76 100) (86 64) (103 37) (124 19) (163 3) (199 -4)
     (247 -7) (291 -2) (330 9) (358 30) (370 49) (379 74))
    NIL
    ((-16.644897 38.499534 0 0 -14.1306038 -20.997219 )
     (-23.710201 28.000923 -14.1306038 -20.997219 4.65302277 14.9861088 )
     (-35.514289 14.496757 -9.477581 -6.0111103 7.51851369 -2.94722366 )
     (-41.232612 7.01203538 -1.95906663 -8.95833398 -10.727083 2.80278683 )
     (-48.55522 -0.544904828 -12.686151 -6.15554715 41.389816 3.73607063 )
     (-40.546463 -4.83241654 28.70367 -2.41947651 -46.832206 -5.74706936 )
     (-35.258895 -10.125427 -18.128536 -8.16654588 43.939003 1.25220871 )
     (-31.41793 -17.665866 25.810466 -6.91433716 -26.923797 6.73823167 )
     (-19.069366 -21.21109 -1.11333346 -0.176105380 9.75619889 -22.205131 )
     (-15.3045978 -32.48976 8.64286614 -22.381237 -0.101001739 46.08229 )
     (-6.71223355 -31.829849 8.5418644 23.701057 -3.35219002 -24.124053 )
     (0.153535515 -20.190822 5.18967438 -0.422999382 1.50976372 -21.586059 )
     (6.09809209 -31.406852 6.6994381 -22.009059 3.31313324 38.468307 )
     (14.4540958 -34.181755 10.012571 16.459247 -14.762298 -6.28718758 )
     (17.0855179 -20.8661 -4.74972725 10.17206 37.73606 -13.319557 )
     (31.203823 -17.35382 32.986335 -3.14749718 -52.181953 17.565422 )
     (38.099174 -11.718605 -19.195617 14.4179268 44.99176 -14.942138 )
     (41.399444 -4.7717495 25.796146 -0.524212718 -37.78511 12.203134 )
     (48.30303 0.805606008 -11.9889679 11.6789226 10.148691 -9.8704033 )
     (41.388412 7.5493269 -1.84027552 1.80851817 -8.8096504 15.278482 )
     (35.14331 16.997085 -10.649927 17.087001 -10.910089 -27.243534 )
     (19.038337 20.462322 -21.560016 -10.156534 22.450019 21.695667 )
     (8.703331 21.153621 0.890004874 11.539133 -0.890004874 -11.539133 ))
    NATURAL)
   (2
    ((379 74) (329 74))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (20
    ((329 74) (329 64) (322 47) (298 35) (268 30) (243 29)
     (218 30) (176 36) (153 48) (135 71) (124 124) (135 177)
     (153 200) (176 212) (218 218) (243 219) (268 218) (298 213)
     (322 201) (329 184))
    NIL
    ((0.788245917 -7.8808317 0 0 -4.72947598 -12.7150058 )
     (-1.57649183 -14.238334 -4.72947598 -12.7150058 -18.352619 21.575031 )
     (-15.4822788 -16.165821 -23.082096 8.8600273 18.139965 -1.58513355 )
     (-29.494392 -8.09836198 -4.94212914 7.27489377 11.792747 -3.23450184 )
     (-28.540145 -2.4407196 6.85061837 4.04039192 0.689037323 -3.47685623 )
     (-21.345008 -0.138755947 7.53965569 0.563535691 -44.548889 5.14192868 )
     (-36.079803 2.99574423 -37.009239 5.70546437 75.50656 0.909141541 )
     (-35.335762 9.15577889 38.497322 6.6146059 -41.47737 -2.77849531 )
     (-17.577129 14.3811378 -2.98005152 3.83611059 6.4029312 40.204834 )
     (-17.3557129 38.319664 3.4228797 44.040947 27.865646 -44.040847 )
     (-8.89971852E-6 60.340187 31.288528 9.19930607E-5 -27.865531 -44.041404 )
     (17.355751 38.319572 3.42299652 -44.041313 -6.40351487 40.206466 )
     (17.576992 14.381498 -2.98051882 -3.83484268 41.47959 -2.78447056 )
     (35.336265 9.15442086 38.499076 -6.61931325 -75.514846 0.931411744 )
     (36.077919 3.00081348 -37.015777 -5.6879015 44.57981 5.05882263 )
     (21.352046 -0.157676696 7.56403638 -0.629078388 -0.804404259 -3.16670466 )
     (28.513881 -2.37010717 6.7596321 -3.79578304 -11.3621997 -4.39200688 )
     (29.592414 -8.3618946 -4.60256768 -8.1877899 -19.746788 2.73473835 )
     (15.116451 -15.1823158 -24.349357 -5.45305157 24.349357 5.45305157 ))
    NATURAL)
   (2
    ((329 184) (379 184))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 144Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  7:36:21)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((3
    ((367 337) (367 337) (367 0))
    NIL
    ((0 84.25 0 0 0 -505.5 )
     (0 -168.5 0 -505.5 0 505.5 ))
    NATURAL)
   (2
    ((367 0) (319 0))
    NIL
    ((-48. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((319 0) (319 19))
    NIL
    ((0 19. 0 0 0 0 ))
    NATURAL)
   (19
    ((319 19) (288 7) (255 -1) (217 -6) (166 -2) (134 9)
     (111 24) (94 42) (82 66) (73 124) (82 182) (94 206)
     (111 224) (134 239) (166 250) (217 254) (255 249) (288 241)
     (319 229))
    NIL
    ((-30.485801 -12.997631 0 0 -3.08518171 5.9857931 )
     (-32.028389 -10.004734 -3.08518171 5.9857931 3.42590904 -5.92896652 )
     (-33.400619 -6.98342515 0.340727687 0.0568262711 -28.618454 11.7300739 )
     (-47.369117 -1.06156063 -28.277729 11.786901 63.04792 -4.99134064 )
     (-44.122886 8.22966958 34.770195 6.79556084 -31.573257 -3.76470709 )
     (-25.13932 13.142877 3.19693613 3.03085375 3.24512148 2.05016756 )
     (-20.319824 17.198814 6.4420576 5.0810213 0.592772484 -10.4359607 )
     (-13.5813789 17.061855 7.0348301 -5.3549404 -11.616209 57.69367 )
     (-12.354654 40.553749 -4.58137989 52.338737 33.872062 -52.338737 )
     (7.97212123E-7 66.723114 29.290687 -2.04428988E-6 -33.872062 -52.33872 )
     (12.354654 40.553749 -4.58137989 -52.338729 11.616209 57.693664 )
     (13.5813789 17.061855 7.03482915 5.3549385 -0.592770577 -10.4359588 )
     (20.319824 17.198814 6.44205857 -5.08102036 -3.24512196 2.05016661 )
     (25.13932 13.142877 3.1969366 -3.03085375 31.573257 -3.76470709 )
     (44.122886 8.22966958 34.770195 -6.79556084 -63.04792 -4.99134064 )
     (47.369117 -1.06156182 -28.277729 -11.786901 28.618454 11.7300739 )
     (33.400619 -6.98342515 0.340728342 -0.0568258986 -3.42591 -5.92896652 )
     (32.028389 -10.004734 -3.08518171 -5.9857931 3.08518171 5.9857931 ))
    NATURAL)
   (2
    ((319 229) (319 337))
    NIL
    ((0 108. 0 0 0 0 ))
    NATURAL)
   (2
    ((319 337) (367 337))
    NIL
    ((48. 0 0 0 0 0 ))
    NATURAL))

  ((21
    ((125 124) (128 86) (140 53) (166 34) (195 28) (220 25)
     (248 28) (275 34) (300 53) (312 86) (315 124) (312 162)
     (300 195) (275 214) (240 220) (220 221) (200 220) (166 214)
     (140 195) (128 162) (125 124))
    NIL
    ((1.51067447 -38.577346 0 0 8.93595315 3.46408939 )
     (5.97865105 -36.845298 8.93595315 3.46408939 9.32023049 12.679552 )
     (19.574718 -27.041435 18.256183 16.143642 -16.216877 -0.182313919 )
     (29.722465 -10.9889488 2.03930521 15.961328 -10.452711 -17.950286 )
     (26.535415 -4.0027647 -8.41340638 -1.98896122 16.027721 11.9834747 )
     (26.135868 1.15633010E-5 7.6143179 9.99451448 -11.658184 -11.983612 )
     (27.921096 4.00271988 -4.04386616 -1.98909831 6.60501576 17.950973 )
     (27.179737 10.989109 2.5611496 15.9618759 -20.761878 0.179710388 )
     (19.359943 27.04084 -18.200729 16.141586 10.4425125 -12.669805 )
     (6.38047219 36.847518 -7.75821686 3.47177982 2.99181557 -3.50048733 )
     (0.118163108 38.569053 -4.76640129 -0.0287075825 -4.40977478 -3.32824135 )
     (-6.85312558 36.876228 -9.17617608 -3.35694933 -3.35271454 -13.186544 )
     (-17.705661 26.926006 -12.5288906 -16.543495 -6.17935753 2.07443428 )
     (-33.324226 11.419729 -18.708248 -14.4690609 46.070129 10.8888015 )
     (-28.997413 2.39507007 27.36188 -3.58025837 -28.10115 2.3703537 )
     (-15.686109 -1.16033479E-5 -0.739272595 -1.20990467 -23.665515 -2.37021637 )
     (-28.25814 -2.3950243 -24.404789 -3.58012104 38.763206 -10.889488 )
     (-33.281318 -11.419889 14.358423 -14.46961 0.612663269 -2.07182503 )
     (-18.616565 -26.92541 14.971086 -16.541435 -5.21385956 13.176794 )
     (-6.25240899 -36.878448 9.75722695 -3.36464119 -9.75722695 3.36464119 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 145Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  7:44:36)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((10
    ((114 106) (121 71) (140 47) (162 36) (198 28) (232 26)
     (262 30) (290 38) (310 55) (317 74))
    NIL
    ((3.72561359 -37.048507 0 0 19.646316 12.291084 )
     (13.5487728 -30.902969 19.646316 12.291084 -26.23159 4.54457855 )
     (20.079292 -16.3395958 -6.5852747 16.8356628 31.280056 -18.469402 )
     (29.134048 -8.738636 24.694782 -1.63374018 -32.88864 9.3330364 )
     (37.384506 -5.70585728 -8.1938591 7.69929696 4.27451039 -0.862744332 )
     (31.327903 1.56206679 -3.91934872 6.8365526 3.79060364 -5.88205815 )
     (29.303859 5.4575901 -0.128744781 0.954493762 -7.43692494 12.390974 )
     (25.456649 12.6075706 -7.56567 13.345468 -10.0429077 -13.681835 )
     (12.8695259 19.112121 -17.608577 -0.336367309 17.608577 0.336367309 ))
    NATURAL)
   (2
    ((317 74) (367 74))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (26
    ((367 74) (358 49) (346 30) (318 9) (279 -2) (235 -7)
     (187 -4) (151 3) (120 17) (92 38) (74 63) (64 90)
     (61 124) (64 148) (75 184) (92 210) (116 229) (153 245)
     (188 252) (235 253) (276 248) (315 237) (345 217) (365 189)
     (375 153) (376 106))
    NIL
    ((-9.14956666 -26.922843 0 0 0.897400857 11.5370788 )
     (-8.7008648 -21.154304 0.897400857 11.5370788 -22.487003 -21.685394 )
     (-19.046966 -20.459922 -21.589603 -10.148315 11.0506248 27.204502 )
     (-35.111259 -17.005985 -10.5389785 17.056186 8.28450204 -15.132629 )
     (-41.507988 -7.51611615 -2.25447607 1.92355561 -8.18863679 9.3260288 )
     (-47.85678 -0.929544092 -10.443113 11.249586 30.470039 -10.1714935 )
     (-43.064872 5.23429489 20.026927 1.07809257 -17.691524 7.3599491 )
     (-31.883708 9.99236299 2.33540249 8.4380417 -1.70394110 -1.26830482 )
     (-30.400276 17.796249 0.631461263 7.16973687 12.5072899 -2.28672886 )
     (-23.51517 23.822624 13.138752 4.883008 -6.32522488 -7.5847759 )
     (-13.53903 24.913242 6.8135271 -2.7017684 0.793606759 20.625831 )
     (-6.3286991 32.52439 7.60713387 17.924064 -2.84920406 -44.918556 )
     (-0.146167755 27.989177 4.7579298 -26.994491 4.60321713 57.048393 )
     (6.91337014 29.518886 9.3611469 30.053905 -3.56366348 -51.275047 )
     (14.492685 33.935264 5.79748345 -21.221145 -2.34856748 16.051834 )
     (19.115882 20.740036 3.44891596 -5.16931153 18.957935 5.067708 )
     (32.043769 18.1045799 22.406852 -0.101603269 -37.483184 -12.32267 )
     (35.70903 11.84164 -15.0763359 -12.424274 40.974823 8.22297288 )
     (41.1201 3.52885342 25.89849 -4.20130062 -42.416122 -2.56921959 )
     (45.81053 -1.957057 -16.517631 -6.7705202 20.689662 2.05390358 )
     (39.637733 -7.7006254 4.17203236 -4.71661663 -16.342529 -5.64639378 )
     (35.638504 -15.24044 -12.1704979 -10.36301 2.68045235 2.53167534 )
     (24.808235 -24.337612 -9.49004556 -7.83133507 -0.379274368 1.51969146 )
     (15.128551 -31.409103 -9.8693199 -6.3116436 -1.16334915 -8.610445 )
     (4.67755604 -42.02597 -11.032669 -14.922088 11.032669 14.922088 ))
    NATURAL)
   (2
    ((376 106) (114 106))
    NIL
    ((-262. 0 0 0 0 0 ))
    NATURAL))

  ((13
    ((111 148) (115 173) (128 195) (142 206) (164 215) (199 220)
     (219 221) (239 220) (273 215) (296 206) (309 195) (323 173)
     (327 148))
    NIL
    ((1.59247875 25.037006 0 0 14.445127 -0.222058296 )
     (8.8150425 24.925979 14.445127 -0.222058296 -18.225643 -16.889705 )
     (14.147348 16.259063 -3.78051567 -17.111766 10.4574489 19.780899 )
     (15.595558 9.03774835 6.67693425 2.66913366 18.395839 -8.23390008 )
     (31.470413 7.58993245 25.072776 -5.56476689 -54.040817 1.15470123 )
     (29.522777 2.60251617 -28.968044 -4.41006565 29.767448 3.61509848 )
     (15.438461 -1.19209289E-7 0.799406291 -0.794966818 24.971008 -3.61509848 )
     (28.723369 -2.60251665 25.770416 -4.41006565 -45.65148 -1.15470123 )
     (31.668045 -7.58993245 -19.881069 -5.56476689 7.63492776 8.23390008 )
     (15.60444 -9.03774835 -12.246141 2.66913366 21.111778 -19.780899 )
     (13.914188 -16.259067 8.8656368 -17.111766 -26.082042 16.889705 )
     (9.73880197 -24.925979 -17.216407 -0.222057551 17.216407 0.222057551 ))
    NATURAL)
   (2
    ((327 148) (111 148))
    NIL
    ((-216. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 146Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  7:51:03)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((156 0) (156 210))
    NIL
    ((0 210. 0 0 0 0 ))
    NATURAL)
   (2
    ((156 210) (60 210))
    NIL
    ((-96. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((60 210) (60 246))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((60 246) (156 246))
    NIL
    ((96. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((156 246) (156 292))
    NIL
    ((0 46. 0 0 0 0 ))
    NATURAL)
   (10
    ((156 292) (165 316) (189 333) (215 341) (243 345) (278 346)
     (315 342) (348 331) (369 315) (378 292))
    NIL
    ((5.11860848 25.295597 0 0 23.288345 -7.7735853 )
     (16.762779 21.408802 23.288345 -7.7735853 -26.441726 -3.1320734 )
     (26.83026 12.069181 -3.15338469 -10.9056587 4.47857857 8.3018837 )
     (25.916164 5.31446457 1.32519412 -2.60377359 8.5274124 -0.0754714012 )
     (31.505065 2.67295551 9.8526077 -2.67924499 -8.58823396 -1.99999904 )
     (37.063552 -1.00628972 1.26437258 -4.67924404 -4.17447186 -3.92452908 )
     (36.240692 -7.64779854 -2.9100995 -8.6037731 -10.713871 5.69811249 )
     (27.973655 -13.402515 -13.6239719 -2.90566063 -0.970033646 -6.86792374 )
     (13.8646679 -19.742137 -14.594005 -9.77358438 14.594005 9.77358438 ))
    NATURAL)
   (2
    ((378 292) (378 272))
    NIL
    ((0 -20. 0 0 0 0 ))
    NATURAL)
   (2
    ((378 272) (337 272))
    NIL
    ((-41. 0 0 0 0 0 ))
    NATURAL)
   (8
    ((337 272) (331 295) (319 305) (300 311) (273 313) (245 310)
     (219 299) (209 283))
    NIL
    ((-4.74338722 26.25661 0 0 -7.53967667 -19.539676 )
     (-8.51322557 16.48677 -7.53967667 -19.539676 1.69838524 19.698383 )
     (-15.203708 6.79628945 -5.84129143 0.158708185 -5.25386429 -5.25386334 )
     (-23.671932 4.32806492 -11.0951557 -5.0951557 13.3170719 1.31707239 )
     (-28.10855 -0.108553722 2.22191667 -3.77808333 -6.01442719 -6.01442719 )
     (-28.893848 -6.89385033 -3.7925105 -9.792511 28.74063 4.74063969 )
     (-18.31604 -14.3160419 24.948123 -5.0518713 -24.948123 5.0518713 ))
    NATURAL)
   (2
    ((209 283) (209 246))
    NIL
    ((0 -37. 0 0 0 0 ))
    NATURAL)
   (2
    ((209 246) (313 246))
    NIL
    ((104. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((313 246) (313 210))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL)
   (2
    ((313 210) (209 210))
    NIL
    ((-104. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((209 210) (209 0))
    NIL
    ((0 -210. 0 0 0 0 ))
    NATURAL)
   (2
    ((209 0) (156 0))
    NIL
    ((-53. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 147Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  8:11:15)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((11
    ((367 -36) (360 -58) (339 -81) (316 -96) (276 -109) (223 -113)
     (171 -109) (130 -96) (106 -81) (87 -58) (79 -36))
    NIL
    ((-3.1312089 -21.157455 0 0 -23.212745 -5.05524826 )
     (-14.737581 -23.685081 -23.212745 -5.05524826 32.063728 19.276241 )
     (-21.91846 -19.102207 8.85098649 14.220993 -33.042182 -18.04972 )
     (-29.588569 -13.906076 -24.1912 -3.82872963 10.105022 16.922653 )
     (-48.727256 -9.27347947 -14.0861778 13.093923 16.622085 -7.6408863 )
     (-54.502388 6.37024641E-7 2.53591108 5.45303726 7.4066181 7.6408844 )
     (-48.263168 9.27347947 9.94252969 13.0939216 13.751432 -16.922649 )
     (-31.444919 13.906076 23.693962 -3.82872915 -26.412349 18.04972 )
     (-20.957134 19.102207 -2.71838999 14.220993 19.897983 -19.276241 )
     (-13.726532 23.685081 17.1795959 -5.05524826 -17.1795959 5.05524826 ))
    NATURAL)
   (2
    ((79 -36) (134 -36))
    NIL
    ((55. 0 0 0 0 0 ))
    NATURAL)
   (8
    ((134 -36) (157 -66) (188 -78) (215 -81) (238 -81) (278 -72)
     (310 -53) (319 -26))
    NIL
    ((20.736858 -34.19924 0 0 13.578838 25.195465 )
     (27.526279 -21.601509 13.578838 25.195465 -19.894191 -17.977325 )
     (31.15802 -5.39470959 -6.3153553 7.21813775 -6.00206185 -7.28615475 )
     (21.841632 -1.81964922 -12.317417 -0.0680177510 43.902435 11.121948 )
     (31.475437 3.67330837 31.585022 11.053932 -43.607688 -1.20164871 )
     (41.256607 14.126417 -12.0226726 9.85228349 -19.471656 -0.315355301 )
     (19.498107 23.821022 -31.49433 9.53692819 31.49433 -9.53692819 ))
    NATURAL)
   (2
    ((319 -26) (319 19))
    NIL
    ((0 45. 0 0 0 0 ))
    NATURAL)
   (19
    ((319 19) (294 10) (255 -1) (217 -6) (166 -2) (134 9)
     (111 24) (94 42) (78 78) (73 124) (77 160) (88 196)
     (111 224) (134 239) (166 250) (217 254) (263 249) (297 238)
     (319 229))
    NIL
    ((-20.838954 -8.1762371 0 0 -24.966262 -4.94256687 )
     (-33.322082 -10.6475219 -24.966262 -4.94256687 40.83132 12.712835 )
     (-37.872688 -9.2336712 15.865064 7.77026845 -48.359054 2.09122372 )
     (-46.187156 -0.417790532 -32.493995 9.86149217 68.604934 -3.07773304 )
     (-44.378677 7.9048357 36.110939 6.7837591 -34.060707 -1.78029155 )
     (-25.298099 13.798448 2.05022669 5.00346756 7.6379194 -7.8010969 )
     (-19.428913 14.901367 9.6881466 -2.79762983 -14.490961 26.984676 )
     (-16.986244 25.596077 -4.80281449 24.187049 20.325923 -10.1376247 )
     (-11.6260967 44.714317 15.523111 14.049425 -6.81274796 -34.43418 )
     (0.490640223 41.546646 8.7103634 -20.384758 -5.07493115 27.874359 )
     (6.66353799 35.099075 3.63543177 7.489604 15.112472 -17.0632629 )
     (17.855205 34.057045 18.747905 -9.5736599 -25.374961 -7.62130547 )
     (23.91563 20.672733 -6.62705899 -17.194965 14.387386 17.548488 )
     (24.482265 12.252012 7.7603283 0.353523433 21.825416 -8.572649 )
     (43.155304 8.31921006 29.585746 -8.21912576 -41.68907 -1.25789261 )
     (51.896514 -0.528861285 -12.1033249 -9.47701837 0.930879594 1.60422325 )
     (40.258628 -9.20376779 -11.172445 -7.8727951 -4.0344429 12.8409939 )
     (27.068962 -10.656065 -15.206888 4.96819878 15.206888 -4.96819878 ))
    NATURAL)
   (2
    ((319 229) (319 246))
    NIL
    ((0 17. 0 0 0 0 ))
    NATURAL)
   (2
    ((319 246) (367 246))
    NIL
    ((48. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((367 246) (367 -36))
    NIL
    ((0 -282. 0 0 0 0 ))
    NATURAL))

  ((11
    ((315 124) (312 86) (300 53) (275 34) (240 28) (220 26)
     (200 28) (166 34) (140 53) (128 86) (125 124))
    NIL
    ((-1.25777840 -38.569053 0 0 -10.453329 3.41436482 )
     (-6.4844427 -36.861877 -10.453329 3.41436482 -1.73335266 12.9281749 )
     (-17.804447 -26.983425 -12.1866817 16.34254 -6.61325646 -1.12707138 )
     (-33.29776 -11.204418 -18.799938 15.215469 46.186386 -14.419889 )
     (-29.004505 -3.1988945 27.386447 0.795579792 -28.1323 4.80662918 )
     (-15.6842098 4.17232513E-7 -0.745856881 5.60220909 -23.657165 -4.80662918 )
     (-28.258647 3.19889498 -24.403022 0.795579315 38.76097 14.419889 )
     (-33.28118 11.20442 14.357952 15.215469 0.613256455 1.12706756 )
     (-18.6166 26.983425 14.971208 16.3425369 -5.21401215 -12.928171 )
     (-6.2523985 36.861877 9.7571964 3.41436482 -9.7571964 -3.41436482 ))
    NATURAL)
   (11
    ((125 124) (128 162) (140 195) (166 214) (200 220) (220 222)
     (240 220) (275 214) (300 195) (312 162) (315 124))
    NIL
    ((1.37380051 38.569053 0 0 9.7571964 -3.41436482 )
     (6.2523985 36.861877 9.7571964 -3.41436482 5.21401596 -12.9281749 )
     (18.616603 26.983425 14.971212 -16.34254 -0.613260269 1.12707138 )
     (33.28118 11.204418 14.357952 -15.215469 -38.76097 14.419889 )
     (28.258647 3.1988945 -24.403022 -0.795579792 23.657165 -4.80662918 )
     (15.6842098 -4.17232513E-7 -0.745855928 -5.60220909 28.1323 4.80662918 )
     (29.004505 -3.19889498 27.386447 -0.795579315 -46.186386 -14.419889 )
     (33.29776 -11.20442 -18.799942 -15.215469 6.61326218 -1.12706756 )
     (17.804447 -26.983425 -12.1866798 -16.3425369 1.73335075 12.928171 )
     (6.4844427 -36.861877 -10.453329 -3.41436482 10.453329 3.41436482 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 150Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  8:17:17)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((3
    ((81 0) (81 0) (81 337))
    NIL
    ((0 -84.25 0 0 0 505.5 )
     (0 168.5 0 505.5 0 -505.5 ))
    NATURAL)
   (2
    ((81 337) (132 337))
    NIL
    ((51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((132 337) (132 221))
    NIL
    ((0 -116. 0 0 0 0 ))
    NATURAL)
   (11
    ((132 221) (159 239) (190 249) (215 254) (244 256) (273 253)
     (301 245) (321 236) (336 224) (348 208) (355 187))
    NIL
    ((25.419338 19.823307 0 0 9.48395349 -10.939859 )
     (30.161315 14.353378 9.48395349 -10.939859 -23.419769 6.69930363 )
     (27.935386 6.76317025 -13.9358158 -4.24055577 24.195125 2.14264202 )
     (26.097133 3.59393549 10.2593097 -2.09791374 -13.3607387 -3.26987267 )
     (29.676075 -0.138914734 -3.10142994 -5.3677864 5.24783802 -1.06315231 )
     (29.198562 -6.03827763 2.14640856 -6.4309387 -13.630613 7.5224819 )
     (24.529663 -8.7079754 -11.484205 1.09154343 7.27461815 -5.02677727 )
     (16.6827659 -10.1298198 -4.2095871 -3.93523455 2.53214359 0.584630490 )
     (13.739254 -13.772739 -1.67744326 -3.35060406 -5.40319538 -3.31174469 )
     (9.3602123 -18.779216 -7.08063889 -6.66234875 7.08063889 6.66234875 ))
    NATURAL)
   (2
    ((355 187) (357 0))
    NIL
    ((2. -187. 0 0 0 0 ))
    NATURAL)
   (2
    ((357 0) (308 0))
    NIL
    ((-49. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((308 0) (308 166))
    NIL
    ((0 166. 0 0 0 0 ))
    NATURAL)
   (9
    ((308 166) (302 195) (283 213) (255 220) (232 221) (202 218)
     (168 211) (142 191) (132 166))
    NIL
    ((-3.2881074 31.25368 0 0 -16.271354 -13.5220909 )
     (-11.423784 24.492633 -16.271354 -13.5220909 3.35677528 1.61045646 )
     (-26.01675 11.775772 -12.914579 -11.911634 26.844253 7.08026505 )
     (-25.5092 3.40427065 13.929674 -4.8313694 -26.733795 0.0684823990 )
     (-24.946426 -1.39285707 -12.8041229 -4.762887 8.09094239 4.64580345 )
     (-33.705078 -3.83284283 -4.71318054 -0.117083445 12.370027 -18.651691 )
     (-32.233245 -13.275772 7.65684796 -18.7687759 14.4289398 15.9609699 )
     (-17.361927 -24.064064 22.085788 -2.80780554 -22.085788 2.80780554 ))
    NATURAL)
   (2
    ((132 166) (132 0))
    NIL
    ((0 -166. 0 0 0 0 ))
    NATURAL)
   (2
    ((132 0) (81 0))
    NIL
    ((-51. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 151Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  8:21:40)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((254 210) (254 0))
    NIL
    ((0 -210. 0 0 0 0 ))
    NATURAL)
   (2
    ((254 0) (304 0))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((304 0) (304 246))
    NIL
    ((0 246. 0 0 0 0 ))
    NATURAL)
   (2
    ((304 246) (115 246))
    NIL
    ((-189. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((115 246) (115 210))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL)
   (2
    ((115 210) (254 210))
    NIL
    ((139. 0 0 0 0 0 ))
    NATURAL))

  ((13
    ((236 313) (240 329) (251 339) (275 345) (299 339) (310 329)
     (314 313) (310 297) (299 287) (275 281) (251 287) (240 297)
     (236 313))
    NIL
    ((2.99777937 17.538459 0 0 6.01332379 -9.2307682 )
     (6.00444127 12.9230766 6.01332379 -9.2307682 11.93338 10.1538429 )
     (17.984455 8.7692299 17.946704 0.923076273 -17.7468529 -19.384609 )
     (27.057731 -6.96629285E-7 0.199850619 -18.461536 -18.945957 19.384613 )
     (17.784599 -8.7692299 -18.746109 0.923076988 15.530712 -10.1538448 )
     (6.80384827 -12.9230766 -3.21539688 -9.2307682 -7.17690278 9.2307682 )
     (-7.15255737E-7 -17.538459 -10.3922996 0 7.17690278 9.2307682 )
     (-6.80384827 -12.9230747 -3.2153964 9.2307682 -15.5307159 -10.1538448 )
     (-17.784603 -8.7692299 -18.746112 -0.923076749 18.945961 19.384613 )
     (-27.057731 6.96629285E-7 0.199851840 18.461536 17.7468529 -19.384613 )
     (-17.984455 8.7692299 17.946704 -0.923076988 -11.93338 10.1538448 )
     (-6.00444127 12.9230766 6.01332379 9.2307682 -6.01332379 -9.2307682 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 152Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  8:27:59)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((275 -33) (275 210))
    NIL
    ((0 243. 0 0 0 0 ))
    NATURAL)
   (2
    ((275 210) (136 210))
    NIL
    ((-139. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((136 210) (136 246))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((136 246) (325 246))
    NIL
    ((189. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((325 246) (325 -32))
    NIL
    ((0 -278. 0 0 0 0 ))
    NATURAL)
   (13
    ((325 -32) (321 -50) (312 -67) (298 -83) (279 -97) (250 -107)
     (193 -113) (136 -107) (108 -97) (88 -83) (75 -67) (66 -50)
     (61 -34))
    NIL
    ((-2.93862963 -18.215393 0 0 -6.36822224 1.29237032 )
     (-6.12274075 -17.569206 -6.36822224 1.29237032 1.84111404 -0.461851597 )
     (-11.5704059 -16.5077629 -4.52710819 0.830518723 -0.996235848 0.555036068 )
     (-16.59563 -15.3997268 -5.52334404 1.38555479 2.14382934 4.2417059 )
     (-21.047061 -11.89332 -3.37951469 5.62726116 -37.579078 -5.52186203 )
     (-43.216117 -9.02698899 -40.958595 0.105398297 40.172508 17.845745 )
     (-64.088455 0.00128283351 -0.786086679 17.951145 44.889015 -17.861129 )
     (-42.43003 9.021862 44.102935 0.0900126547 -45.728599 5.5987873 )
     (-21.191398 11.911268 -1.62566781 5.6888008 12.0254 -4.5340147 )
     (-16.804367 15.333061 10.3997326 1.15478539 -8.37299348 0.537271738 )
     (-10.591131 16.756481 2.02673769 1.69205713 3.466578 -3.6150713 )
     (-6.83110524 16.641002 5.4933157 -1.92301416 -5.4933157 1.92301416 ))
    NATURAL)
   (2
    ((61 -34) (111 -33))
    NIL
    ((50. 1. 0 0 0 0 ))
    NATURAL)
   (9
    ((111 -33) (120 -56) (145 -71) (170 -75) (193 -77) (216 -75)
     (241 -71) (266 -56) (275 -33))
    NIL
    ((4.75 -24.371131 0 0 25.5 8.2268028 )
     (17.5 -20.257728 25.5 8.2268028 -31.5 6.86598015 )
     (27.249996 -8.59793664 -6. 15.0927829 4.5 -17.690719 )
     (23.499996 -2.35051536 -1.49999976 -2.59793806 1.49999952 9.8969059 )
     (22.75 -1.58324837E-7 -6.38824957E-8 7.29896927 1.5 -9.8969059 )
     (23.5 2.35051536 1.5 -2.59793758 4.49999905 17.690715 )
     (27.249996 8.59793855 5.99999905 15.092781 -31.499992 -6.86597634 )
     (17.499996 20.257728 -25.499996 8.22680474 25.499996 -8.22680474 ))
    NATURAL))

  ((13
    ((296 345) (272 339) (261 329) (257 313) (261 297) (272 287)
     (296 281) (320 287) (331 297) (335 313) (331 329) (320 339)
     (296 345))
    NIL
    ((-27.115383 -5.32938576 0 0 18.692306 -4.02368546 )
     (-17.7692299 -7.34122849 18.692306 -4.02368546 -15.461536 -3.88156986 )
     (-6.80769158 -13.305698 3.23076916 -7.9052553 7.15384579 7.549963 )
     (2.38418579E-7 -17.43597 10.3846149 -0.355292022 -7.15384579 9.681715 )
     (6.80769253 -12.950405 3.23076868 9.32642365 15.461536 -10.2768306 )
     (17.7692299 -8.76239778 18.692306 -0.950407744 -18.692306 19.425609 )
     (27.115383 -2.57045030E-7 0 18.475204 -18.692306 -19.425609 )
     (17.7692299 8.76239778 -18.692306 -0.950407386 15.461538 10.2768306 )
     (6.80769158 12.950407 -3.2307682 9.32642365 -7.15384675 -9.681715 )
     (-2.38418579E-7 17.43597 -10.3846149 -0.355291724 7.15384579 -7.549963 )
     (-6.80769253 13.305698 -3.23076868 -7.9052553 -15.461536 3.88156986 )
     (-17.7692299 7.34122849 -18.692306 -4.02368546 18.692306 4.02368546 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 153Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  8:32:02)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((73 0) (73 337))
    NIL
    ((0 337. 0 0 0 0 ))
    NATURAL)
   (2
    ((73 337) (120 337))
    NIL
    ((47. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((120 337) (120 157))
    NIL
    ((0 -180. 0 0 0 0 ))
    NATURAL)
   (2
    ((120 157) (165 157))
    NIL
    ((45. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((165 157) (293 246))
    NIL
    ((128. 89. 0 0 0 0 ))
    NATURAL)
   (2
    ((293 246) (360 246))
    NIL
    ((67. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((360 246) (199 136))
    NIL
    ((-161. -110. 0 0 0 0 ))
    NATURAL)
   (2
    ((199 136) (405 0))
    NIL
    ((206. -136. 0 0 0 0 ))
    NATURAL)
   (2
    ((405 0) (333 0))
    NIL
    ((-72. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((333 0) (165 110))
    NIL
    ((-168. 110. 0 0 0 0 ))
    NATURAL)
   (2
    ((165 110) (120 110))
    NIL
    ((-45. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((120 110) (120 0))
    NIL
    ((0 -110. 0 0 0 0 ))
    NATURAL)
   (2
    ((120 0) (73 0))
    NIL
    ((-47. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 154Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  8:32:50)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((232 0) (232 301))
    NIL
    ((0 301. 0 0 0 0 ))
    NATURAL)
   (2
    ((232 301) (94 301))
    NIL
    ((-138. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((94 301) (94 337))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((94 337) (283 337))
    NIL
    ((189. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((283 337) (283 0))
    NIL
    ((0 -337. 0 0 0 0 ))
    NATURAL)
   (2
    ((283 0) (232 0))
    NIL
    ((-51. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 155Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  8:39:05)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((31 0) (31 246))
    NIL
    ((0 246. 0 0 0 0 ))
    NATURAL)
   (2
    ((31 246) (78 246))
    NIL
    ((47. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((78 246) (78 227))
    NIL
    ((0 -19. 0 0 0 0 ))
    NATURAL)
   (9
    ((78 227) (88 237) (100 244) (117 250) (153 254) (178 254)
     (205 250) (225 244) (241 232))
    NIL
    ((9.3958931 10.755245 0 0 3.62463093 -4.53147984 )
     (11.20821 8.48950578 3.62463093 -4.53147984 -6.1231556 4.65740013 )
     (11.771263 6.286726 -2.49852466 0.125920355 38.867988 -2.09812164 )
     (28.706737 5.36358547 36.369468 -1.97220134 -65.348846 -2.26491165 )
     (32.401779 2.2589283 -28.979377 -4.237113 42.52742 -0.842230797 )
     (24.686119 -2.39930057 13.548048 -5.0793438 -26.76086 5.63383484 )
     (24.853736 -4.661726 -13.212812 0.554491878 10.516016 -9.6931133 )
     (16.898929 -8.95379258 -2.69679642 -9.13862229 2.69679642 9.13862229 ))
    NATURAL)
   (10
    ((241 232) (256 241) (274 248) (294 253) (322 255) (358 250)
     (381 242) (394 231) (403 220) (409 200))
    NIL
    ((14.241657 9.41674615 0 0 4.5500555 -2.50048065 )
     (16.516681 8.1665058 4.5500555 -2.50048065 -4.75027752 0.502404452 )
     (18.6916 5.91722679 -0.200222254 -1.9980762 8.4510555 0.490862370 )
     (22.716903 4.16458225 8.2508335 -1.50721383 6.94605637 -8.46585084 )
     (34.440765 -1.57555818 15.1968898 -9.9730663 -36.235282 9.37254716 )
     (31.520011 -6.86235047 -21.038398 -0.600517631 11.995113 -5.02434349 )
     (16.4791679 -9.9750385 -9.04328538 -5.6248617 6.25482846 10.7248249 )
     (10.563299 -10.2374878 -2.78845692 5.09996319 -1.01442861 -19.87495 )
     (7.2676277 -15.075002 -3.80288553 -14.77499 3.80288553 14.77499 ))
    NATURAL)
   (2
    ((409 200) (409 0))
    NIL
    ((0 -200. 0 0 0 0 ))
    NATURAL)
   (2
    ((409 0) (359 0))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((359 0) (359 190))
    NIL
    ((0 190. 0 0 0 0 ))
    NATURAL)
   (9
    ((359 190) (355 206) (341 215) (319 219) (294 219) (271 214)
     (258 205) (252 190) (250 174))
    NIL
    ((-1.83845734 17.571243 0 0 -12.969255 -9.42746545 )
     (-8.32308579 12.857509 -12.969255 -9.42746545 4.84628105 5.1373329 )
     (-18.869197 5.99871063 -8.1229744 -4.29013253 5.58413029 0.878129960 )
     (-24.200107 2.14764309 -2.53884363 -3.41200256 2.81719446 -2.64985275 )
     (-25.330356 -2.58928585 0.278350830 -6.0618553 13.147089 3.72128105 )
     (-18.478458 -6.79050065 13.4254398 -2.34057426 -7.40555764 -6.23527337 )
     (-8.75579835 -12.2487106 6.0198822 -8.5758476 -1.52485275 9.21980859 )
     (-3.49834299 -16.214653 4.49502945 0.643961907 -4.49502945 -0.643961907 ))
    NATURAL)
   (2
    ((250 174) (250 0))
    NIL
    ((0 -174. 0 0 0 0 ))
    NATURAL)
   (2
    ((250 0) (201 0))
    NIL
    ((-49. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((201 0) (201 190))
    NIL
    ((0 190. 0 0 0 0 ))
    NATURAL)
   (10
    ((201 190) (197 206) (183 215) (161 219) (142 220) (122 218)
     (99 214) (86 205) (80 190) (78 174))
    NIL
    ((-1.95049953 17.560386 0 0 -12.2970028 -9.3623371 )
     (-8.09900094 12.879219 -12.2970028 -9.3623371 1.48501777 4.81169033 )
     (-19.653495 5.92272759 -10.811985 -4.55064678 18.356933 2.11557484 )
     (-21.287014 2.42986774 7.54494954 -2.43507194 -8.9127617 -1.27399206 )
     (-18.198444 -0.642200113 -1.36781311 -3.709064 -6.70588303 2.98039245 )
     (-22.9192 -2.86106777 -8.07369615 -0.728671313 23.736293 -4.64757633 )
     (-19.124748 -5.91352749 15.662597 -5.37624836 -10.23929 -2.39008522 )
     (-8.58179666 -12.484817 5.42330647 -7.76633359 -0.779133797 8.20791627 )
     (-3.54805756 -16.1471939 4.64417267 0.441583455 -4.64417267 -0.441583455 ))
    NATURAL)
   (2
    ((78 174) (78 0))
    NIL
    ((0 -174. 0 0 0 0 ))
    NATURAL)
   (2
    ((78 0) (31 0))
    NIL
    ((-47. 0 0 0 0 0 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/GACHAE.LC2-SF b/obsolete/lispusers/splinefonts/GACHAE.LC2-SF
deleted file mode 100644
index 2b113cd5..00000000
--- a/obsolete/lispusers/splinefonts/GACHAE.LC2-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY gacha)
 (CHARACTER 156Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  9:03:06)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((3
    ((81 0) (81 0) (81 246))
    NIL
    ((0 -61.5 0 0 0 369. )
     (0 123. 0 369. 0 -369. ))
    NATURAL)
   (2
    ((81 246) (132 246))
    NIL
    ((51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((132 246) (132 231))
    NIL
    ((0 -15. 0 0 0 0 ))
    NATURAL)
   (12
    ((132 231) (146 239) (165 247) (188 252) (219 255) (244 255)
     (273 253) (301 245) (321 236) (336 224) (348 208) (355 187))
    NIL
    ((12.757387 7.8082018 0 0 7.45567608 1.15078807 )
     (16.4852218 8.3835945 7.45567608 1.15078807 -7.2783804 -5.75393963 )
     (20.301708 6.65741254 0.177295416 -4.60315228 15.657846 3.86497593 )
     (28.30793 3.9867487 15.835142 -0.738176108 -31.353008 -3.705966 )
     (28.466568 1.39558935 -15.517866 -4.44414234 25.754188 4.95888996 )
     (25.825794 -0.569107771 10.236322 0.514747978 -11.6637478 -10.1295967 )
     (30.230243 -5.11915779 -1.42742538 -9.6148491 -9.09919549 11.5594978 )
     (24.253219 -8.95425797 -10.5266208 1.94464874 6.0605383 -6.10839368 )
     (16.756866 -10.0638065 -4.46608258 -4.16374493 2.85703802 0.874077321 )
     (13.719303 -13.790512 -1.60904455 -3.2896676 -5.48869324 -3.38791514 )
     (9.36591149 -18.774135 -7.09773827 -6.67758275 7.09773827 6.67758275 ))
    NATURAL)
   (2
    ((355 187) (357 0))
    NIL
    ((2. -187. 0 0 0 0 ))
    NATURAL)
   (2
    ((357 0) (308 0))
    NIL
    ((-49. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((308 0) (308 176))
    NIL
    ((0 176. 0 0 0 0 ))
    NATURAL)
   (11
    ((308 176) (307 191) (295 205) (275 215) (247 219) (223 220)
     (197 219) (168 215) (149 205) (137 191) (132 176))
    NIL
    ((1.54838872 15.082872 0 0 -15.2903328 -0.497237682 )
     (-6.09677697 14.834253 -15.2903328 -0.497237682 10.4516639 -3.51381159 )
     (-16.161277 12.5801086 -4.83866883 -4.01104927 -8.5163231 -3.44751453 )
     (-25.258106 6.84530354 -13.3549919 -7.4585638 23.613628 5.30386734 )
     (-26.806285 2.03867388 10.258636 -2.15469599 -13.938192 0.232043981 )
     (-23.516746 -7.96280801E-8 -3.67955732 -1.922652 -3.86084795 -0.232043504 )
     (-29.126728 -2.03867388 -7.54040528 -2.15469551 23.381584 -5.3038683 )
     (-24.976337 -6.84530354 15.8411789 -7.4585638 -11.665493 3.44751453 )
     (-14.9679069 -12.58011 4.17568493 -4.01104927 5.28039456 3.51381159 )
     (-8.1520252 -14.834253 9.45607949 -0.497237623 -9.45607949 0.497237623 ))
    NATURAL)
   (2
    ((132 176) (132 0))
    NIL
    ((0 -176. 0 0 0 0 ))
    NATURAL)
   (2
    ((132 0) (81 0))
    NIL
    ((-51. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 157Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  9:07:04)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((29
    ((220 253) (184 250) (150 243) (111 227) (90 209) (72 184)
     (61 148) (58 124) (61 100) (72 64) (90 39) (111 21)
     (148 3) (184 -4) (220 -7) (256 -4) (292 3) (330 21)
     (351 39) (369 64) (379 100) (382 124) (379 148) (369 184)
     (351 209) (330 227) (291 243) (256 250) (220 253))
    NIL
    ((-37.23284 -2.5527296 0 0 7.3970537 -2.68362236 )
     (-33.534309 -3.89454079 7.3970537 -2.68362236 -24.985267 -10.581888 )
     (-38.629898 -11.869106 -17.5882149 -13.26551 50.544029 15.0111789 )
     (-30.94609 -17.629028 32.955818 1.74566984 -39.190887 -7.4628372 )
     (-17.58572 -19.614776 -6.23507023 -5.71716786 16.219528 -15.159822 )
     (-15.711023 -32.911857 9.9844608 -20.876991 -1.68723678 44.102119 )
     (-6.5701809 -31.737785 8.29722405 23.225132 -3.47058487 -23.24868 )
     (-0.00824896433 -20.136993 4.82663918 -0.0235491991 3.56957626 -23.107383 )
     (6.60317803 -31.714237 8.39621545 -23.130935 1.19228363 43.67823 )
     (15.595535 -33.00605 9.58849908 20.547298 -14.338714 -13.6055526 )
     (18.014675 -19.261531 -4.75021649 6.9417448 32.162574 -13.256025 )
     (29.345752 -18.947799 27.412365 -6.31428147 -36.311607 24.629661 )
     (38.60231 -12.94725 -8.8992462 18.31538 11.083864 -19.26263 )
     (35.244995 -4.26318646 2.18461943 -0.947252036 -2.02385092 10.4208755 )
     (36.417686 4.37721610E-7 0.160768091 9.47362519 -2.98846006 -10.420877 )
     (35.084228 4.26318646 -2.82769203 -0.947252989 13.977691 19.262634 )
     (39.245384 12.947252 11.1499996 18.3153839 -40.922302 -24.629665 )
     (29.93423 18.947799 -29.772304 -6.31428147 35.711525 13.256027 )
     (18.017688 19.261531 5.93922329 6.94174576 -17.923809 13.6055526 )
     (14.995006 33.00605 -11.9845867 20.547298 5.98371315 -43.67823 )
     (6.00227643 31.714233 -6.00087357 -23.130935 -0.0110425949 23.107383 )
     (-0.00411796570 20.136993 -6.01191617 -0.0235481784 0.0604562759 23.24868 )
     (-5.9858074 31.737785 -5.95145989 23.225132 -6.23077584 -44.102119 )
     (-15.052654 32.91185 -12.1822357 -20.876987 18.86264 15.159818 )
     (-17.803569 19.614776 6.68040753 -5.7171688 -39.219795 7.46283913 )
     (-30.733062 17.629028 -32.53939 1.74567079 48.016555 -15.0111828 )
     (-39.264167 11.869106 15.4771709 -13.265512 -20.846462 10.58189 )
     (-34.210235 3.8945403 -5.36929226 -2.6836214 5.36929226 2.6836214 ))
    NATURAL))

  ((21
    ((244 28) (221 26) (196 28) (160 36) (138 47) (117 71)
     (106 124) (117 177) (138 201) (160 212) (196 220) (221 221)
     (244 220) (280 212) (303 201) (324 177) (334 124) (324 71)
     (303 47) (280 36) (244 28))
    NIL
    ((-31.346866 -4.94781018 27.096454 7.89321995 -31.20816 -5.99279499 )
     (-19.854492 -0.0509881154 -4.11170769 1.90042472 -18.537914 6.6046543 )
     (-33.235153 5.1517639 -22.649623 8.50507928 51.359825 -8.4258213 )
     (-30.204864 9.44393159 28.7102 0.0792564750 -36.90139 9.0986347 )
     (-19.945362 14.0725078 -8.19119454 9.17789269 18.245773 32.031272 )
     (-19.013671 39.266037 10.0545787 41.209167 17.918293 -41.223762 )
     (5.46798110E-5 59.863327 27.972873 -0.0145962312 -17.918949 -41.136184 )
     (19.01345 39.280632 10.0539245 -41.150787 -18.242496 31.768524 )
     (19.946128 14.014112 -8.18857194 -9.38226129 36.88893 10.062099 )
     (30.202026 9.6629028 28.700363 0.679839969 -51.313247 -12.016935 )
     (33.245758 4.33427334 -22.612884 -11.337097 18.364067 14.005647 )
     (19.81491 1.11246481E-6 -4.24881554 2.66855192 31.85696 -14.005661 )
     (31.494579 -4.33427906 27.608146 -11.33711 -55.791923 12.0170059 )
     (31.206764 -9.66288568 -28.183776 0.679895640 35.31073 -10.062366 )
     (20.678356 -14.014175 7.1269579 -9.38247109 -19.451011 -31.767528 )
     (18.079803 -39.28041 -12.3240547 -41.15 -11.506668 41.132476 )
     (0.00241565704 -59.864166 -23.830722 -0.0175195671 11.477674 41.237594 )
     (-18.0894699 -39.262886 -12.353048 41.220077 19.59597 -32.08287 )
     (-20.644531 -14.084251 7.24292184 9.1372032 -35.861557 -8.9060955 )
     (-31.332393 -9.4000969 -28.618637 0.231106251 57.850273 7.70726395 ))
    PSEUDOCYCLIC))))

((FAMILY gacha)
 (CHARACTER 160Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  9:12:38)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((73 246) (73 -98))
    NIL
    ((0 -344. 0 0 0 0 ))
    NATURAL)
   (2
    ((73 -98) (122 -98))
    NIL
    ((49. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((122 -98) (122 19))
    NIL
    ((0 117. 0 0 0 0 ))
    NATURAL)
   (19
    ((122 19) (152 6) (186 -2) (223 -6) (274 -2) (306 10)
     (330 24) (346 42) (358 66) (367 124) (358 182) (346 206)
     (330 224) (306 238) (274 250) (223 254) (186 250) (149 241)
     (122 229))
    NIL
    ((28.78485 -14.1662578 0 0 7.29088879 6.99755765 )
     (32.43029 -10.6674785 7.29088879 6.99755765 -12.4544449 -4.9877901 )
     (33.493957 -6.1638174 -5.1635561 2.00976705 36.526893 6.95360566 )
     (46.593849 -0.677247048 31.363338 8.96337319 -67.653137 1.17336273 )
     (44.130615 8.87280656 -36.28981 10.1367359 36.0857 -11.6470565 )
     (25.883659 13.186014 -0.204107195 -1.51032066 -10.689651 9.4148655 )
     (20.334728 16.383125 -10.8937587 7.90454579 6.67289925 -14.012405 )
     (12.777418 17.281471 -4.22085953 -6.10786057 7.9980583 58.63475 )
     (12.5555877 40.490989 3.77719927 52.526893 -32.66513 -52.526634 )
     (2.22682952E-4 66.75456 -28.887935 2.57580541E-4 32.662468 -52.528175 )
     (-12.556476 40.49073 3.77453518 -52.527923 -7.98474026 58.639366 )
     (-12.7743129 17.282493 -4.21020508 6.11144925 -6.72350693 -14.029323 )
     (-20.346271 16.37928 -10.933712 -7.91787434 10.8787708 9.4779205 )
     (-25.840599 13.2003688 -0.0549402982 1.56004619 -36.791572 -11.8823547 )
     (-44.291328 8.81923677 -36.846519 -10.322309 70.28755 2.05150032 )
     (-45.99407 -0.477321923 33.441032 -8.27080918 -46.358634 3.67635918 )
     (-35.73236 -6.9099512 -12.917608 -4.59445 31.147007 1.24306249 )
     (-33.076461 -10.8828697 18.2294 -3.3513875 -18.2294 3.3513875 ))
    NATURAL)
   (2
    ((122 229) (122 246))
    NIL
    ((0 17. 0 0 0 0 ))
    NATURAL)
   (2
    ((122 246) (73 246))
    NIL
    ((-49. 0 0 0 0 0 ))
    NATURAL))

  ((11
    ((121 124) (124 162) (136 195) (162 214) (196 220) (222 222)
     (244 220) (279 214) (304 195) (316 162) (319 124))
    NIL
    ((1.40951395 38.569053 0 0 9.54291535 -3.41436482 )
     (6.1809721 36.861877 9.54291535 -3.41436482 6.28541756 -12.9281749 )
     (18.866596 26.983425 15.8283329 -16.34254 -4.68458176 1.12707138 )
     (32.352638 11.204418 11.143751 -15.215469 -23.547092 14.419889 )
     (31.722843 3.1988945 -12.403341 -0.795579792 2.87295532 -4.80662918 )
     (20.755977 -4.17232513E-7 -9.53038598 -5.60220909 36.055267 4.80662918 )
     (29.25323 -3.19889498 26.524887 -0.795579315 -45.094047 -14.419889 )
     (33.231086 -11.20442 -18.569164 -15.215469 6.32094384 -1.12706756 )
     (17.822395 -26.983425 -12.24822 -16.3425369 1.81027794 12.928171 )
     (6.47931386 -36.861877 -10.437942 -3.41436482 10.437942 3.41436482 ))
    NATURAL)
   (11
    ((319 124) (316 86) (304 53) (279 34) (244 28) (222 26)
     (196 28) (162 34) (136 53) (124 86) (121 124))
    NIL
    ((-1.26034259 -38.569053 0 0 -10.437944 3.41436482 )
     (-6.4793148 -36.861877 -10.437944 3.41436482 -1.81027794 12.9281749 )
     (-17.822395 -26.983425 -12.248222 16.34254 -6.32094193 -1.12707138 )
     (-33.231086 -11.204418 -18.569164 15.215469 45.094047 -14.419889 )
     (-29.25323 -3.1988945 26.524887 0.795579792 -36.055267 4.80662918 )
     (-20.755977 4.17232513E-7 -9.53038598 5.60220909 -2.87295532 -4.80662918 )
     (-31.722843 3.19889498 -12.403341 0.795579315 23.547092 14.419889 )
     (-32.352638 11.20442 11.143753 15.215469 4.68457794 1.12706756 )
     (-18.866596 26.983425 15.828331 16.3425369 -6.28541566 -12.928171 )
     (-6.18097115 36.861877 9.54291535 3.41436482 -9.54291535 -3.41436482 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 161Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  9:19:54)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((367 -98) (319 -98))
    NIL
    ((-48. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((319 -98) (319 19))
    NIL
    ((0 117. 0 0 0 0 ))
    NATURAL)
   (19
    ((319 19) (288 7) (255 -1) (217 -6) (166 -2) (134 9)
     (111 24) (94 42) (82 66) (73 124) (82 182) (94 206)
     (111 224) (134 239) (166 250) (217 254) (255 250) (292 241)
     (319 229))
    NIL
    ((-30.485801 -12.997631 0 0 -3.08518171 5.9857931 )
     (-32.028389 -10.004734 -3.08518171 5.9857931 3.42590904 -5.92896652 )
     (-33.400619 -6.98342515 0.340727687 0.0568262711 -28.618454 11.7300739 )
     (-47.369117 -1.06156039 -28.277729 11.786901 63.04792 -4.99134159 )
     (-44.122886 8.22966958 34.770195 6.79555989 -31.57326 -3.76470089 )
     (-25.13932 13.142879 3.19693089 3.03085899 3.24514675 2.05014229 )
     (-20.319816 17.19881 6.44207764 5.08100128 0.592679024 -10.435867 )
     (-13.5813999 17.061878 7.03475667 -5.35486698 -11.6158619 57.693328 )
     (-12.354574 40.553672 -4.58110619 52.338462 33.870765 -52.337432 )
     (-2.96272337E-4 66.723404 29.289665 0.00102418940 -33.867218 -52.34358 )
     (12.3557586 40.552642 -4.5775528 -52.342559 11.5981006 57.711776 )
     (13.577257 17.065979 7.0205488 5.36921883 -0.525197029 -10.503532 )
     (20.335208 17.183429 6.4953518 -5.13431454 -3.49731016 2.30235624 )
     (25.081905 13.200292 2.99804163 -2.83195829 32.514434 -4.7058897 )
     (44.337165 8.0153904 35.51248 -7.53784848 -66.560455 -1.47879696 )
     (46.56941 -0.261858106 -31.047985 -9.01664544 41.727447 4.62108517 )
     (36.385154 -6.9679613 10.679462 -4.39556027 -28.349323 0.994450570 )
     (32.889953 -10.8662967 -17.66986 -3.4011097 17.66986 3.4011097 ))
    NATURAL)
   (2
    ((319 229) (319 246))
    NIL
    ((0 17. 0 0 0 0 ))
    NATURAL)
   (2
    ((319 246) (367 246))
    NIL
    ((48. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((367 246) (367 -98))
    NIL
    ((0 -344. 0 0 0 0 ))
    NATURAL))

  ((11
    ((319 124) (316 162) (304 195) (279 214) (244 220) (220 222)
     (196 220) (162 214) (136 195) (124 162) (121 124))
    NIL
    ((-1.27691745 38.569053 0 0 -10.338495 -3.41436482 )
     (-6.44616604 36.861877 -10.338495 -3.41436482 -2.307518 -12.9281749 )
     (-17.938419 26.983425 -12.646013 -16.34254 -4.43143654 1.12707138 )
     (-32.800148 11.204418 -17.077449 -15.215469 38.03327 14.419889 )
     (-30.860965 3.1988945 20.955825 -0.795579792 -21.701679 -4.80662918 )
     (-20.755977 -4.17232513E-7 -0.745855928 -5.60220909 -17.226543 4.80662918 )
     (-30.115108 -3.19889498 -17.9724 -0.795579315 30.607864 -14.419889 )
     (-32.783577 -11.20442 12.6354656 -15.215469 2.79507446 -1.12706756 )
     (-18.750572 -26.983425 15.43054 -16.3425369 -5.78817559 12.928171 )
     (-6.21412087 -36.861877 9.6423645 -3.41436482 -9.6423645 3.41436482 ))
    NATURAL)
   (11
    ((121 124) (124 86) (136 53) (162 34) (196 28) (220 26)
     (244 28) (279 34) (304 53) (316 86) (319 124))
    NIL
    ((1.39293909 -38.569053 0 0 9.6423645 3.41436482 )
     (6.21412087 -36.861877 9.6423645 3.41436482 5.78817749 12.9281749 )
     (18.750572 -26.983425 15.430542 16.34254 -2.79507828 -1.12707138 )
     (32.783577 -11.204418 12.6354637 15.215469 -30.607864 -14.419889 )
     (30.115108 -3.1988945 -17.9724 0.795579792 17.226543 4.80662918 )
     (20.755977 4.17232513E-7 -0.745855928 5.60220909 21.701679 -4.80662918 )
     (30.860965 3.19889498 20.955825 0.795579315 -38.03327 14.419889 )
     (32.800148 11.20442 -17.077449 15.215469 4.43143654 1.12706756 )
     (17.938419 26.983425 -12.646013 16.3425369 2.3075161 -12.928171 )
     (6.44616509 36.861877 -10.338497 3.41436482 10.338497 -3.41436482 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 162Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  9:24:15)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((3
    ((94 0) (94 0) (94 246))
    NIL
    ((0 -61.5 0 0 0 369. )
     (0 123. 0 369. 0 -369. ))
    NATURAL)
   (2
    ((94 246) (146 246))
    NIL
    ((52. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((146 246) (146 231))
    NIL
    ((0 -15. 0 0 0 0 ))
    NATURAL)
   (11
    ((146 231) (172 241) (200 250) (226 254) (258 256) (286 253)
     (315 245) (334 236) (349 224) (361 208) (369 187))
    NIL
    ((25.179721 9.92842675 0 0 4.92166043 0.429432392 )
     (27.640552 10.1431427 4.92166043 0.429432392 -12.608301 -8.14716149 )
     (26.25806 6.49899483 -7.6866417 -7.71772957 21.51155 8.15921594 )
     (29.327194 2.8608737 13.824909 0.441486776 -25.4379 -6.48970318 )
     (30.43315 0.0575087815 -11.612993 -6.04821683 20.240062 -0.200402260 )
     (28.940189 -6.090909 8.62707139 -6.24861909 -25.522361 7.29131127 )
     (24.806079 -8.69387246 -16.89529 1.04269218 15.849386 -4.96484089 )
     (15.835481 -10.1336 -1.04590392 -3.92214918 -1.87518859 0.568055630 )
     (13.851984 -13.7717228 -2.9210925 -3.35409355 -2.34863329 -3.30738258 )
     (9.7565746 -18.779506 -5.2697258 -6.66147614 5.2697258 6.66147614 ))
    NATURAL)
   (2
    ((369 187) (370 169))
    NIL
    ((1. -18. 0 0 0 0 ))
    NATURAL)
   (2
    ((370 169) (321 169))
    NIL
    ((-49. 0 0 0 0 0 ))
    NATURAL)
   (10
    ((321 169) (319 191) (307 205) (288 215) (259 220) (235 221)
     (209 219) (178 212) (155 193) (146 160))
    NIL
    ((0.395535767 23.935108 0 0 -14.3732147 -11.6106548 )
     (-6.79107094 18.129779 -14.3732147 -11.6106548 11.8660736 10.053274 )
     (-15.2312488 11.545763 -2.50714111 -1.55738067 -15.091079 -4.60244179 )
     (-25.283931 7.68716145 -17.59822 -6.15982247 30.498256 2.35649347 )
     (-27.633022 2.70558596 12.9000358 -3.80332899 -16.901958 1.1764698 )
     (-23.183967 -0.509507895 -4.00192356 -2.62685919 -4.89041806 -1.06237459 )
     (-29.631099 -3.66755486 -8.8923416 -3.68923378 18.46363 -8.9269695 )
     (-29.291626 -11.820274 9.57129098 -12.616203 9.03588296 -5.22974015 )
     (-15.20239 -27.051349 18.6071739 -17.845943 -18.6071739 17.845943 ))
    NATURAL)
   (2
    ((146 160) (146 0))
    NIL
    ((0 -160. 0 0 0 0 ))
    NATURAL)
   (2
    ((146 0) (94 0))
    NIL
    ((-52. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 163Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  9:34:01)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((25
    ((351 186) (346 202) (336 220) (306 238) (265 250) (223 254)
     (183 252) (148 246) (120 234) (106 222) (94 204) (90 183)
     (96 165) (121 142) (175 120) (226 103) (277 85) (295 58)
     (281 32) (238 25) (210 26) (171 31) (138 42) (122 59)
     (117 73))
    NIL
    ((-4.89096356 15.5457267 0 0 -0.654214859 2.72563505 )
     (-5.21807099 16.908542 -0.654214859 2.72563505 -26.728923 -1.62817669 )
     (-19.236747 18.820091 -27.38314 1.09745836 17.569915 -8.21292687 )
     (-37.83493 15.811084 -9.8132229 -7.11546899 10.4492588 -1.52011108 )
     (-42.423522 7.9355602 0.636036754 -8.63558007 0.633041024 2.29337406 )
     (-41.470962 0.446667433 1.26907777 -6.342206 5.0185728 4.34661293 )
     (-37.692596 -3.72223234 6.28765107 -1.99559283 -2.70733642 -7.67982579 )
     (-32.758613 -9.55773736 3.58031464 -9.67541886 17.810775 14.372688 )
     (-20.272914 -12.046812 21.39109 4.69726944 -26.535766 -13.81093 )
     (-12.1497097 -14.2550087 -5.1446762 -9.1136608 16.3322868 4.87103844 )
     (-9.1282406 -20.933151 11.187612 -4.24262238 -2.79339218 12.326774 )
     (0.662676096 -19.012386 8.39422036 8.0841522 6.8412819 -18.178138 )
     (12.477537 -20.017303 15.235502 -10.0939865 29.428268 12.385782 )
     (42.427177 -23.918396 44.663772 2.2917962 -64.554397 4.63500405 )
     (54.81375 -19.309097 -19.890628 6.92680073 36.789367 -6.92580319 )
     (53.3178 -15.845199 16.8987388 9.97102587E-4 -64.603057 -12.9317836 )
     (37.915008 -22.310096 -47.704322 -12.930788 23.622894 10.6529445 )
     (2.02213144 -29.914409 -24.081428 -2.27784204 -23.888504 30.319995 )
     (-34.003547 -17.032253 -47.969932 28.042156 89.931106 -23.932937 )
     (-37.007927 -0.956568003 41.961174 4.10921669 -71.835937 -0.588241577 )
     (-30.964725 2.85852814 -29.874763 3.52097511 41.412643 2.28590584 )
     (-40.133163 7.52245618 11.5378837 5.80688095 8.1853447 3.44461632 )
     (-24.502605 15.051645 19.723228 9.25149728 -8.15403558 -16.064369 )
     (-8.8563976 16.2709579 11.5691928 -6.81287385 -11.5691928 6.81287385 ))
    NATURAL)
   (2
    ((117 73) (72 73))
    NIL
    ((-45. 0 0 0 0 0 ))
    NATURAL)
   (24
    ((72 73) (85 42) (112 15) (144 1) (183 -7) (222 -8)
     (261 -7) (296 0) (325 13) (349 37) (355 66) (348 95)
     (330 114) (292 131) (238 148) (187 165) (151 184) (156 213)
     (188 221) (213 223) (241 221) (277 214) (297 202) (303 186))
    NIL
    ((9.47211839 -31.218654 0 0 21.167285 1.31194877 )
     (20.055763 -30.562683 21.167285 1.31194877 -21.836437 17.440254 )
     (30.304828 -20.530601 -0.669154763 18.752204 12.1784839 -17.072986 )
     (35.724914 -10.3148918 11.5093307 1.67921805 -14.877496 8.8516998 )
     (39.795494 -4.20982266 -3.3681674 10.530918 5.33150673 -12.3338146 )
     (39.093078 0.154187590 1.96334004 -1.80289674 -6.4485321 10.483564 )
     (37.832153 3.59307385 -4.4851923 8.68066789 -3.53737736 -5.60044766 )
     (31.578277 9.47351838 -8.02256967 3.08022022 8.59804345 11.918224 )
     (27.854728 18.512851 0.575473786 14.998445 -24.854797 -12.0724487 )
     (16.0028 27.47507 -24.279323 2.9259963 12.821157 0.371571064 )
     (-1.86594367 30.586853 -11.458166 3.29756737 3.57016087 -19.413829 )
     (-11.539028 24.177501 -7.88800526 -16.116264 -15.101804 17.28376 )
     (-26.977935 16.703121 -22.98981 1.16749811 2.83706665 -1.72122335 )
     (-48.549217 17.0100059 -20.152744 -0.553725243 27.753543 1.6011281 )
     (-54.825187 17.256843 7.6008024 1.04740286 0.148731231 -4.68328858 )
     (-47.150016 15.962604 7.74953366 -3.63588619 43.651519 29.132022 )
     (-17.574722 26.89273 51.401054 25.496139 -18.754821 -63.84481 )
     (24.448917 20.466461 32.646232 -38.34867 -52.632209 40.247222 )
     (30.779045 2.24140549 -19.985977 1.89855599 25.283653 -7.1441021 )
     (23.434894 0.567910671 5.297678 -5.24554634 11.497587 0.329174995 )
     (34.48136 -4.51304817 16.795265 -4.91637135 -41.274002 -0.172595977 )
     (30.639629 -9.51571656 -24.478736 -5.08896733 9.598423 0.361209869 )
     (10.9601039 -14.4240799 -14.8803138 -4.72775746 14.8803138 4.72775746 ))
    NATURAL)
   (2
    ((303 186) (351 186))
    NIL
    ((48. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 164Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  9:41:54)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((215 316) (169 316))
    NIL
    ((-46. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((169 316) (169 246))
    NIL
    ((0 -70. 0 0 0 0 ))
    NATURAL)
   (2
    ((169 246) (73 246))
    NIL
    ((-96. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((73 246) (73 210))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL)
   (2
    ((73 210) (169 210))
    NIL
    ((96. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((169 210) (169 60))
    NIL
    ((0 -150. 0 0 0 0 ))
    NATURAL)
   (11
    ((169 60) (175 39) (189 20) (205 7) (229 -3) (268 -9)
     (316 -6) (346 3) (367 20) (381 38) (388 69))
    NIL
    ((3.90507937 -21.153274 0 0 12.5695228 0.919651986 )
     (10.18984 -20.693447 12.5695228 0.919651986 -14.847616 7.40174008 )
     (15.335556 -16.072925 -2.27809334 8.32139207 10.8209438 -6.526618 )
     (18.467933 -11.014843 8.5428505 1.79477358 7.56383896 0.704737187 )
     (30.792705 -8.86770059 16.106689 2.49951076 0.923694611 9.7076702 )
     (47.361244 -1.51435375 17.030384 12.2071819 -47.258613 -9.53542138 )
     (40.762313 5.92511654 -30.228233 2.67175913 26.110794 10.434017 )
     (23.589481 13.8138847 -4.1174364 13.1057777 -3.1845789 -20.200649 )
     (17.879753 16.8193359 -7.3020153 -7.09487343 -1.37248039 28.368587 )
     (9.89149858 23.90876 -8.6744957 21.273715 8.6744957 -21.273715 ))
    NATURAL)
   (2
    ((388 69) (340 69))
    NIL
    ((-48. 0 0 0 0 0 ))
    NATURAL)
   (8
    ((340 69) (337 47) (325 33) (303 27) (272 25) (245 29)
     (222 40) (215 60))
    NIL
    ((-1.11267614 -23.621776 0 0 -11.323942 9.73067666 )
     (-6.7746477 -18.756439 -11.323942 9.73067666 2.61971664 -0.653385163 )
     (-16.78873 -9.35245515 -8.70422555 9.0772915 -5.1549282 -7.1171398 )
     (-28.070419 -3.83373404 -13.8591537 1.96015119 23.999996 5.12195015 )
     (-29.929576 0.687392831 10.140844 7.0821018 -12.8450699 -1.37066269 )
     (-26.211265 7.08416367 -2.70422554 5.71143914 27.380279 6.3607006 )
     (-15.225351 15.975952 24.676055 12.0721397 -24.676055 -12.0721397 ))
    NATURAL)
   (2
    ((215 60) (215 210))
    NIL
    ((0 150. 0 0 0 0 ))
    NATURAL)
   (2
    ((215 210) (334 210))
    NIL
    ((119. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((334 210) (334 246))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((334 246) (215 246))
    NIL
    ((-119. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((215 246) (215 316))
    NIL
    ((0 70. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 165Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  9:50:36)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((3
    ((367 0) (367 0) (367 246))
    NIL
    ((0 -61.5 0 0 0 369. )
     (0 123. 0 369. 0 -369. ))
    NATURAL)
   (2
    ((367 246) (316 246))
    NIL
    ((-51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((316 246) (316 90))
    NIL
    ((0 -156. 0 0 0 0 ))
    NATURAL)
   (9
    ((316 90) (308 59) (278 39) (243 30) (222 29) (196 29)
     (161 33) (132 49) (123 90))
    NIL
    ((-2.74641037 -33.309829 0 0 -31.521537 13.858984 )
     (-18.507179 -26.380336 -31.521537 13.858984 25.607692 -3.29491997 )
     (-37.224868 -14.1688137 -5.91384316 10.564064 31.090755 -0.679307938 )
     (-27.593334 -3.94440317 25.176914 9.8847561 -35.970726 -11.987848 )
     (-20.401783 -0.0535713807 -10.7938156 -2.10309267 -1.20783996 6.63070584 )
     (-31.799518 1.1586895 -12.001655 4.52761364 16.802093 3.46502209 )
     (-35.400123 7.41881467 4.80043888 7.9926357 23.99945 27.5092 )
     (-18.599964 29.166053 28.799892 35.501838 -28.799892 -35.501838 ))
    NATURAL)
   (2
    ((123 90) (123 246))
    NIL
    ((0 156. 0 0 0 0 ))
    NATURAL)
   (2
    ((123 246) (75 246))
    NIL
    ((-48. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((75 246) (76 59))
    NIL
    ((1. -187. 0 0 0 0 ))
    NATURAL)
   (11
    ((76 59) (82 35) (96 18) (114 5) (141 -4) (175 -8)
     (204 -9) (235 -6) (258 -1) (277 7) (316 23))
    NIL
    ((4.01473713 -25.642467 0 0 11.911575 9.85482026 )
     (9.9705238 -20.715057 11.911575 9.85482026 -11.5578765 -7.27410126 )
     (16.1031608 -14.497289 0.353697181 2.58071852 10.3199367 1.24158621 )
     (21.616828 -11.295776 10.673635 3.82230473 0.278120041 2.30775452 )
     (32.429519 -6.31959534 10.951755 6.13005925 -23.432415 -4.47259999 )
     (31.665069 -2.42583704 -12.480661 1.65745854 21.451553 3.5826478 )
     (29.910186 1.02294540 8.97089387 5.24010659 -20.373809 -3.85799217 )
     (28.694175 4.3340559 -11.4029178 1.38211417 0.0436954498 -0.150678157 )
     (17.313106 5.640831 -11.359222 1.23143601 44.199028 10.4607029 )
     (28.053398 12.102619 32.839805 11.6921405 -32.839805 -11.6921405 ))
    NATURAL)
   (2
    ((316 23) (316 0))
    NIL
    ((0 -23. 0 0 0 0 ))
    NATURAL)
   (2
    ((316 0) (367 0))
    NIL
    ((51. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 166Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  9:55:45)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((55 246) (195 0))
    NIL
    ((140. -246. 0 0 0 0 ))
    NATURAL)
   (2
    ((195 0) (242 0))
    NIL
    ((47. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((242 0) (382 246))
    NIL
    ((140. 246. 0 0 0 0 ))
    NATURAL)
   (2
    ((382 246) (328 246))
    NIL
    ((-54. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((328 246) (219 41))
    NIL
    ((-109. -205. 0 0 0 0 ))
    NATURAL)
   (2
    ((219 41) (110 246))
    NIL
    ((-109. 205. 0 0 0 0 ))
    NATURAL)
   (2
    ((110 246) (55 246))
    NIL
    ((-55. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 167Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77  9:57:51)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((25 246) (124 0))
    NIL
    ((99. -246. 0 0 0 0 ))
    NATURAL)
   (2
    ((124 0) (175 0))
    NIL
    ((51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((175 0) (219 146))
    NIL
    ((44. 146. 0 0 0 0 ))
    NATURAL)
   (2
    ((219 146) (262 0))
    NIL
    ((43. -146. 0 0 0 0 ))
    NATURAL)
   (2
    ((262 0) (313 0))
    NIL
    ((51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((313 0) (412 246))
    NIL
    ((99. 246. 0 0 0 0 ))
    NATURAL)
   (2
    ((412 246) (361 246))
    NIL
    ((-51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((361 246) (286 62))
    NIL
    ((-75. -184. 0 0 0 0 ))
    NATURAL)
   (2
    ((286 62) (237 246))
    NIL
    ((-49. 184. 0 0 0 0 ))
    NATURAL)
   (2
    ((237 246) (201 246))
    NIL
    ((-36. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((201 246) (151 62))
    NIL
    ((-50. -184. 0 0 0 0 ))
    NATURAL)
   (2
    ((151 62) (77 246))
    NIL
    ((-74. 184. 0 0 0 0 ))
    NATURAL)
   (2
    ((77 246) (25 246))
    NIL
    ((-52. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 170Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 10:01:04)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((76 246) (190 139))
    NIL
    ((114. -107. 0 0 0 0 ))
    NATURAL)
   (2
    ((190 139) (43 0))
    NIL
    ((-147. -139. 0 0 0 0 ))
    NATURAL)
   (2
    ((43 0) (98 0))
    NIL
    ((55. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((98 0) (219 109))
    NIL
    ((121. 109. 0 0 0 0 ))
    NATURAL)
   (2
    ((219 109) (340 0))
    NIL
    ((121. -109. 0 0 0 0 ))
    NATURAL)
   (2
    ((340 0) (394 0))
    NIL
    ((54. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((394 0) (248 139))
    NIL
    ((-146. 139. 0 0 0 0 ))
    NATURAL)
   (2
    ((248 139) (361 246))
    NIL
    ((113. 107. 0 0 0 0 ))
    NATURAL)
   (2
    ((361 246) (305 246))
    NIL
    ((-56. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((305 246) (219 164))
    NIL
    ((-86. -82. 0 0 0 0 ))
    NATURAL)
   (2
    ((219 164) (132 246))
    NIL
    ((-87. 82. 0 0 0 0 ))
    NATURAL)
   (2
    ((132 246) (76 246))
    NIL
    ((-56. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 171Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 10:03:58)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((67 246) (207 3))
    NIL
    ((140. -243. 0 0 0 0 ))
    NATURAL)
   (8
    ((207 3) (204 -28) (182 -55) (154 -65) (130 -67) (105 -63)
     (78 -50) (65 -25))
    NIL
    ((1.58570909 -30.982479 0 0 -27.514255 -0.105117797 )
     (-12.171417 -31.035038 -27.514255 -0.105117797 23.571277 24.525589 )
     (-27.900032 -18.877357 -3.94297457 24.420471 11.2291298 -19.997249 )
     (-26.228443 -4.455513 7.2861557 4.42322159 -8.4878044 1.4634161 )
     (-23.186187 0.699416161 -1.20164919 5.88663769 -7.27790929 2.14358997 )
     (-28.026794 7.65785027 -8.47955895 8.03022767 31.599445 7.9622154 )
     (-20.706626 19.669185 23.119888 15.992443 -23.119888 -15.992443 ))
    NATURAL)
   (2
    ((65 -25) (18 -25))
    NIL
    ((-47. 0 0 0 0 0 ))
    NATURAL)
   (9
    ((18 -25) (33 -57) (60 -81) (88 -95) (138 -101) (195 -91)
     (232 -69) (253 -38) (274 3))
    NIL
    ((11.490978 -33.511222 0 0 21.054122 9.0673771 )
     (22.018039 -28.977539 21.054122 9.0673771 -33.270614 2.66310882 )
     (26.436855 -18.578605 -12.2164936 11.7304859 46.028343 -7.71980954 )
     (37.234535 -10.7080249 33.81185 4.01067639 -24.842777 16.216125 )
     (58.625 1.41071462 8.96907235 20.226802 -36.65721 -9.1446972 )
     (49.265457 17.065166 -27.688144 11.0821056 9.47165299 -3.63733387 )
     (26.31314 26.328605 -18.216491 7.44477177 22.770614 5.69403363 )
     (19.481956 36.620391 4.55412293 13.138805 -4.55412293 -13.138805 ))
    NATURAL)
   (2
    ((274 3) (394 246))
    NIL
    ((120. 243. 0 0 0 0 ))
    NATURAL)
   (2
    ((394 246) (340 246))
    NIL
    ((-54. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((340 246) (241 37))
    NIL
    ((-99. -209. 0 0 0 0 ))
    NATURAL)
   (2
    ((241 37) (122 246))
    NIL
    ((-119. 209. 0 0 0 0 ))
    NATURAL)
   (2
    ((122 246) (67 246))
    NIL
    ((-55. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 172Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 10:05:23)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((81 246) (369 246))
    NIL
    ((288. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((369 246) (369 212))
    NIL
    ((0 -34. 0 0 0 0 ))
    NATURAL)
   (2
    ((369 212) (140 36))
    NIL
    ((-229. -176. 0 0 0 0 ))
    NATURAL)
   (2
    ((140 36) (378 36))
    NIL
    ((238. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((378 36) (378 0))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL)
   (2
    ((378 0) (63 0))
    NIL
    ((-315. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((63 0) (63 34))
    NIL
    ((0 34. 0 0 0 0 ))
    NATURAL)
   (2
    ((63 34) (292 210))
    NIL
    ((229. 176. 0 0 0 0 ))
    NATURAL)
   (2
    ((292 210) (81 210))
    NIL
    ((-211. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((81 210) (81 246))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/GACHAE.NUM-SF b/obsolete/lispusers/splinefonts/GACHAE.NUM-SF
deleted file mode 100644
index af6370f4..00000000
--- a/obsolete/lispusers/splinefonts/GACHAE.NUM-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY gacha)
 (CHARACTER 60Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 11:56:36)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((29
    ((220 -2) (177 2) (142 13) (115 28) (97 49) (87 72)
     (78 108) (72 169) (78 230) (87 266) (97 289) (115 310)
     (142 325) (177 336) (220 340) (264 336) (298 325) (325 308)
     (343 289) (354 266) (363 230) (369 169) (363 108) (354 72)
     (343 49) (325 28) (298 13) (264 2) (220 -2))
    NIL
    ((-44.70249 2.2971487 0 0 10.2149925 10.2171058 )
     (-39.595 7.4057026 10.2149925 10.2171058 -3.07496834 -9.08553506 )
     (-30.917491 13.0800399 7.14002419 1.13156938 2.08488273 8.12504388 )
     (-22.735023 18.274131 9.2249069 9.25661469 0.735431671 -11.4146518 )
     (-13.1424007 21.823421 9.9603386 -2.15803718 -11.0266018 13.533569 )
     (-8.695364 26.43217 -1.06626343 11.375532 1.37097907 23.280372 )
     (-9.07613755 49.44789 0.304715693 34.655906 17.542682 -34.655075 )
     (-7.94418156E-5 66.776245 17.8474 8.27937503E-4 -17.541725 -34.660041 )
     (9.07645799 49.447059 0.305675328 -34.659217 -1.37578034 23.295288 )
     (8.69424249 26.435485 -1.07010507 -11.3639278 11.044849 13.478868 )
     (13.146564 21.810989 9.9747448 2.11494064 -0.803623200 -11.210775 )
     (22.719497 18.320545 9.1711216 -9.09583474 -1.83035755 7.36423016 )
     (30.97544 12.906824 7.34076405 -1.73160457 2.12505627 -6.24614144 )
     (39.37873 8.0521488 9.4658203 -7.977746 -6.6698742 -0.379662514 )
     (45.509613 -0.115427330 2.79594612 -8.3574085 -17.445552 1.76478958 )
     (39.582786 -7.59044076 -14.649606 -6.59261895 10.452091 -0.679496765 )
     (30.159225 -14.522808 -4.19751454 -7.2721157 -6.3628168 6.95319844 )
     (22.7803 -18.318321 -10.560331 -0.318916559 2.99917793 -3.13330078 )
     (13.7195587 -20.203891 -7.5611534 -3.45221758 6.3660984 -6.4199934 )
     (9.34145547 -26.866107 -1.19505500 -9.87221147 1.53642988 -25.186718 )
     (8.91461564 -49.331672 0.341374993 -35.058929 -18.5118179 35.166854 )
     (7.89556652E-5 -66.807174 -18.170444 0.107930347 18.510856 34.519271 )
     (-8.91493608 -49.439598 0.340415239 34.627204 -1.53162884 -23.243984 )
     (-9.34033395 -26.434387 -1.19121360 11.3832206 -6.38434506 -13.5433178 )
     (-13.723722 -21.822826 -7.57555867 -2.1600976 -2.93098736 11.4172649 )
     (-22.764774 -18.274292 -10.506546 9.2571678 6.10829259 -8.12574578 )
     (-30.217174 -13.079996 -4.39825344 1.13142156 -9.5021801 9.08572198 )
     (-39.366516 -7.40571404 -13.900434 10.217144 13.900434 -10.217144 ))
    NATURAL))

  ((15
    ((117 169) (117 139) (120 107) (126 75) (143 52) (165 38)
     (195 29) (220 28) (245 29) (275 38) (298 52) (314 75)
     (320 107) (323 139) (323 169))
    NIL
    ((-0.787026048 -29.594802 0 0 4.72215653 -2.43117809 )
     (1.57405233 -30.81039 4.72215653 -2.43117809 -5.61078453 0.155890941 )
     (3.49081659 -33.16362 -0.888628126 -2.27528715 17.720981 13.807613 )
     (11.4626827 -28.535102 16.832355 11.5323276 -17.2731628 -1.38635635 )
     (19.658454 -17.695949 -0.440809131 10.145971 15.371683 -8.2621956 )
     (26.903488 -11.6810779 14.9308757 1.88377571 -26.213573 10.435146 )
     (28.727577 -4.57973004 -11.2826976 12.318922 11.482616 -15.478382 )
     (23.186187 1.59256160E-7 0.199920326 -3.15946055 10.283096 15.47838 )
     (28.527656 4.57973004 10.4830169 12.31892 -22.615001 -10.435144 )
     (27.70317 11.6810779 -12.1319866 1.88377547 8.17691995 8.2621975 )
     (19.659645 17.695953 -3.95506573 10.145973 -10.0926818 1.38635444 )
     (10.658237 28.535102 -14.047748 11.5323276 14.193815 -13.807615 )
     (3.70739698 33.16362 0.146066695 -2.27528763 -4.68258286 -0.155889988 )
     (1.51217198 30.81039 -4.53651619 -2.43117761 4.53651619 2.43117761 ))
    NATURAL)
   (15
    ((323 169) (323 199) (320 231) (314 263) (298 286) (275 300)
     (245 309) (220 310) (195 309) (165 300) (143 286) (126 263)
     (120 231) (117 199) (117 169))
    NIL
    ((0.756085992 29.594802 0 0 -4.53651619 2.43117809 )
     (-1.51217222 30.81039 -4.53651619 2.43117809 4.6825819 -0.155890941 )
     (-3.70739698 33.16362 0.146066278 2.27528715 -14.193813 -13.807613 )
     (-10.658239 28.535102 -14.047748 -11.5323276 10.0926818 1.38635635 )
     (-19.659645 17.695949 -3.95506573 -10.145971 -8.17691995 8.2621956 )
     (-27.70317 11.6810779 -12.1319866 -1.88377571 22.615001 -10.435146 )
     (-28.527656 4.57973004 10.4830169 -12.318922 -10.283094 15.478382 )
     (-23.186187 -1.59256160E-7 0.199920833 3.15946055 -11.48262 -15.47838 )
     (-28.727577 -4.57973004 -11.2826995 -12.31892 26.213577 10.435144 )
     (-26.903488 -11.6810779 14.930877 -1.88377547 -15.3716869 -8.2621975 )
     (-19.658454 -17.695953 -0.440809786 -10.145973 17.273166 -1.38635444 )
     (-11.4626808 -28.535102 16.832359 -11.5323276 -17.720985 13.807615 )
     (-3.49081612 -33.16362 -0.888629199 2.27528763 5.61078549 0.155889988 )
     (-1.57405209 -30.81039 4.72215653 2.43117761 -4.72215653 -2.43117761 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 61Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 11:58:51)
 (MADE-FROM gachan.cu 0 140 10 925)
 (SPLINES

  ((3
    ((124 0) (124 0) (367 0))
    NIL
    ((-60.75 0 0 0 364.5 0 )
     (121.5 0 364.5 0 -364.5 0 ))
    NATURAL)
   (2
    ((367 0) (367 36))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((367 36) (273 36))
    NIL
    ((-94. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((273 36) (273 337))
    NIL
    ((0 301. 0 0 0 0 ))
    NATURAL)
   (2
    ((273 337) (210 337))
    NIL
    ((-63. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((210 337) (78 246))
    NIL
    ((-132. -91. 0 0 0 0 ))
    NATURAL)
   (2
    ((78 246) (134 246))
    NIL
    ((56. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((134 246) (220 303))
    NIL
    ((86. 57. 0 0 0 0 ))
    NATURAL)
   (2
    ((220 303) (220 36))
    NIL
    ((0 -267. 0 0 0 0 ))
    NATURAL)
   (2
    ((220 36) (124 36))
    NIL
    ((-96. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((124 36) (124 0))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 62Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 12:24:12)
 (MADE-FROM gachan.cu 0 140 10 925)
 (SPLINES

  ((3
    ((367 0) (367 0) (73 0))
    NIL
    ((73.5 0 0 0 -441. 0 )
     (-147. 0 -441. 0 441. 0 ))
    NATURAL)
   (2
    ((73 0) (73 50))
    NIL
    ((0 50. 0 0 0 0 ))
    NATURAL)
   (17
    ((73 50) (78 70) (90 89) (123 114) (152 134) (189 159)
     (230 186) (269 212) (303 239) (306 270) (290 291) (260 301)
     (216 305) (179 301) (155 293) (137 280) (130 264))
    NIL
    ((4.74380017 20.817619 0 0 1.53719520 -4.90571976 )
     (5.51239777 18.364757 1.53719520 -4.90571976 34.314018 18.528598 )
     (24.206604 22.723339 35.851219 13.622879 -54.793289 -27.208679 )
     (32.66117 22.741878 -18.942073 -13.5858 34.85916 24.306118 )
     (31.148681 21.309139 15.917087 10.7203178 -12.643362 -10.0157985 )
     (40.744087 27.021556 3.27372408 0.704518795 -8.28570748 -2.24291372 )
     (39.874954 26.604618 -5.01198483 -1.53839493 9.78619767 0.987456680 )
     (39.756073 25.559951 4.77421379 -0.550938249 -48.859077 10.293085 )
     (20.100742 30.155559 -44.084869 9.74214746 29.650135 -24.159797 )
     (-9.1590557 27.817802 -14.434732 -14.417652 2.25853729 2.34612083 )
     (-22.464519 14.573211 -12.176195 -12.071531 -8.6842861 8.77531434 )
     (-38.982856 6.8893385 -20.860481 -3.29621697 32.478599 -7.44738007 )
     (-43.604034 -0.130568802 11.61812 -10.743597 4.7698803 9.014204 )
     (-29.600975 -6.36706353 16.388 -1.729393 -15.558134 -4.60943508 )
     (-20.992042 -10.4011745 0.829866291 -6.33882809 15.462663 3.42353535 )
     (-12.430843 -15.028234 16.29253 -2.91529274 -16.29253 2.91529274 ))
    NATURAL)
   (2
    ((130 264) (130 239))
    NIL
    ((0 -25. 0 0 0 0 ))
    NATURAL)
   (2
    ((130 239) (82 239))
    NIL
    ((-48. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((82 239) (82 269))
    NIL
    ((0 30. 0 0 0 0 ))
    NATURAL)
   (20
    ((82 269) (90 291) (105 308) (129 322) (159 331) (216 338)
     (273 332) (307 320) (331 305) (348 282) (354 247) (341 216)
     (312 189) (282 167) (246 143) (211 120) (181 101) (149 81)
     (131 65) (125 43))
    NIL
    ((6.78662205 23.226146 0 0 7.2802677 -7.356884 )
     (10.4267559 19.547702 7.2802677 -7.356884 5.5986595 6.78442288 )
     (20.506351 15.58303 12.878927 -0.572460413 -17.6749038 -7.78081227 )
     (24.547828 11.1201629 -4.79597855 -8.3532734 47.100959 12.3388309 )
     (43.30233 8.936306 42.304985 3.9855585 -44.728965 -23.574516 )
     (63.242828 1.13460397 -2.42398405 -19.588958 -30.185062 15.959251 )
     (45.72631 -10.4747276 -32.609046 -3.62970686 27.469234 1.73749709 )
     (26.851886 -13.235687 -5.1398096 -1.89220977 -1.69189834 -4.90924263 )
     (20.866127 -17.582519 -6.83170796 -6.80145264 -2.70164585 -12.100521 )
     (12.6835956 -30.434234 -9.5333538 -18.901973 -11.501516 29.311332 )
     (-2.60051441 -34.680542 -21.03487 10.4093589 0.707698822 -9.14481927 )
     (-23.281532 -28.843593 -20.327171 1.26453852 26.670726 7.2679472 )
     (-30.273342 -23.945079 6.3435564 8.53248597 -17.390609 -13.926967 )
     (-32.62509 -22.376079 -11.047054 -5.39448166 12.891712 6.4399252 )
     (-37.226287 -24.550598 1.84465909 1.04544425 7.82375527 6.1672592 )
     (-31.469749 -20.421524 9.66841508 7.2127037 -20.186737 -13.108963 )
     (-31.894702 -19.763301 -10.5183239 -5.8962593 30.923206 16.2685928 )
     (-26.951423 -17.5252609 20.404884 10.372335 -7.50610734 -21.965419 )
     (-10.299591 -18.135635 12.898777 -11.593084 -12.898777 11.593084 ))
    NATURAL)
   (2
    ((125 43) (367 43))
    NIL
    ((242. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((367 43) (367 0))
    NIL
    ((0 -43. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 63Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 12:24:51)
 (MADE-FROM gachan.cu 0 140 10 925)
 (SPLINES

  ((2
    ((61 99) (111 99))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (16
    ((111 99) (111 75) (126 51) (153 39) (188 35) (213 34)
     (238 35) (272 39) (299 48) (319 70) (323 97) (317 126)
     (304 143) (281 155) (251 161) (226 161))
    NIL
    ((-3.35919046 -23.278705 0 0 20.155143 -4.32776165 )
     (6.71838284 -25.442585 20.155143 -4.32776165 -10.775732 21.638805 )
     (21.48566 -18.950939 9.3794117 17.311046 4.94778824 -10.2274837 )
     (33.338966 -6.7536373 14.3271999 7.0835619 -33.01541 -4.72886086 )
     (31.158458 -2.03450584 -18.688217 2.35470104 19.11388 -0.857067586 )
     (22.027183 -0.108338594 0.425663412 1.49763345 16.559894 2.15713119 )
     (30.732795 2.4678607 16.985561 3.65476465 -31.353477 -1.77145815 )
     (32.041618 5.2368965 -14.367916 1.8833065 12.854017 16.928699 )
     (24.100711 15.584554 -1.51389813 18.812007 -20.062587 -17.943359 )
     (12.555519 25.42488 -21.576488 0.868646980 13.396343 6.8447523 )
     (-2.32279682 29.715908 -8.18014527 7.71339989 2.47721863 -27.435646 )
     (-9.2643337 23.711479 -5.70292664 -19.722248 -5.30521584 18.89785 )
     (-17.619869 13.438158 -11.008142 -0.824397088 0.743648529 -6.1557617 )
     (-28.256187 9.53587915 -10.2644939 -6.9801588 20.330616 -0.274801254 )
     (-28.355373 2.4183197 10.0661239 -7.25496007 -10.0661239 7.25496007 ))
    NATURAL)
   (2
    ((226 161) (166 161))
    NIL
    ((-60. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((166 161) (166 197) (166 197))
    NIL
    ((0 45. 0 0 0 -54. )
     (0 18. 0 -54. 0 54. ))
    NATURAL)
   (2
    ((166 197) (216 197))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (15
    ((216 197) (241 197) (269 204) (289 217) (298 235) (301 260)
     (290 283) (268 297) (232 303) (210 303) (187 303) (149 297)
     (133 286) (125 272) (125 252))
    NIL
    ((23.819458 -1.50491333 0 0 7.08323479 9.02947999 )
     (27.361076 3.00982666 7.08323479 9.02947999 -17.416175 -3.14740086 )
     (25.736225 10.4656067 -10.332941 5.88207913 -3.4185276 -2.43987894 )
     (13.694019 15.127746 -13.751468 3.44220018 13.090288 6.9069147 )
     (6.48769475 22.023403 -0.661179662 10.349115 -18.9426269 -13.187776 )
     (-3.64480162 25.778629 -19.603809 -2.83866167 14.6802387 -8.1558056 )
     (-15.908493 18.862064 -4.92357064 -10.9944687 -21.778327 3.8110094 )
     (-31.721229 9.7731018 -26.7019 -7.18345929 54.43308 -1.08823299 )
     (-31.206584 2.0455246 27.731185 -8.27169229 -27.954029 12.541927 )
     (-17.452415 0.0447963029 -0.222843975 4.27023506 -32.616958 -13.079483 )
     (-33.983741 -2.22471094 -32.839805 -8.80924798 74.42189 3.77601147 )
     (-29.612598 -9.1459522 41.582084 -5.0332365 -43.07064 3.97543287 )
     (-9.56583596 -12.191473 -1.48855781 -1.05780363 13.8606968 -7.6777439 )
     (-4.12404633 -17.08815 12.3721389 -8.735548 -12.3721389 8.735548 ))
    NATURAL)
   (2
    ((125 252) (82 252))
    NIL
    ((-43. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((82 252) (82 277))
    NIL
    ((0 25. 0 0 0 0 ))
    NATURAL)
   (15
    ((82 277) (91 294) (108 310) (132 323) (163 332) (213 337)
     (259 333) (295 323) (321 307) (339 284) (346 254) (342 230)
     (331 210) (312 190) (294 179))
    NIL
    ((7.3249216 17.1195678 0 0 10.0504665 -0.717417956 )
     (12.3501548 16.76086 10.0504665 -0.717417956 -2.25233459 -2.41290998 )
     (21.274452 14.836986 7.79813195 -3.13032818 -7.04112816 -1.63093948 )
     (25.55202 10.8911876 0.757003189 -4.76126766 30.41685 2.93666792 )
     (41.517448 7.59825516 31.173854 -1.8245995 -42.626266 -10.115734 )
     (51.378166 0.715788484 -11.452417 -11.940334 2.08823204 7.5262718 )
     (40.969863 -7.4614105 -9.36418534 -4.4140625 -1.72665214 -1.98934936 )
     (30.742355 -12.8701477 -11.090837 -6.40341187 4.81837368 0.431121826 )
     (22.060703 -19.057998 -6.2724638 -5.97229004 -5.5468378 -5.73513413 )
     (13.014822 -27.897853 -11.8193016 -11.707424 -0.631027222 22.50941 )
     (0.880005479 -28.35057 -12.4503288 10.8019886 8.07095338 -6.3025217 )
     (-7.53484727 -20.699844 -4.37937546 4.4994669 -7.65279008 -9.29932405 )
     (-15.740617 -20.85004 -12.032165 -4.79985714 16.5402069 19.499816 )
     (-19.502677 -15.899986 4.50804138 14.699962 -4.50804138 -14.699962 ))
    NATURAL)
   (15
    ((294 179) (331 161) (354 138) (364 115) (367 90) (360 61)
     (339 32) (316 16) (279 3) (216 -2) (159 1) (117 12)
     (90 28) (72 50) (63 71))
    NIL
    ((39.920318 -16.637714 0 0 -17.5219269 -8.17371179 )
     (31.159355 -20.724571 -17.5219269 -8.17371179 3.60964584 10.8685646 )
     (15.442251 -23.464 -13.912281 2.6948533 9.08333589 -5.30055332 )
     (6.07163716 -23.419422 -4.82894516 -2.60570001 -3.94299126 -1.66635275 )
     (-0.728803635 -26.858299 -8.7719364 -4.27205277 -11.3113689 -0.0340318680 )
     (-15.156425 -31.147369 -20.083305 -4.30608464 25.188472 25.802475 )
     (-22.645492 -22.552211 5.10516835 21.496391 -17.442531 -25.17588 )
     (-26.261592 -13.643764 -12.337366 -3.679492 -27.41833 14.9010658 )
     (-52.308128 -9.8727226 -39.755699 11.2215747 55.115875 -4.42838192 )
     (-64.505874 -0.865339280 15.360178 6.79319287 -1.04520416 2.81245708 )
     (-49.668304 7.3340826 14.3149738 9.60564996 3.0649395 -6.82144929 )
     (-33.820861 13.5290088 17.379913 2.78420067 -11.2145576 6.4733448 )
     (-22.048225 19.549881 6.16535569 9.25754548 5.79330445 -13.0719318 )
     (-12.986219 22.271461 11.95866 -3.81438637 -11.95866 3.81438637 ))
    NATURAL)
   (2
    ((63 71) (61 99))
    NIL
    ((-2. 28. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 64Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 12:27:37)
 (MADE-FROM gachan.cu 0 140 0 0)
 (SPLINES

  ((2
    ((287 0) (334 0))
    NIL
    ((47. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((334 0) (334 84))
    NIL
    ((0 84. 0 0 0 0 ))
    NATURAL)
   (2
    ((334 84) (388 84))
    NIL
    ((54. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((388 84) (388 127))
    NIL
    ((0 43. 0 0 0 0 ))
    NATURAL)
   (2
    ((388 127) (334 127))
    NIL
    ((-54. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((334 127) (334 337))
    NIL
    ((0 210. 0 0 0 0 ))
    NATURAL)
   (2
    ((334 337) (287 337))
    NIL
    ((-47. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((287 337) (61 112))
    NIL
    ((-226. -225. 0 0 0 0 ))
    NATURAL)
   (2
    ((61 112) (61 84))
    NIL
    ((0 -28. 0 0 0 0 ))
    NATURAL)
   (2
    ((61 84) (287 84))
    NIL
    ((226. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((287 84) (287 0))
    NIL
    ((0 -84. 0 0 0 0 ))
    NATURAL))

  ((2
    ((287 127) (132 127))
    NIL
    ((-155. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((132 127) (287 285))
    NIL
    ((155. 158. 0 0 0 0 ))
    NATURAL)
   (2
    ((287 285) (287 127))
    NIL
    ((0 -158. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 65Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 12:33:57)
 (MADE-FROM gachan.cu 0 140 0 0)
 (SPLINES

  ((2
    ((63 99) (113 99))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (11
    ((113 99) (117 71) (128 55) (149 41) (187 33) (212 31)
     (238 32) (276 39) (300 56) (317 84) (322 112))
    NIL
    ((2.45260906 -31.158916 0 0 9.2843437 18.953514 )
     (7.09478188 -21.682159 9.2843437 18.953514 -4.42172432 -22.76757 )
     (14.168264 -14.112432 4.8626194 -3.81405783 26.402553 12.1167736 )
     (32.232162 -11.868103 31.265174 8.3027172 -59.188507 -1.69952965 )
     (33.903076 -4.41515064 -27.923336 6.60318757 30.351509 -5.31865692 )
     (21.155502 -0.471291602 2.42817497 1.28452992 21.782455 4.97415924 )
     (34.474899 3.30031872 24.210632 6.25868989 -51.48133 3.42201805 )
     (32.944862 11.2700176 -27.270702 9.6807079 28.14289 5.33776856 )
     (19.745609 23.619609 0.872188688 15.018476 -19.090236 -18.773094 )
     (11.072681 29.251537 -18.218048 -3.7546196 18.218048 3.7546196 ))
    NATURAL)
   (12
    ((322 112) (319 136) (310 159) (298 174) (278 186) (250 191)
     (229 192) (203 191) (167 185) (146 173) (134 159) (125 141))
    NIL
    ((-1.50521779 23.720333 0 0 -8.96869279 1.67799902 )
     (-5.9895649 24.55933 -8.96869279 1.67799902 8.8434677 -14.389993 )
     (-10.5365219 19.042331 -0.125223279 -12.711996 -8.4051876 13.8819828 )
     (-14.8643398 13.2713279 -8.53041268 1.16998744 -5.22271347 -11.137939 )
     (-26.00611 8.87234689 -13.753126 -9.9679527 29.296043 6.669775 )
     (-25.111213 2.23928118 15.542919 -3.29817772 -21.961471 2.45884323 )
     (-20.54903 0.170525491 -6.4185524 -0.839334369 -13.450157 -4.50514984 )
     (-33.692657 -2.92138386 -19.868709 -5.34448433 45.762107 -2.43824291 )
     (-30.680313 -9.48498918 25.893402 -7.78272725 -19.598308 8.2581215 )
     (-14.586067 -13.138656 6.29509164 0.475394309 -3.36886454 -6.59424306 )
     (-9.97540856 -15.960382 2.92622709 -6.1188488 -2.92622709 6.1188488 ))
    NATURAL)
   (3
    ((125 141) (73 141) (73 141))
    NIL
    ((-65. 0 0 0 78. 0 )
     (-26. 0 78. 0 -78. 0 ))
    NATURAL)
   (2
    ((73 141) (108 337))
    NIL
    ((35. 196. 0 0 0 0 ))
    NATURAL)
   (2
    ((108 337) (334 337))
    NIL
    ((226. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((334 337) (334 295))
    NIL
    ((0 -42. 0 0 0 0 ))
    NATURAL)
   (2
    ((334 295) (153 295))
    NIL
    ((-181. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((153 295) (137 202))
    NIL
    ((-16. -93. 0 0 0 0 ))
    NATURAL)
   (22
    ((137 202) (170 217) (202 224) (237 227) (280 222) (312 211)
     (337 193) (352 175) (363 153) (367 122) (363 86) (351 57)
     (325 29) (295 12) (259 2) (208 -2) (160 4) (120 17)
     (94 34) (76 54) (67 73) (63 99))
    NIL
    ((33.278953 16.989254 0 0 -1.6737628 -11.935539 )
     (32.442077 11.021486 -1.6737628 -11.935539 2.36881447 11.677698 )
     (31.95272 4.9247961 0.695052028 -0.257840454 16.198501 -10.775257 )
     (40.747024 -0.720674277 16.893554 -11.033098 -37.162834 7.42333985 )
     (39.059166 -8.0421009 -20.269279 -3.6097579 18.4528389 -6.9181099 )
     (28.016304 -15.110916 -1.816437 -10.527868 -12.6485328 14.249101 )
     (19.875598 -18.514232 -14.464971 3.72123432 14.141298 -8.07830239 )
     (12.481279 -18.832149 -0.323671937 -4.35706902 -7.91666699 -5.9358902 )
     (8.19927407 -26.157165 -8.24033929 -10.292959 -0.474626541 1.82187271 )
     (-0.278379440 -35.539184 -8.7149658 -8.4710865 3.8151741 22.648395 )
     (-7.0857582 -32.686073 -4.89979172 14.1773109 -14.786075 -20.415466 )
     (-19.378585 -28.716499 -19.685867 -6.2381563 19.329124 23.013469 )
     (-29.39989 -23.447917 -0.356739759 16.775314 -2.53043222 -11.6384296 )
     (-31.021846 -12.491817 -2.88717222 5.13688374 -21.207397 -0.459736824 )
     (-44.512718 -7.58480263 -24.09457 4.6771469 33.36003 7.47737885 )
     (-51.927269 0.831033350 9.26546289 12.1545257 -4.23274899 -5.4497776 )
     (-44.778183 10.2606697 5.03271389 6.70474816 13.570957 -3.67826986 )
     (-32.959983 15.126283 18.603672 3.02647829 -14.051084 2.16285753 )
     (-21.381855 19.234191 4.55258656 5.18933583 6.63338948 -10.9731578 )
     (-13.512575 18.936946 11.185976 -5.783823 -6.4824705 17.729778 )
     (-5.56783486 22.018013 4.7035055 11.945955 -4.7035055 -11.945955 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 66Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 12:40:25)
 (MADE-FROM gachan.cu 0 140 0 0)
 (SPLINES

  ((11
    ((314 260) (306 281) (287 297) (251 308) (210 307) (174 303)
     (144 291) (125 271) (117 255) (113 235) (110 192))
    NIL
    ((-6.15634823 22.203887 0 0 -11.0619106 -7.2233467 )
     (-11.687303 18.592216 -11.0619106 -7.2233467 -10.6904468 6.11673546 )
     (-28.094436 14.427236 -21.752357 -1.10661101 17.823703 -17.243595 )
     (-40.934944 4.6988287 -3.92865229 -18.350208 11.39562 20.857646 )
     (-39.165779 -3.2225542 7.4669695 2.50744152 -3.40619659 -12.186998 )
     (-33.401908 -6.80861188 4.0607729 -9.6795578 8.2291622 -2.10965156 )
     (-25.226558 -17.542995 12.289936 -11.789209 0.489543915 20.625602 )
     (-12.6918487 -19.019401 12.7794799 8.83639527 -10.1873417 -8.39276696 )
     (-5.00603962 -14.3793907 2.59213829 0.443627298 -1.74017286 -35.054527 )
     (-3.283988 -31.463031 0.851965309 -34.6109 -0.851965309 34.6109 ))
    NATURAL)
   (33
    ((110 192) (143 210) (181 220) (232 225) (279 222) (310 213)
     (337 199) (357 180) (370 153) (376 124) (373 91) (363 60)
     (334 29) (289 8) (226 -1) (174 6) (135 20) (105 40)
     (87 60) (70 98) (64 164) (69 221) (76 252) (91 283)
     (111 306) (139 323) (177 335) (235 338) (279 333) (309 323)
     (331 309) (351 286) (357 260))
    NIL
    ((32.591583 19.91341 0 0 2.45046902 -11.480478 )
     (33.816818 14.173172 2.45046902 -11.480478 17.7476539 9.40239717 )
     (45.141113 7.39389229 20.198123 -2.07808113 -25.441089 -8.12911416 )
     (52.61869 1.25125384 -5.24296665 -10.207195 -17.983284 5.1140623 )
     (38.384079 -6.39890957 -23.226253 -5.09313298 25.374244 -0.327138901 )
     (27.844951 -11.6556129 2.14799404 -5.42027188 -11.5137119 2.19449425 )
     (24.236091 -15.978637 -9.36571885 -3.22577763 2.68060589 -8.45083619 )
     (16.210674 -23.429832 -6.68511296 -11.6766147 0.791287423 13.608858 )
     (9.9212036 -28.30202 -5.89382553 1.93224478 -5.8457508 -9.9846058 )
     (1.10450172 -31.362079 -11.739576 -8.05236245 10.5917167 14.3295707 )
     (-5.33921623 -32.249656 -1.14785862 6.27720929 -24.521122 -11.333683 )
     (-18.747634 -31.639289 -25.668983 -5.05647373 15.4927768 19.005157 )
     (-36.670234 -27.19318 -10.1762066 13.948686 -19.449962 -4.68696213 )
     (-56.571426 -15.587976 -29.62617 9.26172448 50.307067 11.742685 )
     (-61.044059 -0.454907894 20.6809 21.004409 -7.77833939 -18.283779 )
     (-44.252327 11.4076118 12.902561 2.72062778 -7.19371319 7.39244557 )
     (-34.946617 17.824459 5.708848 10.113073 12.55319 -17.285995 )
     (-22.961177 19.294536 18.262039 -7.17292214 -25.019046 25.751537 )
     (-17.20866 24.997383 -6.7570076 18.578617 21.522995 22.279834 )
     (-13.20417 54.71591 14.765987 40.85845 -1.07293892 -54.870864 )
     (1.02534771 68.13893 13.693048 -14.0124149 -17.231231 -24.796375 )
     (6.10277939 41.728324 -3.53818369 -38.808792 15.997869 52.056388 )
     (10.5635299 28.94773 12.459686 13.2476 -10.760248 -27.429206 )
     (17.643093 28.480728 1.69943738 -14.181606 9.04312516 9.6604328 )
     (23.864093 19.129337 10.742563 -4.52117348 -7.412261 0.787478924 )
     (30.900527 15.001905 3.33030224 -3.73369455 32.605918 -6.81034947 )
     (50.53379 7.86303425 35.936225 -10.544044 -63.011444 2.45392418 )
     (54.964294 -1.45404815 -27.075222 -8.0901203 15.439876 2.99464989 )
     (35.609008 -8.04684258 -11.635345 -5.09547043 1.25195694 3.56747198 )
     (24.599643 -11.3585777 -10.3833885 -1.52799845 15.5522918 -11.264534 )
     (21.992401 -18.51884 5.16890335 -12.7925338 -27.461128 11.490667 )
     (13.43074 -25.566043 -22.292224 -1.30186629 22.292224 1.30186629 ))
    NATURAL)
   (2
    ((357 260) (314 260))
    NIL
    ((-43. 0 0 0 0 0 ))
    NATURAL))

  ((21
    ((113 119) (121 149) (140 172) (164 185) (208 192) (228 194)
     (248 192) (291 185) (314 170) (327 147) (333 117) (330 86)
     (315 57) (290 40) (249 33) (229 31) (209 33) (163 42)
     (134 61) (119 84) (113 119))
    NIL
    ((4.91333866 31.251632 0 0 18.519966 -7.5098009 )
     (14.173322 27.49673 18.519966 -7.5098009 -26.599842 -4.45099545 )
     (19.393367 17.761432 -8.07987596 -11.960796 51.879409 7.3137846 )
     (37.253196 9.45752908 43.799537 -4.64701176 -90.917816 -0.804142953 )
     (35.593818 4.4084463 -47.118286 -5.4511547 47.791908 1.90278578 )
     (12.371492 -0.0913158953 0.673623085 -3.54836893 43.750167 -0.806997777 )
     (34.920204 -4.04318428 44.423797 -4.3553667 -84.792617 -4.6747942 )
     (36.947685 -10.7359466 -40.36882 -9.0301609 37.420303 1.50617122 )
     (15.289024 -19.013023 -2.94851398 -7.52398968 -4.88860703 -1.34988689 )
     (9.8962059 -27.211956 -7.837121 -8.87387658 0.134121895 9.8933773 )
     (2.12614632 -31.139144 -7.7029991 1.01950121 -7.64788056 -2.22362852 )
     (-9.40079309 -31.231456 -15.350879 -1.20412731 12.457403 17.0011329 )
     (-18.522972 -23.935016 -2.893476 15.797006 -30.181732 -5.78090859 )
     (-36.507316 -11.028463 -33.07521 10.016098 72.26953 -5.87750626 )
     (-33.44776 -3.95111895 39.19432 4.13859177 -36.896385 -0.709060669 )
     (-12.701635 -0.167057514 2.29793119 3.4295311 -50.683975 2.71375179 )
     (-35.745689 4.61934948 -48.386047 6.1432829 83.632309 7.85405255 )
     (-42.315582 14.689657 35.24626 13.997335 -25.845264 -16.129955 )
     (-19.991954 20.622013 9.40099526 -2.13262224 1.7487545 20.665775 )
     (-9.71658326 28.82228 11.1497497 18.533153 -11.1497497 -18.533153 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 67Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 12:42:36)
 (MADE-FROM gachan.cu 0 140 0 0)
 (SPLINES

  ((3
    ((82 337) (82 337) (82 295))
    NIL
    ((0 10.5 0 0 0 -63. )
     (0 -21. 0 -63. 0 63. ))
    NATURAL)
   (2
    ((82 295) (317 295))
    NIL
    ((235. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((317 295) (140 0))
    NIL
    ((-177. -295. 0 0 0 0 ))
    NATURAL)
   (2
    ((140 0) (207 0))
    NIL
    ((67. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((207 0) (367 307))
    NIL
    ((160. 307. 0 0 0 0 ))
    NATURAL)
   (2
    ((367 307) (367 337))
    NIL
    ((0 30. 0 0 0 0 ))
    NATURAL)
   (2
    ((367 337) (82 337))
    NIL
    ((-285. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 70Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 12:49:46)
 (MADE-FROM gachan.cu 0 140 0 0)
 (SPLINES

  ((19
    ((291 180) (315 191) (336 207) (351 232) (354 260) (345 290)
     (324 313) (298 326) (259 336) (219 340) (178 336) (139 326)
     (114 313) (93 290) (84 260) (87 232) (102 207) (123 191)
     (147 180))
    NIL
    ((24.558052 10.265171 0 0 -3.34833002 4.4089651 )
     (22.883888 12.469654 -3.34833002 4.4089651 -1.25834989 7.95517254 )
     (18.906383 20.856205 -4.60667992 12.3641376 -9.61826898 -12.229656 )
     (9.49056817 27.105514 -14.2249489 0.134480089 3.73142815 4.96345997 )
     (-2.86866617 29.721725 -10.4935207 5.09794045 -5.3074398 -13.624183 )
     (-16.015907 28.007572 -15.80096 -8.5262432 17.498333 -4.46672058 )
     (-23.067699 17.247966 1.69737339 -12.9929638 -22.685901 13.4910698 )
     (-32.713279 11.0005397 -20.988529 0.498106360 25.245277 -7.49756528 )
     (-41.07917 7.74986458 4.25675106 -6.99945927 -6.2952261 -1.50080967 )
     (-39.97003 -4.76837158E-7 -2.03847551 -8.50026895 -0.0643725395 1.50080967 )
     (-42.040695 -7.74986458 -2.10284805 -6.99945927 24.552715 7.49756528 )
     (-31.867183 -11.0005397 22.449867 0.498106659 -26.146499 -13.4910717 )
     (-22.490562 -17.24797 -3.69663239 -12.9929657 20.03329 4.46672249 )
     (-16.170547 -28.007572 16.336658 -8.5262432 -5.98667336 13.624183 )
     (-2.82722759 -29.721725 10.349985 5.09794045 3.91341019 -4.96346092 )
     (9.47946359 -27.105514 14.263395 0.134479522 -9.6669674 12.22966 )
     (18.909374 -20.856205 4.59642697 12.364139 -1.24553394 -7.9551754 )
     (22.883033 -12.469654 3.35089302 4.40896416 -3.35089302 -4.40896416 ))
    NATURAL)
   (21
    ((147 180) (117 170) (87 154) (69 134) (60 100) (67 60)
     (88 34) (114 18) (139 9) (169 2) (219 -2) (268 2)
     (298 9) (324 18) (349 34) (370 60) (378 100) (369 134)
     (351 154) (321 170) (291 180))
    NIL
    ((-29.24649 -8.45737458 0 0 -4.52104187 -9.25575067 )
     (-31.50701 -13.0852489 -4.52104187 -9.25575067 22.605209 10.278753 )
     (-24.725448 -17.201622 18.084167 1.02300405 -13.899799 -19.859268 )
     (-13.5911808 -26.108253 4.18436814 -18.836265 14.993984 9.15831948 )
     (-1.90981889 -40.365356 19.178352 -9.6779461 -4.07614327 31.225994 )
     (15.230461 -34.430305 15.102209 21.548049 -10.6893997 -14.062305 )
     (24.987968 -19.91341 4.41280842 7.4857435 -7.16625214 1.02323055 )
     (25.817649 -11.9160499 -2.75344372 8.50897409 3.3544116 -8.03062058 )
     (24.741413 -7.42238618 0.600968123 0.478352726 29.7486 1.09926128 )
     (40.216682 -6.3944025 30.34957 1.57761407 -32.348823 9.63357545 )
     (54.391838 7.15255737E-7 -1.99925756 11.211191 -26.353275 -9.63357736 )
     (39.215942 6.3944025 -28.352535 1.57761335 29.761928 -1.09926057 )
     (25.744373 7.42238618 1.40939593 0.478352666 -2.69444275 8.03062058 )
     (25.806549 11.9160499 -1.28504705 8.50897409 -0.984160424 -1.02323150 )
     (24.029418 19.91341 -2.26920748 7.48574258 -11.3689117 14.062307 )
     (16.075756 34.430305 -13.63812 21.548049 -7.5401821 -31.225994 )
     (-1.3324542 40.365356 -21.178302 -9.6779461 17.529632 -9.15831567 )
     (-13.745939 26.108249 -3.64866877 -18.836261 -14.57835 19.859264 )
     (-24.683784 17.201622 -18.22702 1.02300405 22.783775 -10.278753 )
     (-31.518917 13.0852489 4.55675507 -9.25575067 -4.55675507 9.25575067 ))
    NATURAL))

  ((9
    ((131 253) (135 224) (156 204) (194 196) (221 194) (244 196)
     (281 204) (302 224) (307 253))
    NIL
    ((0.832658768 -30.649482 0 0 19.004047 9.8969059 )
     (10.334684 -25.701026 19.004047 9.8969059 6.97975159 4.51546479 )
     (32.828605 -13.54639 25.983799 14.41237 -46.923042 -9.9587631 )
     (35.350875 -4.1134014 -20.939247 4.45360756 12.712442 -0.680411816 )
     (20.767856 1.59256160E-7 -8.22680474 3.77319574 38.073265 0.680411816 )
     (31.577686 4.11340237 29.846466 4.45360756 -57.005523 9.9587612 )
     (32.921386 13.546392 -27.159057 14.4123687 9.94882585 -4.51546097 )
     (10.7367439 25.70103 -17.210231 9.8969078 17.210231 -9.8969078 ))
    NATURAL)
   (9
    ((307 253) (298 283) (274 300) (244 307) (221 309) (194 307)
     (164 300) (140 283) (131 253))
    NIL
    ((-5.5618553 32.845359 0 0 -20.628864 -17.072162 )
     (-15.876289 24.309276 -20.628864 -17.072162 13.144329 7.36082268 )
     (-29.932987 10.917524 -7.4845352 -9.71133996 22.051544 5.6288662 )
     (-26.39175 4.02061749 14.5670089 -4.08247376 -23.350509 0.123711586 )
     (-23.5 -3.18512320E-7 -8.78350259 -3.95876217 5.3505125 -0.123711586 )
     (-29.608245 -4.02061844 -3.4329896 -4.08247376 7.94845296 -5.6288662 )
     (-29.067009 -10.917526 4.51546383 -9.71133996 16.855667 -7.36082268 )
     (-16.12371 -24.309276 21.371131 -17.072162 -21.371131 17.072162 ))
    NATURAL))

  ((11
    ((105 98) (113 128) (132 147) (155 158) (194 164) (220 165)
     (244 164) (283 158) (305 147) (325 128) (332 98))
    NIL
    ((4.97496033 32.444747 0 0 18.150238 -14.668506 )
     (14.050081 25.110496 18.150238 -14.668506 -24.751201 7.34253979 )
     (19.824714 14.113258 -6.6009655 -7.32596684 38.854583 3.2983427 )
     (32.651046 8.4364624 32.253624 -4.02762413 -58.667167 -2.53591156 )
     (35.571083 3.14088345 -26.413543 -6.5635357 21.814094 6.84530354 )
     (20.06459 -7.96280801E-8 -4.59944725 0.281768083 37.410774 -6.84530354 )
     (34.170532 -3.14088392 32.811332 -6.5635357 -69.457214 2.53591251 )
     (32.25325 -8.4364643 -36.645889 -4.02762318 48.41812 -3.2983427 )
     (19.816429 -14.113258 11.7722377 -7.32596589 -34.215293 -7.34254265 )
     (14.481018 -25.110496 -22.443058 -14.668508 22.443058 14.668508 ))
    NATURAL)
   (11
    ((332 98) (326 69) (302 47) (275 36) (244 31) (220 29)
     (194 31) (162 36) (135 47) (111 69) (105 98))
    NIL
    ((-1.27926373 -30.190605 0 0 -28.324417 7.14364625 )
     (-15.441473 -26.618782 -28.324417 7.14364625 33.622093 6.2817669 )
     (-26.954841 -16.334251 5.29768086 13.425413 -16.163986 -8.2707176 )
     (-29.739154 -7.04419804 -10.866306 5.1546955 25.033847 -3.19889402 )
     (-28.088535 -3.48895025 14.167543 1.95580148 -17.971408 3.06629705 )
     (-22.906696 3.18512320E-7 -3.80386734 5.02209854 -7.1482048 -3.06629753 )
     (-30.284668 3.48895025 -10.952072 1.95580101 22.564231 3.19889545 )
     (-29.954624 7.044199 11.6121616 5.15469647 -17.1087379 8.2707157 )
     (-26.896831 16.334251 -5.4965763 13.425413 33.870712 -6.2817669 )
     (-15.4580459 26.618782 28.374141 7.14364625 -28.374141 -7.14364625 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 71Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 12:58:42)
 (MADE-FROM gachan.cu 0 140 0 0)
 (SPLINES

  ((2
    ((118 77) (75 77))
    NIL
    ((-43. 0 0 0 0 0 ))
    NATURAL)
   (32
    ((75 77) (81 51) (100 28) (123 14) (153 4) (196 -1)
     (255 2) (294 13) (321 31) (340 54) (355 85) (363 116)
     (367 173) (364 239) (351 277) (333 297) (303 317) (264 331)
     (205 338) (142 329) (97 308) (67 277) (55 246) (54 213)
     (60 184) (75 157) (109 130) (153 115) (199 112) (260 118)
     (302 131) (322 145))
    NIL
    ((2.70768738 -26.21757 0 0 19.753875 1.30543661 )
     (12.584625 -25.564853 19.753875 1.30543661 -20.769386 11.472816 )
     (21.953807 -18.523006 -1.01551056 12.778253 9.32367517 -11.1967029 )
     (25.600135 -11.343107 8.3081646 1.58154917 1.47467994 3.31399965 )
     (34.645637 -8.10455705 9.78284455 4.89554882 20.77761 3.94070339 )
     (54.81729 -1.23865676 30.560455 8.8362522 -66.585128 -1.07681560 )
     (52.085174 7.0591879 -36.024673 7.7594366 29.562927 0.366560936 )
     (30.841968 15.001905 -6.46174336 8.12599755 -3.66660023 -6.3894329 )
     (22.546924 19.933185 -10.1283435 1.73656463 9.1034622 13.191175 )
     (16.970314 28.265338 -1.02488088 14.92774 -8.7472496 -28.375263 )
     (11.5718078 29.005447 -9.77213098 -13.447525 7.88553906 52.309883 )
     (5.7424469 41.712867 -1.88659143 38.862358 -4.79491043 -24.864299 )
     (1.45840072 68.143066 -6.68150235 13.998058 -6.70589734 -54.852653 )
     (-8.5760498 54.714805 -13.3873996 -40.854599 13.6184997 22.274959 )
     (-15.154197 24.997684 0.231101900 -18.579639 -17.768104 25.752807 )
     (-23.807151 19.294448 -17.537006 7.17316819 15.4539318 -17.286197 )
     (-33.617187 17.824516 -2.08307314 -10.113031 -26.047618 7.3919878 )
     (-48.724075 11.407478 -28.130695 -2.72104311 22.736557 -18.2817459 )
     (-65.48648 -0.454440713 -5.39413643 -21.002792 31.101375 11.7350216 )
     (-55.329933 -15.589721 25.70724 -9.26777078 -15.14208 -4.65834809 )
     (-37.193733 -27.186668 10.5651607 -13.9261188 11.466947 18.898368 )
     (-20.895099 -31.6636 22.032108 4.97225094 -12.725717 -10.9351349 )
     (-5.2258501 -32.158912 9.30639077 -5.9628849 -2.5640707 12.842174 )
     (2.7985053 -31.700714 6.74232007 6.87928963 -1.01799202 -4.43356228 )
     (9.03182984 -27.038208 5.72432804 2.44572735 18.636032 -7.1079273 )
     (24.074176 -28.146442 24.360363 -4.66219998 -13.526155 20.865268 )
     (41.671463 -22.376003 10.8342075 16.203071 -18.53141 -4.35317803 )
     (43.239959 -8.34952165 -7.69720364 11.849893 39.651802 -3.45254517 )
     (55.368667 1.77409935 31.954605 8.3973484 -62.075828 0.163358688 )
     (56.285354 10.253126 -30.121227 8.5607071 4.65153504 -9.20088388 )
     (28.489894 14.213392 -25.469692 -0.640176893 25.469692 0.640176893 ))
    NATURAL)
   (12
    ((322 145) (319 102) (314 82) (307 66) (287 46) (262 36)
     (226 33) (196 33) (162 36) (141 44) (126 58) (118 77))
    NIL
    ((-2.36525059 -48.755897 0 0 -3.80849552 34.535408 )
     (-4.26949787 -31.488193 -3.80849552 34.535408 7.0424776 -34.67704 )
     (-4.55675507 -14.291311 3.23398209 -0.141639173 -24.361415 -9.8272133 )
     (-13.5034828 -19.346557 -21.127433 -9.968853 24.403202 25.985908 )
     (-22.429313 -16.322452 3.27577066 16.017055 -25.251411 -10.1164398 )
     (-31.77925 -5.36361695 -21.975643 5.90061569 40.602447 -3.52014017 )
     (-33.453666 -1.22307181 18.626808 2.38047552 -35.158393 0.197004795 )
     (-32.406059 1.25590610 -16.531585 2.57748031 40.031112 2.73212242 )
     (-28.922084 5.19944763 23.49953 5.30960274 -22.966072 0.874502183 )
     (-16.90559 10.946302 0.533458472 6.1841049 9.83317567 -0.230131149 )
     (-11.455543 17.0153389 10.366634 5.95397377 -10.366634 -5.95397377 ))
    NATURAL))

  ((11
    ((323 220) (316 188) (295 164) (268 150) (226 145) (202 143)
     (179 145) (138 152) (115 166) (99 190) (93 220))
    NIL
    ((-3.30784607 -33.58744 0 0 -22.152923 9.52467538 )
     (-14.3843078 -28.825103 -22.152923 9.52467538 26.764621 0.376617432 )
     (-23.154918 -19.112121 4.61169815 9.9012928 -36.905563 0.968858719 )
     (-36.996009 -8.72639848 -32.293869 10.870151 66.857666 -10.252054 )
     (-35.861038 -2.98227548 34.563797 0.618097306 -32.525123 4.039361 )
     (-17.559806 -0.344497323 2.03867292 4.6574583 -38.757156 0.0946092606 )
     (-34.899719 4.36026573 -36.71849 4.75206757 73.553787 1.58220005 )
     (-34.841308 9.90343286 36.835304 6.3342676 -39.458053 5.57659245 )
     (-17.735031 19.025997 -2.62274933 11.91086 18.278434 -5.88857556 )
     (-11.218561 27.992569 15.655687 6.0222845 -15.655687 -6.0222845 ))
    NATURAL)
   (11
    ((93 220) (95 251) (111 280) (140 297) (180 307) (204 308)
     (227 306) (274 295) (302 276) (317 253) (323 220))
    NIL
    ((-1.10016107 30.764175 0 0 18.600967 1.4149456 )
     (8.2003212 31.471645 18.600967 1.4149456 -9.00483705 -19.074726 )
     (22.29887 23.349227 9.59613038 -17.659782 11.4183807 14.883974 )
     (37.604187 13.131431 21.014511 -2.7758069 -48.668686 -10.4611778 )
     (34.284355 5.12503529 -27.654178 -13.236986 21.256389 14.9607429 )
     (17.258373 -0.631578923 -6.39778805 1.72375726 53.64311 -13.3817978 )
     (37.68215 -5.59872055 47.24533 -11.658041 -85.8289 2.5664463 )
     (42.01303 -15.973539 -38.583572 -9.0915947 31.672523 9.1160202 )
     (19.26572 -20.507122 -6.91104603 0.0244256891 -4.86119175 -15.0305309 )
     (9.924078 -27.997962 -11.7722377 -15.006105 11.7722377 15.006105 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/GACHAE.S1-SF b/obsolete/lispusers/splinefonts/GACHAE.S1-SF
deleted file mode 100644
index 8a13afa8..00000000
--- a/obsolete/lispusers/splinefonts/GACHAE.S1-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY gacha)
 (CHARACTER 40Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 13-SEP-77 15:50:28)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES))

((FAMILY gacha)
 (CHARACTER 30Q)
 (FACE M R E)
 (WIDTH 0 0)
 (FIDUCIAL 480 480)
 (VERSION 0 13-SEP-77 15:52:00)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((3
    ((0 -112) (0 -112) (441 -112))
    NIL
    ((-110.25 0 0 0 661.5 0 )
     (220.5 0 661.5 0 -661.5 0 ))
    NATURAL)
   (2
    ((441 -112) (441 -76))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((441 -76) (0 -76))
    NIL
    ((-441. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((0 -76) (0 -112))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 41Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 13:12:55)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((13
    ((219 -4) (231 -3) (251 9) (261 29) (251 49) (231 61)
     (219 62) (207 61) (187 49) (177 29) (187 9) (207 -3)
     (219 -4))
    NIL
    ((9.72938157 0.167401611 -0.927834511 -5.42605019 16.407211 21.273738 )
     (17.005153 5.3782215 15.479379 15.84769 -28.469066 -7.81240464 )
     (18.249996 17.319709 -12.9896869 8.03528596 -10.530931 -8.02412416 )
     (-0.00515493005 21.342933 -23.520618 0.0111602712 10.5927848 -8.09108735 )
     (-18.229381 17.3085479 -12.927833 -8.07992745 28.15979 -7.61152077 )
     (-17.077316 5.42286206 15.231958 -15.691448 -15.231958 20.53717 )
     (-9.46133996 0 -5.11072471E-7 4.8457241 -15.231954 -20.53717 )
     (-17.07732 -5.42286206 -15.231956 -15.691448 28.15979 7.61152077 )
     (-18.229377 -17.3085479 12.927833 -8.07992745 10.592781 8.09108735 )
     (-0.00515333563 -21.342933 23.520614 0.0111602917 -10.5309238 8.02412416 )
     (18.25 -17.319709 12.9896908 8.03528596 -28.46907 7.81240464 )
     (17.005153 -5.3782215 -15.479381 15.84769 16.407215 -21.273738 ))
    PSEUDOCYCLIC))))

((FAMILY gacha)
 (CHARACTER 42Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 13:18:48)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((8
    ((137 197) (130 223) (122 248) (115 273) (112 296) (114 313)
     (126 331) (147 338))
    NIL
    ((-6.72208787 26.270351 0 0 -1.66746807 -1.62212276 )
     (-7.55582238 25.459289 -1.66746807 -1.62212276 2.33734083 2.1106143 )
     (-8.05461885 24.892475 0.669872761 0.488491952 4.31810379 -0.820336819 )
     (-5.2256956 24.970798 4.98797703 -0.331844926 -1.60975694 -10.8292656 )
     (-1.04259658 19.224319 3.37822008 -11.1611118 8.12091828 20.137405 )
     (6.39608384 18.131912 11.4991397 8.97629548 -0.873926163 -27.720367 )
     (17.458259 13.248024 10.6252136 -18.7440719 -10.6252136 18.7440719 ))
    NATURAL)
   (8
    ((147 338) (168 331) (180 313) (182 296) (179 273) (172 248)
     (164 223) (157 197))
    NIL
    ((22.770866 -3.875988 0 0 -10.6252136 -18.7440719 )
     (17.458259 -13.248024 -10.6252136 -18.7440719 -0.873926163 27.720367 )
     (6.39608288 -18.131912 -11.4991397 8.97629548 8.12091828 -20.137409 )
     (-1.04259729 -19.224319 -3.37822008 -11.1611137 -1.60975599 10.829267 )
     (-5.2256956 -24.970798 -4.98797608 -0.331844509 4.31810284 0.820336342 )
     (-8.05461885 -24.892475 -0.669872761 0.488491833 2.33734083 -2.1106143 )
     (-7.55582238 -25.459289 1.66746831 -1.62212276 -1.66746831 1.62212276 ))
    NATURAL)
   (2
    ((157 197) (137 197))
    NIL
    ((-20. 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((302 197) (282 197))
    NIL
    ((-20. 0 0 0 0 0 ))
    NATURAL)
   (8
    ((282 197) (275 223) (267 248) (260 273) (257 296) (259 313)
     (271 331) (292 338))
    NIL
    ((-6.72208787 26.270351 0 0 -1.66746807 -1.62212276 )
     (-7.55582238 25.459289 -1.66746807 -1.62212276 2.33734083 2.1106143 )
     (-8.05461885 24.892475 0.669872761 0.488491952 4.31810379 -0.820336819 )
     (-5.2256956 24.970798 4.98797703 -0.331844926 -1.60975694 -10.8292656 )
     (-1.04259658 19.224319 3.37822008 -11.1611118 8.12091828 20.137405 )
     (6.39608384 18.131912 11.4991397 8.97629548 -0.873926163 -27.720367 )
     (17.458259 13.248024 10.6252136 -18.7440719 -10.6252136 18.7440719 ))
    NATURAL)
   (8
    ((292 338) (313 331) (325 313) (327 296) (324 273) (317 248)
     (309 223) (302 197))
    NIL
    ((22.770866 -3.875988 0 0 -10.6252136 -18.7440719 )
     (17.458259 -13.248024 -10.6252136 -18.7440719 -0.873926163 27.720367 )
     (6.39608288 -18.131912 -11.4991397 8.97629548 8.12091828 -20.137409 )
     (-1.04259729 -19.224319 -3.37822008 -11.1611137 -1.60975599 10.829267 )
     (-5.2256956 -24.970798 -4.98797608 -0.331844509 4.31810284 0.820336342 )
     (-8.05461885 -24.892475 -0.669872761 0.488491833 2.33734083 -2.1106143 )
     (-7.55582238 -25.459289 1.66746831 -1.62212276 -1.66746831 1.62212276 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 43Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 13:21:04)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((2
    ((39 0) (90 0))
    NIL
    ((51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((90 0) (144 113))
    NIL
    ((54. 113. 0 0 0 0 ))
    NATURAL)
   (2
    ((144 113) (246 113))
    NIL
    ((102. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((246 113) (192 0))
    NIL
    ((-54. -113. 0 0 0 0 ))
    NATURAL)
   (2
    ((192 0) (243 0))
    NIL
    ((51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((243 0) (297 113))
    NIL
    ((54. 113. 0 0 0 0 ))
    NATURAL)
   (2
    ((297 113) (393 113))
    NIL
    ((96. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((393 113) (393 148))
    NIL
    ((0 35. 0 0 0 0 ))
    NATURAL)
   (2
    ((393 148) (313 148))
    NIL
    ((-80. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((313 148) (337 198))
    NIL
    ((24. 50. 0 0 0 0 ))
    NATURAL)
   (2
    ((337 198) (415 198))
    NIL
    ((78. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((415 198) (417 232))
    NIL
    ((2. 34. 0 0 0 0 ))
    NATURAL)
   (2
    ((417 232) (354 232))
    NIL
    ((-63. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((354 232) (405 337))
    NIL
    ((51. 105. 0 0 0 0 ))
    NATURAL)
   (2
    ((405 337) (354 337))
    NIL
    ((-51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((354 337) (303 232))
    NIL
    ((-51. -105. 0 0 0 0 ))
    NATURAL)
   (2
    ((303 232) (201 232))
    NIL
    ((-102. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((201 232) (252 337))
    NIL
    ((51. 105. 0 0 0 0 ))
    NATURAL)
   (2
    ((252 337) (201 337))
    NIL
    ((-51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((201 337) (150 232))
    NIL
    ((-51. -105. 0 0 0 0 ))
    NATURAL)
   (2
    ((150 232) (54 232))
    NIL
    ((-96. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((54 232) (54 197))
    NIL
    ((0 -35. 0 0 0 0 ))
    NATURAL)
   (2
    ((54 197) (133 197))
    NIL
    ((79. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((133 197) (109 147))
    NIL
    ((-24. -50. 0 0 0 0 ))
    NATURAL)
   (2
    ((109 147) (31 147))
    NIL
    ((-78. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((31 147) (30 113))
    NIL
    ((-1. -34. 0 0 0 0 ))
    NATURAL)
   (2
    ((30 113) (93 113))
    NIL
    ((63. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((93 113) (39 0))
    NIL
    ((-54. -113. 0 0 0 0 ))
    NATURAL))

  ((2
    ((184 197) (160 147))
    NIL
    ((-24. -50. 0 0 0 0 ))
    NATURAL)
   (2
    ((160 147) (262 147))
    NIL
    ((102. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((262 147) (286 197))
    NIL
    ((24. 50. 0 0 0 0 ))
    NATURAL)
   (2
    ((286 197) (184 197))
    NIL
    ((-102. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 46Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 14:35:37)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((4
    ((107 270) (123 246) (161 212) (174 202))
    NIL
    ((8.46666719 -19.733333 0 0 45.199996 -25.599998 )
     (31.066665 -32.533332 45.199996 -25.599998 -93.999984 67.999984 )
     (29.266662 -24.133331 -48.799995 42.399993 48.799995 -42.399993 ))
    NATURAL)
   (13
    ((174 202) (197 214) (222 228) (247 246) (259 270) (253 289)
     (235 303) (205 308) (182 310) (158 308) (131 303) (113 289)
     (107 270))
    NIL
    ((22.63285 11.613859 0 0 2.202878 2.31683636 )
     (23.73429 12.7722778 2.202878 2.31683636 0.985608578 0.415817738 )
     (26.429973 15.2970237 3.18848658 2.73265409 -18.145309 8.01989175 )
     (20.545803 22.039623 -14.956825 10.752546 -6.4043541 -20.495391 )
     (2.38680172 22.544475 -21.361179 -9.74284555 13.7627258 7.9616804 )
     (-12.0930137 16.7824669 -7.5984535 -1.78116488 -12.646549 -11.3513279 )
     (-26.014743 9.3256397 -20.245002 -13.1324939 36.82347 13.4436359 )
     (-27.848007 2.91496467 16.578468 0.311142981 -20.647338 -6.42321969 )
     (-21.593212 0.0144983027 -4.0688715 -6.11207677 -2.23410892 6.24923993 )
     (-26.779136 -2.97295809 -6.30298043 0.137163698 17.583774 -12.57374 )
     (-24.290229 -9.1226635 11.280794 -12.4365768 3.8990078 8.04572106 )
     (-11.0599327 -17.53638 15.1798019 -4.39085484 -15.1798019 4.39085484 ))
    NATURAL))

  ((15
    ((129 183) (72 242) (61 280) (73 309) (97 326) (132 339)
     (183 344) (234 339) (268 326) (291 309) (302 280) (294 242)
     (270 214) (238 196) (200 177))
    NIL
    ((-67.869125 64.199096 0 0 65.214828 -31.194587 )
     (-35.261718 48.601799 65.214828 -31.194587 -50.074157 29.972938 )
     (4.91602898 32.393684 15.1406707 -1.22164702 -2.91818809 -16.697174 )
     (18.597606 22.823448 12.2224827 -17.918823 -4.25308895 18.815761 )
     (28.693542 14.312507 7.96939374 0.896939040 13.930542 -10.56587 )
     (43.628204 9.92650987 21.899936 -9.66893197 -21.469078 -0.552272797 )
     (54.7936 -0.0185569115 0.430855572 -10.2212047 -24.054214 0.774955750 )
     (43.197349 -9.85228349 -23.623359 -9.446249 15.6859588 9.4524574 )
     (27.416969 -14.5723037 -7.93739987 0.00620953180 -2.68962955 -14.584795 )
     (18.134754 -21.858493 -10.627029 -14.578586 -10.927448 0.886726380 )
     (2.04400062 -35.993713 -21.554477 -13.69186 4.39942932 29.03789 )
     (-17.31076 -35.166626 -17.155048 15.346033 11.329729 -3.0383091 )
     (-28.800945 -21.339752 -5.82531929 12.307724 -1.71835041 -16.884651 )
     (-35.485443 -17.474353 -7.5436697 -4.57693005 7.5436697 4.57693005 ))
    NATURAL)
   (2
    ((200 177) (318 80))
    NIL
    ((118. -97. 0 0 0 0 ))
    NATURAL)
   (6
    ((318 80) (335 99) (346 114) (356 130) (368 156) (372 178))
    NIL
    ((18.459327 19.933013 0 0 -8.75597955 -5.5980854 )
     (14.0813389 17.133968 -8.75597955 -5.5980854 7.77990246 3.99043036 )
     (9.21531106 13.531099 -0.976076246 -1.60765481 7.63636208 19.63636 )
     (12.057415 21.741626 6.66028596 18.028705 -20.325355 -28.53588 )
     (8.5550232 25.502391 -13.665069 -10.507175 13.665069 10.507175 ))
    NATURAL)
   (2
    ((372 178) (421 178))
    NIL
    ((49. 0 0 0 0 0 ))
    NATURAL)
   (6
    ((421 178) (412 145) (396 115) (373 85) (361 74) (346 59))
    NIL
    ((-7.85167409 -34.186599 0 0 -6.88995267 7.1196165 )
     (-11.2966499 -30.626792 -6.88995267 7.1196165 -7.5502367 -17.598083 )
     (-21.961719 -32.306213 -14.440189 -10.4784679 37.090904 45.27272 )
     (-17.856456 -20.148323 22.650714 34.794258 -32.813392 -49.49282 )
     (-11.61244 -10.100477 -10.1626777 -14.698564 10.1626777 14.698564 ))
    NATURAL)
   (2
    ((346 59) (424 0))
    NIL
    ((78. -59. 0 0 0 0 ))
    NATURAL)
   (2
    ((424 0) (352 0))
    NIL
    ((-72. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((352 0) (309 32))
    NIL
    ((-43. 32. 0 0 0 0 ))
    NATURAL)
   (12
    ((309 32) (270 11) (228 -2) (163 -8) (105 0) (63 18)
     (37 45) (28 84) (40 124) (64 150) (94 168) (129 183))
    NIL
    ((-39.917266 -22.867206 0 0 5.50363159 11.2032489 )
     (-37.16545 -17.265583 5.50363159 11.2032489 -45.518158 -8.0162468 )
     (-54.420906 -10.070457 -40.014526 3.18700123 56.569015 14.861742 )
     (-66.150909 0.547416330 16.554489 18.048744 -0.757925034 -9.4307308 )
     (-49.975395 13.880794 15.796564 8.61801339 0.462682724 -1.13881588 )
     (-33.947486 21.929401 16.2592468 7.4791975 -1.09281921 7.98599148 )
     (-18.234645 33.401596 15.166427 15.4651889 9.90859605 -12.805143 )
     (1.88607931 42.46421 25.075023 2.66004515 -14.5415477 -22.765411 )
     (19.690326 33.741546 10.5334758 -20.105369 -5.74240303 13.866802 )
     (27.3526 20.56958 4.79107285 -6.23856736 1.51115894 3.29820967 )
     (32.899253 15.9801178 6.30223179 -2.94035768 -6.30223179 2.94035768 ))
    NATURAL))

  ((10
    ((277 52) (243 38) (192 25) (147 26) (111 37) (86 53)
     (72 82) (81 112) (105 133) (150 157))
    NIL
    ((-29.138164 -13.446022 0 0 -29.170993 -3.32386208 )
     (-43.723663 -15.107954 -29.170993 -3.32386208 43.854972 22.619308 )
     (-50.96717 -7.12215996 14.683979 19.295448 -8.2489071 -9.15338517 )
     (-40.407638 7.59659577 6.43507195 10.142063 7.14065743 -10.0057678 )
     (-30.40224 12.735775 13.575729 0.136293560 -8.3137245 19.176464 )
     (-20.983375 22.460304 5.26200485 19.312759 26.114242 -18.700103 )
     (-2.66424894 32.423004 31.376247 0.612653733 -24.143245 -16.376026 )
     (16.640373 24.847648 7.23299885 -15.763374 22.458747 24.204216 )
     (35.102745 21.186382 29.691749 8.44084359 -29.691749 -8.44084359 ))
    NATURAL)
   (2
    ((150 157) (277 52))
    NIL
    ((127. -105. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 47Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 14:38:09)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((8
    ((210 197) (203 223) (195 248) (188 273) (185 296) (187 313)
     (199 331) (220 338))
    NIL
    ((-6.72208787 26.270351 0 0 -1.66746807 -1.62212276 )
     (-7.55582238 25.459289 -1.66746807 -1.62212276 2.33734083 2.1106143 )
     (-8.05461885 24.892475 0.669872761 0.488491952 4.31810379 -0.820336819 )
     (-5.2256956 24.970798 4.98797703 -0.331844926 -1.60975694 -10.8292656 )
     (-1.04259658 19.224319 3.37822008 -11.1611118 8.12091828 20.137405 )
     (6.39608384 18.131912 11.4991397 8.97629548 -0.873926163 -27.720367 )
     (17.458259 13.248024 10.6252136 -18.7440719 -10.6252136 18.7440719 ))
    NATURAL)
   (8
    ((220 338) (241 331) (253 313) (255 296) (252 273) (245 248)
     (237 223) (230 197))
    NIL
    ((22.770866 -3.875988 0 0 -10.6252136 -18.7440719 )
     (17.458259 -13.248024 -10.6252136 -18.7440719 -0.873926163 27.720367 )
     (6.39608288 -18.131912 -11.4991397 8.97629548 8.12091828 -20.137409 )
     (-1.04259729 -19.224319 -3.37822008 -11.1611137 -1.60975599 10.829267 )
     (-5.2256956 -24.970798 -4.98797608 -0.331844509 4.31810284 0.820336342 )
     (-8.05461885 -24.892475 -0.669872761 0.488491833 2.33734083 -2.1106143 )
     (-7.55582238 -25.459289 1.66746831 -1.62212276 -1.66746831 1.62212276 ))
    NATURAL)
   (2
    ((230 197) (210 197))
    NIL
    ((-20. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 50Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 14:40:32)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((2
    ((304 350) (256 350))
    NIL
    ((-48. 0 0 0 0 0 ))
    NATURAL)
   (11
    ((256 350) (226 328) (190 291) (160 250) (140 202) (127 121)
     (139 40) (161 -8) (190 -49) (226 -86) (256 -108))
    NIL
    ((-28.149116 -18.291866 0 0 -11.105289 -22.248802 )
     (-33.701759 -29.416267 -11.105289 -22.248802 19.526447 21.244014 )
     (-35.043823 -41.04306 8.42115785 -1.00478410 4.99949837 3.2727251 )
     (-24.12292 -40.411483 13.420656 2.267941 -15.5244369 -52.334915 )
     (-18.464481 -64.311004 -2.10378218 -50.066978 39.098243 50.066978 )
     (-1.01913643 -89.34448 36.994468 0 -32.868583 50.066978 )
     (19.541038 -64.310989 4.1258812 50.066978 2.37611484 -52.334915 )
     (24.854976 -40.411476 6.50199605 -2.26794243 5.3641386 3.27272701 )
     (34.039039 -41.04306 11.8661346 1.00478482 -23.832664 21.244014 )
     (33.988838 -29.416267 -11.9665317 22.248802 11.9665317 -22.248802 ))
    NATURAL)
   (2
    ((256 -108) (304 -108))
    NIL
    ((48. 0 0 0 0 0 ))
    NATURAL)
   (11
    ((304 -108) (274 -86) (238 -49) (210 -8) (187 40) (175 121)
     (189 202) (208 250) (238 291) (274 328) (304 350))
    NIL
    ((-27.892368 18.291866 0 0 -12.6457729 22.248802 )
     (-34.215255 29.416267 -12.6457729 22.248802 27.22887 -21.244014 )
     (-33.246589 41.04306 14.583097 1.00478410 -12.269714 -3.2727251 )
     (-24.798355 40.411483 2.3133831 -2.267941 3.84998512 52.334915 )
     (-20.559978 64.311004 6.16336823 50.066978 32.869773 -50.066978 )
     (2.03827906 89.34448 39.033142 0 -45.3291 -50.066978 )
     (18.406868 64.310989 -6.29596043 -50.066978 22.446659 52.334915 )
     (23.334239 40.411476 16.150699 2.26794243 -8.45755387 -3.27272701 )
     (35.256164 41.04306 7.69314576 -1.00478482 -18.616432 -21.244014 )
     (33.64109 29.416267 -10.923286 -22.248802 10.923286 22.248802 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 51Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 14:42:07)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((11
    ((126 350) (156 328) (192 291) (222 250) (241 202) (255 121)
     (243 40) (220 -8) (192 -49) (156 -86) (126 -108))
    NIL
    ((28.17945 -18.291866 0 0 10.923286 -22.248802 )
     (33.64109 -29.416267 10.923286 -22.248802 -18.616432 21.244014 )
     (35.256164 -41.04306 -7.69314576 -1.00478410 -8.45755769 3.2727251 )
     (23.334239 -40.411483 -16.150703 2.267941 22.446666 -52.334915 )
     (18.406868 -64.311004 6.29596425 -50.066978 -45.329109 50.066978 )
     (2.03827715 -89.34448 -39.033149 0 32.86978 50.066978 )
     (-20.559978 -64.310989 -6.16336537 50.066978 3.84998179 -52.334915 )
     (-24.798355 -40.411476 -2.31338358 -2.26794243 -12.269712 3.27272701 )
     (-33.246589 -41.04306 -14.583097 1.00478482 27.22887 21.244014 )
     (-34.215255 -29.416267 12.6457748 22.248802 -12.6457748 -22.248802 ))
    NATURAL)
   (2
    ((126 -108) (174 -108))
    NIL
    ((48. 0 0 0 0 0 ))
    NATURAL)
   (11
    ((174 -108) (204 -86) (240 -49) (269 -8) (291 40) (303 121)
     (290 202) (270 250) (240 291) (204 328) (174 350))
    NIL
    ((28.005577 18.291866 0 0 11.9665336 22.248802 )
     (33.988838 29.416267 11.9665336 22.248802 -23.832668 -21.244014 )
     (34.039039 41.04306 -11.8661346 1.00478410 5.36413956 -3.2727251 )
     (24.854976 40.411483 -6.50199509 -2.267941 2.37611198 52.334915 )
     (19.541038 64.311004 -4.1258831 50.066978 -32.868583 -50.066978 )
     (-1.01914072 89.34448 -36.994468 0 39.098243 -50.066978 )
     (-18.464481 64.310989 2.10378218 -50.066978 -15.5244369 52.334915 )
     (-24.12292 40.411476 -13.420656 2.26794243 4.99949837 -3.27272701 )
     (-35.043823 41.04306 -8.42115785 -1.00478482 19.526447 -21.244014 )
     (-33.701759 29.416267 11.105289 -22.248802 -11.105289 22.248802 ))
    NATURAL)
   (2
    ((174 350) (126 350))
    NIL
    ((-48. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 52Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 14:50:44)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((49
    ((225 98) (205 106) (196 133) (202 169) (218 201) (186 185)
     (159 162) (132 150) (105 157) (93 184) (111 202) (144 209)
     (203 218) (144 227) (111 234) (93 252) (105 279) (132 286)
     (159 274) (186 251) (218 235) (202 267) (196 303) (205 330)
     (225 338) (245 330) (254 303) (248 267) (232 235) (264 251)
     (291 274) (318 286) (345 279) (357 252) (339 234) (306 227)
     (247 218) (306 209) (339 202) (357 184) (345 157) (318 150)
     (291 162) (264 185) (232 201) (248 169) (254 133) (245 106)
     (225 98))
    NIL
    ((-22.53239 0.0906766206 0.746076346 11.4537448 12.9561367 13.094705 )
     (-15.308248 18.091774 13.702213 24.54845 -3.25714302 -20.196006 )
     (-3.23460579 32.54222 10.44507 4.3524437 24.072422 7.68932534 )
     (19.246673 40.739326 34.517494 12.041769 -123.0325 -88.561279 )
     (-7.7521 8.50045587 -88.515045 -76.519516 120.0577 82.5558 )
     (-36.238273 -26.741153 31.542694 6.03629685 -39.198417 4.33803749 )
     (-24.294792 -18.535835 -7.65572835 10.374334 6.73594475 8.09202767 )
     (-28.582546 -4.11548805 -0.919782878 18.466362 12.254642 11.293846 )
     (-23.375007 19.997795 11.3348598 29.760208 34.245483 -47.267402 )
     (5.08259297 26.124298 45.580345 -17.507198 -59.236595 3.77578545 )
     (21.044639 10.504995 -13.65625 -13.7314129 112.70089 20.164264 )
     (63.738838 6.85571576 99.044647 6.43285275 -325.5669 -6.43285275 )
     (5.08129596E-6 10.0721416 -226.5223 0 325.5669 -6.43285275 )
     (-63.738838 6.8557148 99.044647 -6.43285275 -112.70089 20.164264 )
     (-21.044639 10.504995 -13.6562519 13.7314129 59.2366 3.77578545 )
     (-5.0825901 26.124301 45.580352 17.507198 -34.245513 -47.26741 )
     (23.375003 19.997791 11.3348369 -29.760215 -12.254545 11.293884 )
     (28.582569 -4.11548043 -0.919708253 -18.466331 -6.7362957 8.0918808 )
     (24.294712 -18.535869 -7.65600396 -10.3744506 39.199722 4.33859158 )
     (36.23857 -26.741024 31.543724 -6.0358591 -120.0626 82.55374 )
     (7.75098897 8.49999238 -88.51889 76.51788 123.0507 -88.5536 )
     (-19.24253 40.741066 34.531845 -12.0357227 -24.140338 7.6607275 )
     (3.21914434 32.535705 10.391504 -4.37499523 3.51062012 -20.08929 )
     (15.365957 18.116069 13.902124 -24.464286 -13.902124 12.69643 )
     (22.31702 0 -5.11072471E-7 -11.7678566 -13.90212 -12.69643 )
     (15.365957 -18.116069 -13.902122 -24.464286 3.5106144 20.089286 )
     (3.21914196 -32.535713 -10.391508 -4.37499714 -24.140327 -7.6607256 )
     (-19.24253 -40.741066 -34.531837 -12.0357227 123.0507 88.5536 )
     (7.75099564 -8.49998284 88.518875 76.51788 -120.06259 -82.55374 )
     (36.23857 26.741027 -31.543724 -6.035861 39.199722 -4.33858967 )
     (24.294712 18.535869 7.6560049 -10.3744506 -6.73629666 -8.0918808 )
     (28.582569 4.11547947 0.919708014 -18.466331 -12.254543 -11.293884 )
     (23.375003 -19.997791 -11.3348369 -29.760215 -34.245513 47.26741 )
     (-5.08259106 -26.124298 -45.580352 17.507198 59.2366 -3.77578545 )
     (-21.044643 -10.504995 13.6562538 13.7314129 -112.70089 -20.164264 )
     (-63.738838 -6.85571576 -99.044647 -6.43285275 325.5669 6.43285275 )
     (-5.08129596E-6 -10.0721416 226.5223 0 -325.5669 6.43285275 )
     (63.738838 -6.8557148 -99.044647 6.43285275 112.70089 -20.164264 )
     (21.044639 -10.504995 13.65625 -13.7314129 -59.236595 -3.77578545 )
     (5.08259106 -26.124298 -45.580345 -17.507198 34.245483 47.267402 )
     (-23.375011 -19.997795 -11.334856 29.760204 12.2546367 -11.293842 )
     (-28.582546 4.11548996 0.919782162 18.466362 6.7359457 -8.09202767 )
     (-24.294792 18.535839 7.65572835 10.374334 -39.198417 -4.33804226 )
     (-36.238273 26.741149 -31.542694 6.03629208 120.0577 -82.555786 )
     (-7.75209904 -8.50045968 88.515045 -76.5195 -123.0325 88.56126 )
     (19.246673 -40.739326 -34.517494 12.041765 24.072422 -7.6893215 )
     (-3.2346077 -32.54222 -10.44507 4.3524437 -3.25714302 20.196006 )
     (-15.308248 -18.091774 -13.702213 24.54845 12.9561367 -13.094705 ))
    PSEUDOCYCLIC))))

((FAMILY gacha)
 (CHARACTER 53Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 15:00:01)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((2
    ((195 28) (245 28))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((245 28) (245 143))
    NIL
    ((0 115. 0 0 0 0 ))
    NATURAL)
   (2
    ((245 143) (360 143))
    NIL
    ((115. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((360 143) (360 193))
    NIL
    ((0 50. 0 0 0 0 ))
    NATURAL)
   (2
    ((360 193) (245 193))
    NIL
    ((-115. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((245 193) (245 308))
    NIL
    ((0 115. 0 0 0 0 ))
    NATURAL)
   (2
    ((245 308) (195 308))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((195 308) (195 193))
    NIL
    ((0 -115. 0 0 0 0 ))
    NATURAL)
   (2
    ((195 193) (80 193))
    NIL
    ((-115. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((80 193) (80 143))
    NIL
    ((0 -50. 0 0 0 0 ))
    NATURAL)
   (2
    ((80 143) (195 143))
    NIL
    ((115. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((195 143) (195 28))
    NIL
    ((0 -115. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 54Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 15:04:46)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((20
    ((218 -3) (205 -3) (185 9) (175 29) (181 49) (195 61)
     (213 66) (241 61) (255 50) (263 29) (259 -9) (247 -32)
     (234 -44) (215 -53) (186 -57) (170 -49) (177 -36) (195 -31)
     (215 -21) (218 -3))
    NIL
    ((-10.673479 -2.67581272 0 0 -13.959116 16.054878 )
     (-17.653038 5.3516264 -13.959116 16.054878 27.795578 -8.27439309 )
     (-17.714363 17.269306 13.8364639 7.7804842 4.77679062 -6.95730019 )
     (-1.48950290 21.57114 18.613254 0.823183776 -10.902744 -11.896402 )
     (11.672378 16.446121 7.7105093 -11.073219 -9.1658039 6.54291535 )
     (14.7999859 8.6443615 -1.4552958 -4.53030396 23.565967 -8.275259 )
     (25.127674 -0.0235718079 22.110672 -12.8055629 -49.09806 8.5581188 )
     (22.689312 -8.55007554 -26.987392 -4.2474432 28.826297 -1.95721721 )
     (10.115068 -13.7761268 1.83890605 -6.2046604 -18.207134 -24.729248 )
     (2.8504076 -32.345413 -16.3682289 -30.93391 8.00223924 58.874214 )
     (-9.51670075 -33.842216 -8.36598969 27.940307 10.198177 -18.767623 )
     (-12.7836017 -15.2857189 1.83218932 9.1726837 -6.7949562 -7.80373 )
     (-14.34889 -10.0149 -4.9627676 1.3689537 -13.0183487 1.98254585 )
     (-25.820835 -7.65467358 -17.981117 3.35149956 34.868362 11.8735466 )
     (-26.367767 1.63359928 16.887249 15.225046 11.544872 -7.47673417 )
     (-3.70808268 13.120277 28.43212 7.748312 -21.047866 -23.966606 )
     (14.2001037 8.8852844 7.3842535 -16.218296 0.646611214 25.343174 )
     (21.907661 5.3385763 8.0308647 9.12487985 -35.538574 0.593898773 )
     (12.169237 14.760406 -27.507713 9.7187786 27.507713 -9.7187786 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 55Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 15:07:38)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((2
    ((320 193) (120 193))
    NIL
    ((-200. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((120 193) (120 143))
    NIL
    ((0 -50. 0 0 0 0 ))
    NATURAL)
   (2
    ((120 143) (320 143))
    NIL
    ((200. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((320 143) (320 193))
    NIL
    ((0 50. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 56Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 15:10:01)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((13
    ((218 63) (231 61) (251 49) (261 29) (251 9) (231 -3)
     (218 -5) (205 -3) (185 9) (175 29) (185 49) (205 61)
     (218 63))
    NIL
    ((10.989046 -0.181750595 -0.894697548 1.09114074 14.749813 -14.182918 )
     (17.469253 -6.18206978 13.8551159 -13.0917778 -26.380886 4.36775208 )
     (18.133926 -17.089969 -12.52577 -8.7240257 -11.226255 8.71190835 )
     (-0.00497087091 -21.458042 -23.752025 -0.0121169965 11.285902 8.78460885 )
     (-18.114044 -17.077854 -12.466123 8.77249337 26.082653 4.14965058 )
     (-17.538841 -6.2305355 13.616529 12.9221439 -13.616529 -13.3832149 )
     (-10.730577 9.96515154E-8 0 -0.461072266 -13.616529 13.3832149 )
     (-17.538841 6.23053647 -13.616529 12.9221439 26.082653 -4.14965058 )
     (-18.114044 17.077854 12.466123 8.77249337 11.285898 -8.78460885 )
     (-0.00496927649 21.458042 23.752021 -0.0121165085 -11.2262497 -8.71190835 )
     (18.133926 17.089969 12.525772 -8.7240257 -26.380889 -4.36775208 )
     (17.469253 6.18206883 -13.8551178 -13.0917778 14.749815 14.182918 ))
    PSEUDOCYCLIC))))

((FAMILY gacha)
 (CHARACTER 57Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 15:11:04)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((2
    ((73 0) (321 337))
    NIL
    ((248. 337. 0 0 0 0 ))
    NATURAL)
   (2
    ((321 337) (369 337))
    NIL
    ((48. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((369 337) (121 0))
    NIL
    ((-248. -337. 0 0 0 0 ))
    NATURAL)
   (2
    ((121 0) (73 0))
    NIL
    ((-48. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 73Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 15:15:21)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((13
    ((219 232) (206 230) (186 218) (176 198) (186 178) (206 166)
     (219 164) (232 166) (252 178) (262 198) (252 218) (232 230)
     (219 232))
    NIL
    ((-10.989046 -0.181750595 0.894697548 1.09114074 -14.749813 -14.182918 )
     (-17.469253 -6.18206978 -13.8551159 -13.0917778 26.380886 4.36775208 )
     (-18.133926 -17.089969 12.52577 -8.7240257 11.226255 8.71190835 )
     (0.00497087091 -21.458042 23.752025 -0.0121169965 -11.285902 8.78460885 )
     (18.114044 -17.077854 12.466123 8.77249337 -26.082653 4.14965058 )
     (17.538841 -6.2305355 -13.616529 12.9221439 13.616529 -13.3832149 )
     (10.730577 9.96515154E-8 0 -0.461072266 13.616529 13.3832149 )
     (17.538841 6.23053647 13.616529 12.9221439 -26.082653 -4.14965058 )
     (18.114044 17.077854 -12.466123 8.77249337 -11.285898 -8.78460885 )
     (0.00496927649 21.458042 -23.752021 -0.0121165085 11.2262497 -8.71190835 )
     (-18.133926 17.089969 -12.525772 -8.7240257 26.380889 -4.36775208 )
     (-17.469253 6.18206883 13.8551178 -13.0917778 -14.749815 14.182918 ))
    PSEUDOCYCLIC))

  ((20
    ((218 -3) (215 -21) (195 -31) (177 -36) (170 -49) (186 -57)
     (215 -53) (234 -44) (247 -32) (259 -9) (263 29) (255 50)
     (241 61) (213 66) (195 61) (181 49) (175 29) (185 9)
     (205 -3) (218 -3))
    NIL
    ((1.58461880 -19.619796 0 0 -27.507713 9.7187805 )
     (-12.169239 -14.760406 -27.507713 9.7187805 35.538574 -0.593902588 )
     (-21.907661 -5.3385763 8.0308647 9.1248779 -0.646611214 -25.343174 )
     (-14.2001037 -8.88528634 7.3842535 -16.218296 21.047866 23.966606 )
     (3.70808458 -13.120277 28.43212 7.748312 -11.544872 7.47673417 )
     (26.367767 -1.63359856 16.887249 15.225046 -34.86837 -11.8735466 )
     (25.820831 7.65467358 -17.981121 3.35149956 13.018354 -1.98254537 )
     (14.34889 10.0149 -4.9627657 1.36895418 6.7949543 7.80372716 )
     (12.7836017 15.2857208 1.8321886 9.1726818 -10.198175 18.767623 )
     (9.51670075 33.842208 -8.36598779 27.940307 -8.00224114 -58.874214 )
     (-2.85040808 32.345413 -16.3682289 -30.93391 18.207134 24.729248 )
     (-10.115068 13.7761268 1.83890652 -6.20466138 -28.826297 1.95721817 )
     (-22.689312 8.5500736 -26.987392 -4.2474432 49.09806 -8.5581188 )
     (-25.127674 0.0235716477 22.110672 -12.8055629 -23.565967 8.275259 )
     (-14.7999859 -8.6443615 -1.45529556 -4.53030396 9.1658039 -6.54291535 )
     (-11.672378 -16.446121 7.7105093 -11.073219 10.902744 11.896402 )
     (1.48950433 -21.57114 18.613254 0.823183776 -4.77679062 6.95730019 )
     (17.714363 -17.269306 13.8364639 7.7804842 -27.795578 8.27439309 )
     (17.653038 -5.35162544 -13.959116 16.054878 13.959116 -16.054878 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 72Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 20-SEP-77 15:16:21)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((7
    ((219 164) (206 166) (186 178) (176 198) (186 218) (206 230)
     (219 232))
    NIL
    ((-10.730768 -0.133333206 0 0 -13.615383 12.799999 )
     (-17.538459 6.2666664 -13.615383 12.799999 26.076919 -4. )
     (-18.115383 17.066665 12.461538 8.79999925 11.3076915 -8.79999925 )
     (6.37024641E-7 21.466663 23.769229 0 -11.307693 -8.79999925 )
     (18.115383 17.066665 12.461536 -8.79999925 -26.076919 -4. )
     (17.538459 6.2666664 -13.615383 -12.799999 13.615383 12.799999 ))
    NATURAL)
   (7
    ((219 232) (232 230) (252 218) (262 198) (252 178) (232 166)
     (219 164))
    NIL
    ((10.730768 0.133333206 0 0 13.615383 -12.799999 )
     (17.538459 -6.2666664 13.615383 -12.799999 -26.076919 4. )
     (18.115383 -17.066665 -12.461538 -8.79999925 -11.3076915 8.79999925 )
     (-6.37024641E-7 -21.466663 -23.769229 0 11.307693 8.79999925 )
     (-18.115383 -17.066665 -12.461536 8.79999925 26.076919 4. )
     (-17.538459 -6.2666664 13.615383 12.799999 -13.615383 -12.799999 ))
    NATURAL))

  ((7
    ((219 -3) (206 -1) (186 11) (176 31) (186 51) (206 63)
     (219 65))
    NIL
    ((-10.730768 -0.133333206 0 0 -13.615383 12.799999 )
     (-17.538459 6.2666664 -13.615383 12.799999 26.076919 -4. )
     (-18.115383 17.066665 12.461538 8.79999925 11.3076915 -8.79999925 )
     (6.37024641E-7 21.466663 23.769229 0 -11.307693 -8.79999925 )
     (18.115383 17.066665 12.461536 -8.79999925 -26.076919 -4. )
     (17.538459 6.2666664 -13.615383 -12.799999 13.615383 12.799999 ))
    NATURAL)
   (7
    ((219 65) (232 63) (252 51) (262 31) (252 11) (232 -1)
     (219 -3))
    NIL
    ((10.730768 0.133333206 0 0 13.615383 -12.799999 )
     (17.538459 -6.2666664 13.615383 -12.799999 -26.076919 4. )
     (18.115383 -17.066665 -12.461538 -8.79999925 -11.3076915 8.79999925 )
     (-6.37024641E-7 -21.466663 -23.769229 0 11.307693 8.79999925 )
     (-18.115383 -17.066665 -12.461536 8.79999925 26.076919 4. )
     (-17.538459 -6.2666664 13.615383 12.799999 -13.615383 -12.799999 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 45Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  8:31:26)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((17
    ((118 338) (159 333) (186 321) (201 303) (207 277) (201 251)
     (186 233) (159 221) (118 216) (78 221) (51 233) (36 251)
     (30 277) (36 303) (51 321) (78 333) (118 338))
    NIL
    ((43.632125 -0.0974335671 1.31016326 -11.476913 -19.723274 5.01534176 )
     (35.08065 -9.0666752 -18.413112 -6.4615717 6.75541115 1.78477382 )
     (20.045242 -14.63586 -11.657701 -4.67679787 4.70163059 -6.1544361 )
     (10.7383575 -22.389877 -6.9560709 -10.8312339 -7.56193638 10.832973 )
     (0.00131877139 -27.804622 -14.518007 0.00173969077 7.5461092 10.8225345 )
     (-10.743633 -22.391616 -6.97189809 10.8242759 -4.62250042 -6.1231203 )
     (-20.026783 -14.6289 -11.594398 4.70115566 -7.05610657 1.66994285 )
     (-35.14923 -9.09277345 -18.650505 6.3710985 20.846931 5.4433527 )
     (-43.376274 0 2.19642639 11.814451 13.668373 -5.44335366 )
     (-34.345657 9.09277345 15.864799 6.37109757 -3.52042198 -1.66994095 )
     (-20.241073 14.6289 12.344377 4.70115662 -5.5866909 6.12311745 )
     (-10.6900406 22.391616 6.7576866 10.824274 7.8671856 -10.8225326 )
     (0.00123898312 27.804622 14.624872 0.00174020207 -7.8820505 -10.832975 )
     (10.685085 22.389877 6.7428217 -10.8312358 5.6610155 6.154438 )
     (20.258415 14.63586 12.403837 -4.67679787 3.23799324 -1.78477382 )
     (34.281242 9.0666752 15.64183 -6.4615717 -12.6129837 -5.01534176 ))
    PSEUDOCYCLIC))

  ((13
    ((318 25) (342 29) (364 43) (370 61) (364 79) (342 93)
     (318 96) (294 93) (272 79) (266 61) (272 43) (294 29)
     (318 25))
    NIL
    ((24.01675 0.0585110932 -1.65684819 5.3434658 4.87002945 7.618536 )
     (24.794918 9.21124459 3.2131815 12.9620018 -26.409057 -10.1534767 )
     (14.803571 17.096508 -23.195877 2.80852413 16.766201 -3.00462341 )
     (-0.00920486450 18.402717 -6.42967606 -0.196099460 -16.655742 -1.82802653 )
     (-14.766752 17.292606 -23.085418 -2.02412605 25.856773 -13.683267 )
     (-24.923782 8.42684747 2.77135515 -15.707393 -2.77135515 14.56109 )
     (-23.538105 -8.00937414E-8 -1.27768117E-7 -1.14630294 -2.7713542 -14.56109 )
     (-24.923782 -8.42684747 -2.77135467 -15.707393 25.856773 13.6832657 )
     (-14.766752 -17.292606 23.085418 -2.02412653 -16.655742 1.82802701 )
     (-0.00920422748 -18.402717 6.42967606 -0.196099311 16.766197 3.00462294 )
     (14.803571 -17.096508 23.195873 2.80852365 -26.409053 10.1534767 )
     (24.794918 -9.21124459 -3.21318102 12.9620018 4.8700285 -7.61853696 ))
    PSEUDOCYCLIC))

  ((2
    ((324 337) (73 0))
    NIL
    ((-251. -337. 0 0 0 0 ))
    NATURAL)
   (3
    ((73 0) (73 0) (118 0))
    NIL
    ((-11.25 0 0 0 67.5 0 )
     (22.5 0 67.5 0 -67.5 0 ))
    NATURAL)
   (2
    ((118 0) (369 337))
    NIL
    ((251. 337. 0 0 0 0 ))
    NATURAL)
   (2
    ((369 337) (324 337))
    NIL
    ((-45. 0 0 0 0 0 ))
    NATURAL))

  ((17
    ((319 122) (360 117) (387 105) (402 87) (408 61) (402 35)
     (387 17) (360 5) (319 0) (279 5) (252 17) (237 35)
     (231 61) (237 87) (252 105) (279 117) (319 122))
    NIL
    ((43.632125 -0.0974335671 1.31016326 -11.476913 -19.723274 5.01534176 )
     (35.08065 -9.0666752 -18.413112 -6.4615717 6.75541115 1.78477382 )
     (20.045242 -14.63586 -11.657701 -4.67679787 4.70163059 -6.1544361 )
     (10.7383575 -22.389877 -6.9560709 -10.8312339 -7.56193638 10.832973 )
     (0.00131877139 -27.804622 -14.518007 0.00173969077 7.5461092 10.8225345 )
     (-10.743633 -22.391616 -6.97189809 10.8242759 -4.62250042 -6.1231203 )
     (-20.026783 -14.6289 -11.594398 4.70115566 -7.05610657 1.66994285 )
     (-35.14923 -9.09277345 -18.650505 6.3710985 20.846931 5.4433527 )
     (-43.376274 0 2.19642639 11.814451 13.668373 -5.44335366 )
     (-34.345657 9.09277345 15.864799 6.37109757 -3.52042198 -1.66994095 )
     (-20.241073 14.6289 12.344377 4.70115662 -5.5866909 6.12311745 )
     (-10.6900406 22.391616 6.7576866 10.824274 7.8671856 -10.8225326 )
     (0.00123898312 27.804622 14.624872 0.00174020207 -7.8820505 -10.832975 )
     (10.685085 22.389877 6.7428217 -10.8312358 5.6610155 6.154438 )
     (20.258415 14.63586 12.403837 -4.67679787 3.23799324 -1.78477382 )
     (34.281242 9.0666752 15.64183 -6.4615717 -12.6129837 -5.01534176 ))
    PSEUDOCYCLIC))

  ((13
    ((118 312) (142 309) (164 295) (170 277) (164 259) (142 245)
     (118 241) (94 245) (72 259) (66 277) (72 295) (94 309)
     (118 312))
    NIL
    ((23.538459 -0.330866456 0 0 2.76922989 -16.014801 )
     (24.923076 -8.33826829 2.76922989 -16.014801 -25.846149 14.074016 )
     (14.769228 -17.316059 -23.076919 -1.94078445 16.615379 1.71872663 )
     (-6.37024641E-7 -18.39748 -6.4615383 -0.222057670 -16.615379 3.0510726 )
     (-14.7692318 -17.094001 -23.076919 2.82901525 25.846149 10.0769786 )
     (-24.923076 -9.22649766 2.76923036 12.905994 -2.76922989 -7.35899258 )
     (-23.538459 3.18512320E-7 2.55536235E-7 5.54700184 -2.76923132 7.35899258 )
     (-24.923076 9.22649766 -2.76923132 12.905994 25.846153 -10.0769786 )
     (-14.7692299 17.094001 23.076923 2.82901478 -16.6153869 -3.05107212 )
     (6.37024641E-7 18.39748 6.4615364 -0.222057640 16.6153869 -1.71872687 )
     (14.7692299 17.316059 23.076923 -1.94078469 -25.846153 -14.074014 )
     (24.923076 8.33826638 -2.76923084 -16.014801 2.76923084 16.014801 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 44Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  9:30:26)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((2
    ((236 364) (236 344))
    NIL
    ((0 -20. 0 0 0 0 ))
    NATURAL)
   (7
    ((236 344) (277 339) (309 330) (331 320) (348 309) (363 291)
     (367 260))
    NIL
    ((42.793586 -4. 0 0 -10.7615375 -6. )
     (37.412818 -7. -10.7615375 -6. -0.192308426 6. )
     (26.555126 -9.9999981 -10.9538459 6.81195899E-8 5.5307703 -3.23568030E-7 )
     (18.366664 -10. -5.42307568 -2.55448469E-7 8.0692272 -5.9999981 )
     (16.978202 -13. 2.6461525 -5.99999905 -19.807685 -12. )
     (9.72051049 -25. -17.161533 -18. 17.161533 18. ))
    NATURAL)
   (2
    ((367 260) (329 260))
    NIL
    ((-38. 0 0 0 0 0 ))
    NATURAL)
   (6
    ((329 260) (324 280) (312 294) (288 305) (261 312) (236 316))
    NIL
    ((-3.91866016 21.454544 0 0 -6.488039 -8.72727204 )
     (-7.16267968 17.090908 -6.488039 -8.72727204 -9.5598049 7.63636208 )
     (-18.430622 12.181818 -16.0478439 -1.09090924 14.727268 -3.81818056 )
     (-27.11483 9.1818161 -1.32057404 -4.90909004 4.65071678 1.63636303 )
     (-26.110046 5.090909 3.33014345 -3.27272701 -3.33014345 3.27272701 ))
    NATURAL)
   (2
    ((236 316) (236 197))
    NIL
    ((0 -119. 0 0 0 0 ))
    NATURAL)
   (11
    ((236 197) (280 187) (313 177) (342 161) (366 136) (376 92)
     (370 55) (346 27) (313 9) (274 -1) (236 -6))
    NIL
    ((46.700439 -10.36273 0 0 -16.202648 2.17638588 )
     (38.599113 -9.27453805 -16.202648 2.17638588 15.013242 -10.881929 )
     (29.903087 -12.5391159 -1.18940448 -8.7055435 -1.85032797 5.3513317 )
     (27.78852 -18.568992 -3.03973246 -3.35421133 -13.6119308 -28.523391 )
     (17.942817 -36.184898 -16.651664 -31.877605 2.29807663 48.74224 )
     (2.44018984 -43.691383 -14.353588 16.864639 -7.58037568 -10.4455948 )
     (-15.703586 -32.049545 -21.933963 6.41904355 16.023418 5.0401411 )
     (-29.625843 -23.110427 -5.9105444 11.4591846 -2.51330852 -3.71496868 )
     (-36.793037 -13.508728 -8.4238529 7.74421597 12.0298156 -2.18027019 )
     (-39.20198 -6.8546486 3.60596323 5.56394577 -3.60596323 -5.56394577 ))
    NATURAL)
   (2
    ((236 -6) (236 -35))
    NIL
    ((0 -29. 0 0 0 0 ))
    NATURAL)
   (2
    ((236 -35) (192 -35))
    NIL
    ((-44. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((192 -35) (192 -6))
    NIL
    ((0 29. 0 0 0 0 ))
    NATURAL)
   (6
    ((192 -6) (141 -4) (99 8) (75 23) (55 49) (46 85))
    NIL
    ((-52.143539 -0.626794100 0 0 6.8612442 15.760765 )
     (-48.712913 7.2535877 6.8612442 15.760765 19.693779 -18.803825 )
     (-32.004783 13.61244 26.555023 -3.04306173 -31.63636 17.45454 )
     (-21.26794 19.296649 -5.08133984 14.4114818 22.851673 -3.0143528 )
     (-14.9234447 32.20095 17.770336 11.397129 -17.770336 -11.397129 ))
    NATURAL)
   (2
    ((46 85) (90 85))
    NIL
    ((44. 0 0 0 0 0 ))
    NATURAL)
   (6
    ((90 85) (93 69) (103 49) (127 33) (162 25) (192 22))
    NIL
    ((1.89473676 -14.770334 0 0 6.63157845 -7.37798978 )
     (5.21052647 -18.459327 6.63157845 -7.37798978 8.84210588 12.8899498 )
     (16.2631569 -19.392341 15.473684 5.51196099 -1.90734863E-6 3.81818199 )
     (31.736839 -11.9712906 15.473682 9.33014298 -26.842102 -4.16267872 )
     (33.789466 -4.72248745 -11.3684196 5.16746426 11.3684196 -5.16746426 ))
    NATURAL)
   (2
    ((192 22) (192 159))
    NIL
    ((0 137. 0 0 0 0 ))
    NATURAL)
   (11
    ((192 159) (151 173) (118 185) (93 197) (70 219) (61 263)
     (73 296) (94 315) (124 331) (160 341) (192 344))
    NIL
    ((-42.561904 14.467121 0 0 9.37145997 -2.80273056 )
     (-37.876174 13.0657558 9.37145997 -2.80273056 1.14269447 2.01365328 )
     (-27.933368 11.2698516 10.514154 -0.789076925 -13.9422378 6.74811555 )
     (-24.390335 13.854833 -3.4280839 5.95903874 18.626262 30.993877 )
     (-18.505283 35.310806 15.198179 36.952919 11.437181 -58.72363 )
     (2.41148281 42.901908 26.63536 -21.770717 -22.374977 5.900671 )
     (17.859352 24.081527 4.26038075 -15.870046 6.06273175 17.120952 )
     (25.1511 16.771957 10.323112 1.25090599 -1.87594414 -8.38448144 )
     (34.536239 13.830625 8.44716836 -7.13357545 -16.5589599 -1.5830307 )
     (34.703926 5.90553475 -8.1117916 -8.71660615 8.1117916 8.71660615 ))
    NATURAL)
   (2
    ((192 344) (192 364))
    NIL
    ((0 20. 0 0 0 0 ))
    NATURAL)
   (2
    ((192 364) (236 364))
    NIL
    ((44. 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((192 316) (192 212))
    NIL
    ((0 -104. 0 0 0 0 ))
    NATURAL)
   (9
    ((192 212) (160 221) (133 229) (109 243) (103 266) (115 290)
     (134 304) (161 312) (192 316))
    NIL
    ((-33.384933 9.54270936 0 0 8.3096447 -3.25625897 )
     (-29.230114 7.9145794 8.3096447 -3.25625897 -11.548229 10.2812957 )
     (-26.694583 9.79896928 -3.238585 7.0250368 25.883277 4.13107395 )
     (-16.991527 18.889541 22.644695 11.1561107 -1.98490143 -8.8055935 )
     (4.66071415 25.642856 20.659793 2.35051584 -17.943664 -16.908687 )
     (16.348674 19.539024 2.71612644 -14.558174 7.75957204 10.440353 )
     (22.944587 10.2010288 10.475698 -4.11781979 -7.09462357 -0.852724076 )
     (29.872974 5.65684796 3.3810749 -4.97054386 -3.3810749 4.97054386 ))
    NATURAL))

  ((10
    ((236 143) (268 135) (301 125) (326 111) (339 86) (333 61)
     (313 41) (286 31) (262 26) (236 23))
    NIL
    ((31.306991 -7.5433216 0 0 4.15804672 -2.74006653 )
     (33.386009 -8.91335488 4.15804672 -2.74006653 -14.790233 1.70033264 )
     (30.148944 -10.803255 -10.6321869 -1.03973388 1.00288772 -16.061264 )
     (20.018199 -19.873619 -9.62929917 -17.1009979 -13.221313 20.544723 )
     (3.77824688 -26.702255 -22.850612 3.44372892 9.88235665 -0.117646694 )
     (-14.131187 -23.317348 -12.968256 3.32608223 3.69189644 9.92585755 )
     (-25.253494 -15.028337 -9.27635957 13.2519397 17.350055 -9.58579064 )
     (-25.854827 -6.56929303 8.07369615 3.66614914 -13.092119 -1.58268642 )
     (-24.32719 -3.69448757 -5.01842404 2.08346271 5.01842404 -2.08346271 ))
    NATURAL)
   (2
    ((236 23) (236 143))
    NIL
    ((0 120. 0 0 0 0 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/GACHAE.S2-SF b/obsolete/lispusers/splinefonts/GACHAE.S2-SF
deleted file mode 100644
index e293c5ed..00000000
--- a/obsolete/lispusers/splinefonts/GACHAE.S2-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY gacha)
 (CHARACTER 74Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:22:05)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((2
    ((60 169) (312 0))
    NIL
    ((252. -169. 0 0 0 0 ))
    NATURAL)
   (2
    ((312 0) (372 0))
    NIL
    ((60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((372 0) (120 169))
    NIL
    ((-252. 169. 0 0 0 0 ))
    NATURAL)
   (2
    ((120 169) (370 337))
    NIL
    ((250. 168. 0 0 0 0 ))
    NATURAL)
   (2
    ((370 337) (310 337))
    NIL
    ((-60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((310 337) (60 169))
    NIL
    ((-250. -168. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 75Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:22:46)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((2
    ((82 148) (82 148))
    NIL
    ((0 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((82 148) (357 148))
    NIL
    ((275. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((357 148) (357 108))
    NIL
    ((0 -40. 0 0 0 0 ))
    NATURAL)
   (2
    ((357 108) (82 108))
    NIL
    ((-275. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((82 108) (82 148))
    NIL
    ((0 40. 0 0 0 0 ))
    NATURAL))

  ((2
    ((82 190) (357 190))
    NIL
    ((275. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((357 190) (357 230))
    NIL
    ((0 40. 0 0 0 0 ))
    NATURAL)
   (2
    ((357 230) (82 230))
    NIL
    ((-275. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((82 230) (82 190))
    NIL
    ((0 -40. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 76Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:24:09)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((2
    ((370 169) (118 0))
    NIL
    ((-252. -169. 0 0 0 0 ))
    NATURAL)
   (2
    ((118 0) (58 0))
    NIL
    ((-60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((58 0) (310 169))
    NIL
    ((252. 169. 0 0 0 0 ))
    NATURAL)
   (2
    ((310 169) (60 337))
    NIL
    ((-250. 168. 0 0 0 0 ))
    NATURAL)
   (2
    ((60 337) (120 337))
    NIL
    ((60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((120 337) (370 169))
    NIL
    ((250. -168. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 77Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:35:10)
 (MADE-FROM gacha.cu 0 140 0 0)
 (SPLINES

  ((13
    ((248 24) (243 6) (228 -9) (204 -14) (180 -9) (165 6)
     (160 24) (165 42) (180 57) (204 62) (228 57) (243 42)
     (248 24))
    NIL
    ((-2.93116188 -18.230766 0 0 -12.4130268 1.38461542 )
     (-9.13767625 -17.538459 -12.4130268 1.38461542 2.06513786 11.076921 )
     (-20.518135 -10.615383 -10.3478889 12.461538 10.152477 -3.69230843 )
     (-25.789783 3.18512320E-7 -0.195410430 8.7692299 11.3249416 3.69230843 )
     (-20.322723 10.615383 11.1295318 12.461538 -1.45225525 -11.076921 )
     (-9.91931916 17.538459 9.6772766 1.38461518 0.484085083 -1.38461518 )
     (3.18512320E-7 18.230766 10.1613617 -1.91652190E-7 -0.484086990 -1.38461423 )
     (9.91931916 17.538459 9.6772747 -1.38461446 1.45225715 -11.076923 )
     (20.322723 10.615383 11.1295318 -12.461538 -11.3249416 3.69230843 )
     (25.789783 -3.18512320E-7 -0.195410639 -8.7692299 -10.152477 -3.69230843 )
     (20.518131 -10.615383 -10.3478889 -12.461538 -2.06513786 11.076921 )
     (9.13767434 -17.538459 -12.4130268 -1.38461518 12.4130268 1.38461518 ))
    NATURAL))

  ((18
    ((76 258) (82 281) (100 310) (141 337) (184 345) (222 347)
     (265 344) (301 336) (330 322) (351 301) (358 272) (351 242)
     (325 219) (291 200) (256 185) (234 163) (230 120) (230 82))
    NIL
    ((4.36275196 21.588817 0 0 9.8234863 8.46708489 )
     (9.27449418 25.82236 9.8234863 8.46708489 22.882568 -6.33543015 )
     (30.539264 31.12173 32.706054 2.13165474 -35.353759 -31.125358 )
     (45.568435 17.690704 -2.64770508 -28.993705 -7.4675293 28.836875 )
     (39.186965 3.11543942 -10.115234 -0.156827688 23.223876 -6.22215367 )
     (40.68367 -0.152465343 13.108642 -6.3789816 -25.427978 2.05173683 )
     (41.078323 -5.505579 -12.3193378 -4.32724476 6.48805333 -1.9847908 )
     (32.003013 -10.825218 -5.83128453 -6.31203557 -0.524238587 -0.112575531 )
     (25.909606 -17.193542 -6.3555231 -6.4246111 -10.391092 -3.56490803 )
     (14.358539 -25.400604 -16.746616 -9.9895191 6.0886116 8.3722038 )
     (0.656227112 -31.20402 -10.6580047 -1.61731481 -13.963348 12.0760917 )
     (-16.983448 -26.78329 -24.621353 10.458778 19.764766 -8.6765785 )
     (-31.722419 -20.662803 -4.85658455 1.78219914 0.904281617 4.63022518 )
     (-36.12686 -16.56549 -3.95230293 6.41242505 18.618099 -9.8443241 )
     (-30.770114 -15.075229 14.665796 -3.43189907 8.6233196 -31.252922 )
     (-11.7926578 -34.13359 23.289115 -34.684822 -23.111393 50.856025 )
     (-0.0592400506 -43.390396 0.177720159 16.171203 -0.177720159 -16.171203 ))
    NATURAL)
   (2
    ((230 82) (178 82))
    NIL
    ((-52. 0 0 0 0 0 ))
    NATURAL)
   (9
    ((178 82) (176 130) (179 173) (191 195) (215 207) (241 217)
     (277 231) (300 247) (306 274))
    NIL
    ((-2.93114853 48.008277 0 0 5.58689213 -0.0497055054 )
     (-0.137702286 47.983429 5.58689213 -0.0497055054 2.06553745 -29.751472 )
     (6.4819584 33.057983 7.65242959 -29.801178 10.150957 23.055595 )
     (19.209865 14.7846088 17.803386 -6.74558068 -24.669364 3.52908611 )
     (24.678569 9.8035698 -6.86597825 -3.21649456 28.526504 10.828054 )
     (32.075843 12.001104 21.660526 7.6115608 -41.43666 -10.8413086 )
     (33.018035 14.1920089 -19.776138 -3.2297492 -0.779823304 20.537181 )
     (12.8519859 21.230854 -20.555961 17.307434 20.555961 -17.307434 ))
    NATURAL)
   (8
    ((306 274) (300 293) (276 312) (234 318) (202 317) (155 308)
     (133 281) (128 258))
    NIL
    ((-2.76743364 18.186187 0 0 -19.395397 4.88285733 )
     (-12.4651317 20.627616 -19.395397 4.88285733 -11.023014 -24.414283 )
     (-37.372032 13.303329 -30.41841 -19.531429 63.487457 14.774301 )
     (-36.046714 1.15905142 33.069046 -4.7571268 -74.926818 1.31707191 )
     (-40.441085 -2.9395399 -41.85778 -3.44005489 86.219848 -26.042594 )
     (-39.188934 -19.40089 44.362075 -29.48265 -29.952594 42.853309 )
     (-9.8031597 -27.456886 14.409479 13.3706627 -14.409479 -13.3706627 ))
    NATURAL)
   (2
    ((128 258) (76 258))
    NIL
    ((-52. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 100Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:41:59)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((25
    ((274 84) (315 89) (349 101) (378 127) (388 169) (382 261)
     (346 310) (312 329) (274 340) (222 346) (169 340) (132 329)
     (97 310) (61 261) (49 169) (61 77) (99 29) (132 9)
     (169 -2) (222 -8) (273 -1) (312 10) (339 25) (357 40)
     (372 65))
    NIL
    ((42.841934 4.12846947 0 0 -11.051645 5.22917843 )
     (37.316116 6.74305916 -11.051645 5.22917843 13.25823 15.8541069 )
     (32.893585 19.899292 2.2065854 21.083286 -29.98128 -26.645618 )
     (20.109527 27.659767 -27.774696 -5.562335 22.666904 102.72837 )
     (3.66828489 73.461624 -5.10779095 97.166046 -42.686332 -180.2678 )
     (-22.782672 80.49371 -47.794128 -83.101837 64.07843 60.343216 )
     (-38.537582 27.563484 16.284305 -22.758621 -21.627391 16.8949508 )
     (-33.066978 13.252338 -5.3430872 -5.8636694 -13.568861 4.07696724 )
     (-45.194496 9.42715455 -18.911949 -1.78670144 15.902847 -15.202821 )
     (-56.15502 0.0390407219 -3.00910091 -16.9895248 27.957454 14.734329 )
     (-45.185394 -9.5833187 24.948356 -2.25519466 -25.732685 -1.7344985 )
     (-33.103378 -12.7057628 -0.784330249 -3.98969317 -9.0267067 -25.796333 )
     (-38.401062 -29.593627 -9.81103707 -29.786029 43.839515 -27.080135 )
     (-26.292339 -72.91972 34.02848 -56.866165 -16.33139 56.116867 )
     (-0.429553986 -101.7274 17.69709 -0.749291659 21.486053 60.612625 )
     (28.010566 -72.170425 39.183143 59.863334 -57.61283 -34.567375 )
     (38.38729 -29.590789 -18.429687 25.295959 22.96529 -18.343135 )
     (31.440254 -13.466398 4.53560543 6.95282174 19.751655 -6.06007004 )
     (45.851684 -9.5436115 24.287262 0.892751694 -29.971923 18.583416 )
     (55.152984 0.640850663 -5.68466473 19.476169 -7.86394025 -20.273609 )
     (45.536346 9.98021318 -13.5486049 -0.797443152 1.42769622 8.51104165 )
     (32.70159 13.438291 -12.1209087 7.71360016 2.15315056 -13.770559 )
     (21.65726 14.266613 -9.96775819 -6.0569601 7.9596977 22.571197 )
     (15.669353 19.49525 -2.00806045 16.51424 2.00806045 -16.51424 ))
    NATURAL)
   (2
    ((372 65) (326 65))
    NIL
    ((-46. 0 0 0 0 0 ))
    NATURAL)
   (13
    ((326 65) (310 43) (285 30) (260 22) (223 17) (194 19)
     (167 25) (140 37) (120 53) (103 82) (98 111) (96 143)
     (95 169))
    NIL
    ((-13.31982 -24.077533 0 0 -16.0810699 12.4652157 )
     (-21.360355 -17.8449249 -16.0810699 12.4652157 26.405349 -8.32608224 )
     (-24.23875 -9.5427513 10.3242817 4.1391325 -35.540336 -3.16088247 )
     (-31.684639 -6.98406029 -25.21606 0.978249670 43.756027 8.96961595 )
     (-35.022682 -1.52100181 18.53997 9.94786645 -19.483806 -8.7175865 )
     (-26.224617 4.0680704 -0.943838716 1.23027920 -1.82078004 7.90073395 )
     (-28.078846 9.24871636 -2.76461887 9.13101388 14.766931 -10.885349 )
     (-23.459995 12.937055 12.0023136 -1.75433612 -15.246952 23.640663 )
     (-19.081157 23.003051 -3.24463844 21.886329 22.220874 -29.677307 )
     (-11.2153568 30.050727 18.976238 -7.79098035 -19.636566 17.068573 )
     (-2.05740309 30.794033 -0.660330892 9.2775936 2.32541323 -20.596992 )
     (-1.55502748 29.773132 1.66508269 -11.3193988 -1.66508269 11.3193988 ))
    NATURAL)
   (9
    ((95 169) (96 195) (98 227) (103 256) (120 285) (140 301)
     (167 313) (194 319) (223 321))
    NIL
    ((0.722201824 24.113586 0 0 1.66678905 11.318481 )
     (1.55559635 29.772827 1.66678905 11.318481 -2.33394575 -20.592411 )
     (2.05541229 30.7951 -0.667156935 -9.2739315 19.668994 17.051174 )
     (11.222753 30.046756 19.001838 7.7772455 -22.34204 -29.612293 )
     (19.053569 23.017852 -3.34020567 -21.835048 15.699186 23.398006 )
     (23.562957 12.881811 12.358982 1.56295967 -16.454708 -9.97974778 )
     (27.694583 9.454895 -4.09572888 -8.4167881 8.11966134 4.52098465 )
     (27.658687 3.29860067 4.02393246 -3.89580298 -4.02393246 3.89580298 ))
    NATURAL)
   (7
    ((223 321) (252 319) (279 313) (306 301) (326 285) (343 256)
     (348 227))
    NIL
    ((29.670509 -1.34871792 0 0 -4.02307606 -3.90769243 )
     (27.658973 -3.30256414 -4.02307606 -3.90769243 8.11538316 -4.46153736 )
     (27.693588 -9.44102479 4.09230709 -8.36923028 -16.438457 9.7538433 )
     (23.566665 -12.933332 -12.346153 1.38461446 15.63846 -22.55384 )
     (19.039741 -22.825641 3.29230738 -21.169227 -22.115379 26.461532 )
     (11.2743568 -30.764099 -18.823074 5.2923069 18.823074 -5.2923069 ))
    NATURAL)
   (12
    ((348 227) (324 241) (300 250) (262 253) (217 242) (192 227)
     (174 204) (166 168) (181 124) (204 103) (231 91) (274 84))
    NIL
    ((-24.775428 15.165264 0 0 4.6525793 -6.99158669 )
     (-22.449138 11.6694698 4.6525793 -6.99158669 -23.262893 4.95793438 )
     (-29.428009 7.1568508 -18.610317 -2.0336523 4.3990097 -18.8401489 )
     (-45.83882 -4.2968769 -14.211307 -20.873802 47.666854 22.402671 )
     (-36.216697 -13.969343 33.45555 1.52886963 -33.066444 -10.770544 )
     (-19.294372 -17.825744 0.389100015 -9.2416744 6.59894753 -3.32049179 )
     (-15.605798 -28.727664 6.9880476 -12.562166 24.670658 -5.9474926 )
     (3.71757555 -44.26358 31.658706 -18.509658 -27.281574 57.110458 )
     (21.735492 -34.218002 4.37713242 38.600799 -5.54436779 -36.494346 )
     (23.340442 -13.8643818 -1.16723537 2.10645246 25.459041 4.86693383 )
     (34.902725 -9.32446099 24.291809 6.97338677 -24.291809 -6.97338677 ))
    NATURAL))

  ((21
    ((203 170) (205 183) (211 201) (225 217) (249 226) (270 229)
     (291 226) (315 217) (329 201) (335 183) (337 170) (335 157)
     (329 139) (315 123) (291 114) (270 111) (249 114) (225 123)
     (211 139) (205 157) (203 170))
    NIL
    ((1.29664564 11.627071 0 0 4.2201252 8.2375679 )
     (3.40670824 15.745855 4.2201252 8.2375679 2.89937305 -11.187843 )
     (9.076519 18.389499 7.11949826 -2.95027637 8.18238069 -5.48618603 )
     (20.287208 12.6961307 15.3018799 -8.4364624 -23.628898 3.13259506 )
     (23.774639 5.82596588 -8.32702066 -5.30386734 8.33322335 -1.04419803 )
     (19.614231 -3.18512320E-7 0.00620389823 -6.34806538 8.29599954 1.04419803 )
     (23.768432 -5.82596684 8.30220414 -5.30386734 -23.517223 -3.13259506 )
     (20.312023 -12.6961326 -15.215021 -8.4364624 7.772912 5.48618603 )
     (8.98345948 -18.389499 -7.4421091 -2.9502759 4.42556858 11.187843 )
     (3.75413466 -15.745855 -3.01654005 8.2375679 -1.47518968 -8.2375679 )
     (-8.00937414E-8 -11.627071 -4.49172974 0 1.47518968 -8.2375679 )
     (-3.75413513 -15.745855 -3.01654005 -8.2375679 -4.42556763 11.187843 )
     (-8.98345948 -18.389499 -7.44210816 2.95027685 -7.77291489 5.48618508 )
     (-20.312023 -12.6961307 -15.215023 8.4364624 23.517227 -3.13259506 )
     (-23.768432 -5.82596588 8.30220414 5.30386734 -8.29599954 1.04419803 )
     (-19.614231 1.59256160E-7 0.00620390940 6.34806538 -8.33322335 -1.04419708 )
     (-23.774639 5.82596684 -8.32702066 5.3038683 23.628898 3.1325941 )
     (-20.287208 12.6961326 15.3018779 8.4364624 -8.18237878 -5.48618603 )
     (-9.076519 18.389499 7.11949826 2.9502759 -2.89937305 -11.187843 )
     (-3.40670824 15.745855 4.2201252 -8.2375679 -4.2201252 8.2375679 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 133Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:43:08)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((346 351) (94 351))
    NIL
    ((-252. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((94 351) (94 -112))
    NIL
    ((0 -463. 0 0 0 0 ))
    NATURAL)
   (2
    ((94 -112) (346 -112))
    NIL
    ((252. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((346 -112) (346 -76))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((346 -76) (141 -76))
    NIL
    ((-205. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((141 -76) (141 315))
    NIL
    ((0 391. 0 0 0 0 ))
    NATURAL)
   (2
    ((141 315) (346 315))
    NIL
    ((205. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((346 315) (346 351))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 134Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:44:28)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((117 337) (370 0))
    NIL
    ((253. -337. 0 0 0 0 ))
    NATURAL)
   (2
    ((370 0) (322 0))
    NIL
    ((-48. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((322 0) (69 337))
    NIL
    ((-253. 337. 0 0 0 0 ))
    NATURAL)
   (2
    ((69 337) (117 337))
    NIL
    ((48. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 135Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:45:24)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((346 351) (94 351))
    NIL
    ((-252. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((94 351) (94 315))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL)
   (2
    ((94 315) (299 315))
    NIL
    ((205. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((299 315) (299 -76))
    NIL
    ((0 -391. 0 0 0 0 ))
    NATURAL)
   (2
    ((299 -76) (94 -76))
    NIL
    ((-205. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((94 -76) (94 -112))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL)
   (2
    ((94 -112) (346 -112))
    NIL
    ((252. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((346 -112) (346 351))
    NIL
    ((0 463. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 136Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:48:17)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((219 302) (71 183))
    NIL
    ((-148. -119. 0 0 0 0 ))
    NATURAL)
   (2
    ((71 183) (121 183))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((121 183) (198 239))
    NIL
    ((77. 56. 0 0 0 0 ))
    NATURAL)
   (2
    ((198 239) (198 42))
    NIL
    ((0 -197. 0 0 0 0 ))
    NATURAL)
   (2
    ((198 42) (240 42))
    NIL
    ((42. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((240 42) (240 239))
    NIL
    ((0 197. 0 0 0 0 ))
    NATURAL)
   (2
    ((240 239) (316 183))
    NIL
    ((76. -56. 0 0 0 0 ))
    NATURAL)
   (2
    ((316 183) (366 183))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((366 183) (219 302))
    NIL
    ((-147. 119. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 137Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:49:20)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((22 169) (198 285))
    NIL
    ((176. 116. 0 0 0 0 ))
    NATURAL)
   (2
    ((198 285) (198 233))
    NIL
    ((0 -52. 0 0 0 0 ))
    NATURAL)
   (2
    ((198 233) (130 191))
    NIL
    ((-68. -42. 0 0 0 0 ))
    NATURAL)
   (2
    ((130 191) (411 191))
    NIL
    ((281. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((411 191) (411 147))
    NIL
    ((0 -44. 0 0 0 0 ))
    NATURAL)
   (2
    ((411 147) (130 147))
    NIL
    ((-281. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((130 147) (198 105))
    NIL
    ((68. -42. 0 0 0 0 ))
    NATURAL)
   (2
    ((198 105) (198 53))
    NIL
    ((0 -52. 0 0 0 0 ))
    NATURAL)
   (2
    ((198 53) (22 169))
    NIL
    ((-176. 116. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 173Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:53:08)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((7
    ((313 351) (284 348) (250 338) (224 326) (205 311) (191 293)
     (182 259))
    NIL
    ((-27.201278 -1.20512819 0 0 -10.7923069 -10.7692299 )
     (-32.597435 -6.5897436 -10.7923069 -10.7692299 23.961536 11.846151 )
     (-31.408973 -11.4358959 13.169229 1.07692265 -7.0538454 -6.61538315 )
     (-21.766666 -13.666666 6.1153841 -5.53846073 -1.74615383 8.61538316 )
     (-16.5243568 -14.897436 4.36923027 3.07692337 2.03846168 -27.846153 )
     (-11.1358966 -25.743587 6.40769196 -24.769229 -6.40769196 24.769229 ))
    NATURAL)
   (2
    ((182 259) (182 179))
    NIL
    ((0 -80. 0 0 0 0 ))
    NATURAL)
   (6
    ((182 179) (176 162) (154 142) (130 133) (103 128) (79 126))
    NIL
    ((-1.78468942 -15.4688987 0 0 -25.291862 -9.18660165 )
     (-14.430622 -20.062198 -25.291862 -9.18660165 30.459323 27.93301 )
     (-24.49282 -15.282295 5.1674633 18.74641 -12.545452 -18.545452 )
     (-25.598083 -5.80861187 -7.37798978 0.200957238 13.722486 4.24880219 )
     (-26.11483 -3.483253 6.34449769 4.44975949 -6.34449769 -4.44975949 ))
    NATURAL)
   (2
    ((79 126) (79 106))
    NIL
    ((0 -20. 0 0 0 0 ))
    NATURAL)
   (6
    ((79 106) (103 104) (130 99) (154 90) (176 70) (182 53))
    NIL
    ((22.942581 -1.25837326 0 0 6.34449673 -4.44976044 )
     (26.11483 -3.48325348 6.34449673 -4.44976044 -13.722486 4.24880314 )
     (25.598083 -5.80861187 -7.37798978 -0.200957209 12.545454 -18.545452 )
     (24.49282 -15.282297 5.16746426 -18.74641 -30.459327 27.933013 )
     (14.430622 -20.062198 -25.291866 9.18660356 25.291866 -9.18660356 ))
    NATURAL)
   (2
    ((182 53) (182 -27))
    NIL
    ((0 -80. 0 0 0 0 ))
    NATURAL)
   (7
    ((182 -27) (191 -61) (205 -79) (224 -94) (250 -106) (284 -116)
     (313 -119))
    NIL
    ((7.9320507 -38.128204 0 0 6.40769196 24.769229 )
     (11.1358966 -25.743587 6.40769196 24.769229 -2.03846168 -27.846149 )
     (16.5243568 -14.897434 4.36923027 -3.07692242 1.74615478 8.61538316 )
     (21.766666 -13.666666 6.11538506 5.53846073 7.05384446 -6.61538315 )
     (31.408973 -11.4358959 13.169229 -1.07692289 -23.961536 11.846151 )
     (32.597435 -6.58974267 -10.7923069 10.7692299 10.7923069 -10.7692299 ))
    NATURAL)
   (2
    ((313 -119) (332 -119))
    NIL
    ((19. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((332 -119) (332 -83))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((332 -83) (307 -83))
    NIL
    ((-25. 0 0 0 0 0 ))
    NATURAL)
   (5
    ((307 -83) (276 -78) (255 -69) (237 -54) (229 -29))
    NIL
    ((-33.642852 4.17857075 0 0 15.857141 4.92857075 )
     (-25.714283 6.6428566 15.857141 4.92857075 -19.285709 -0.642856598 )
     (-19.5 11.25 -3.42857075 4.28571415 19.285709 9.6428566 )
     (-13.285713 20.357139 15.857141 13.9285717 -15.857141 -13.9285717 ))
    NATURAL)
   (2
    ((229 -29) (229 41))
    NIL
    ((0 70. 0 0 0 0 ))
    NATURAL)
   (6
    ((229 41) (223 63) (210 84) (195 96) (180 106) (157 116))
    NIL
    ((-4.30622006 21.660285 0 0 -10.1626777 2.03827715 )
     (-9.3875599 22.679424 -10.1626777 2.03827715 8.81339456 -16.191383 )
     (-15.143539 16.622005 -1.34928202 -14.153108 4.90909004 14.72727 )
     (-14.038276 9.8325348 3.55980825 0.574162603 -16.449756 -0.717703223 )
     (-18.703346 10.0478458 -12.8899517 -0.143540680 12.8899517 0.143540680 ))
    NATURAL)
   (6
    ((157 116) (180 126) (195 136) (210 148) (223 169) (229 191))
    NIL
    ((25.148323 9.9760761 0 0 -12.8899517 0.143540561 )
     (18.703346 10.0478458 -12.8899517 0.143540561 16.449756 -0.717702747 )
     (14.038276 9.8325348 3.55980825 -0.574162245 -4.90909004 14.72727 )
     (15.143539 16.622009 -1.3492825 14.153108 -8.81339456 -16.191383 )
     (9.38755799 22.679424 -10.1626777 -2.03827715 10.1626777 2.03827715 ))
    NATURAL)
   (2
    ((229 191) (229 261))
    NIL
    ((0 70. 0 0 0 0 ))
    NATURAL)
   (5
    ((229 261) (237 286) (255 301) (276 310) (307 315))
    NIL
    ((5.35714245 27.321426 0 0 15.857141 -13.9285698 )
     (13.285713 20.357139 15.857141 -13.9285698 -19.285709 9.6428547 )
     (19.5 11.249998 -3.42857075 -4.28571415 19.285709 -0.642856598 )
     (25.714283 6.6428566 15.857141 -4.92857075 -15.857141 4.92857075 ))
    NATURAL)
   (2
    ((307 315) (332 315))
    NIL
    ((25. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((332 315) (332 351))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((332 351) (313 351))
    NIL
    ((-19. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 174Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:54:25)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((195 351) (195 -112))
    NIL
    ((0 -463. 0 0 0 0 ))
    NATURAL)
   (2
    ((195 -112) (246 -112))
    NIL
    ((51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((246 -112) (246 351))
    NIL
    ((0 463. 0 0 0 0 ))
    NATURAL)
   (2
    ((246 351) (195 351))
    NIL
    ((-51. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 175Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  7:58:20)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((139 351) (158 351))
    NIL
    ((19. 0 0 0 0 0 ))
    NATURAL)
   (7
    ((158 351) (187 348) (221 338) (247 326) (266 311) (280 293)
     (289 259))
    NIL
    ((27.201278 -1.20512819 0 0 10.7923069 -10.7692299 )
     (32.597435 -6.5897436 10.7923069 -10.7692299 -23.961536 11.846151 )
     (31.408973 -11.4358959 -13.169229 1.07692265 7.0538454 -6.61538315 )
     (21.766666 -13.666666 -6.1153841 -5.53846073 1.74615383 8.61538316 )
     (16.5243568 -14.897436 -4.36923027 3.07692337 -2.03846168 -27.846153 )
     (11.1358966 -25.743587 -6.40769196 -24.769229 6.40769196 24.769229 ))
    NATURAL)
   (2
    ((289 259) (289 179))
    NIL
    ((0 -80. 0 0 0 0 ))
    NATURAL)
   (6
    ((289 179) (295 162) (317 142) (341 133) (368 128) (392 126))
    NIL
    ((1.78468942 -15.4688987 0 0 25.291862 -9.18660165 )
     (14.430622 -20.062198 25.291862 -9.18660165 -30.459323 27.93301 )
     (24.49282 -15.282295 -5.1674633 18.74641 12.545452 -18.545452 )
     (25.598083 -5.80861187 7.37798978 0.200957238 -13.722486 4.24880219 )
     (26.11483 -3.483253 -6.34449769 4.44975949 6.34449769 -4.44975949 ))
    NATURAL)
   (2
    ((392 126) (392 106))
    NIL
    ((0 -20. 0 0 0 0 ))
    NATURAL)
   (6
    ((392 106) (368 104) (341 99) (317 90) (295 70) (289 53))
    NIL
    ((-22.942581 -1.25837326 0 0 -6.34449673 -4.44976044 )
     (-26.11483 -3.48325348 -6.34449673 -4.44976044 13.722486 4.24880314 )
     (-25.598083 -5.80861187 7.37798978 -0.200957209 -12.545454 -18.545452 )
     (-24.49282 -15.282297 -5.16746426 -18.74641 30.459327 27.933013 )
     (-14.430622 -20.062198 25.291866 9.18660356 -25.291866 -9.18660356 ))
    NATURAL)
   (2
    ((289 53) (289 -27))
    NIL
    ((0 -80. 0 0 0 0 ))
    NATURAL)
   (7
    ((289 -27) (280 -61) (266 -79) (247 -94) (221 -106) (187 -116)
     (158 -119))
    NIL
    ((-7.9320507 -38.128204 0 0 -6.40769196 24.769229 )
     (-11.1358966 -25.743587 -6.40769196 24.769229 2.03846168 -27.846149 )
     (-16.5243568 -14.897434 -4.36923027 -3.07692242 -1.74615478 8.61538316 )
     (-21.766666 -13.666666 -6.11538506 5.53846073 -7.05384446 -6.61538315 )
     (-31.408973 -11.4358959 -13.169229 -1.07692289 23.961536 11.846151 )
     (-32.597435 -6.58974267 10.7923069 10.7692299 -10.7923069 -10.7692299 ))
    NATURAL)
   (2
    ((158 -119) (139 -119))
    NIL
    ((-19. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((139 -119) (139 -83))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((139 -83) (164 -83))
    NIL
    ((25. 0 0 0 0 0 ))
    NATURAL)
   (5
    ((164 -83) (195 -78) (216 -69) (234 -54) (242 -29))
    NIL
    ((33.642852 4.17857075 0 0 -15.857141 4.92857075 )
     (25.714283 6.6428566 -15.857141 4.92857075 19.285709 -0.642856598 )
     (19.5 11.25 3.42857075 4.28571415 -19.285709 9.6428566 )
     (13.285713 20.357139 -15.857141 13.9285717 15.857141 -13.9285717 ))
    NATURAL)
   (2
    ((242 -29) (242 41))
    NIL
    ((0 70. 0 0 0 0 ))
    NATURAL)
   (6
    ((242 41) (248 63) (261 84) (276 96) (291 106) (314 116))
    NIL
    ((4.30622006 21.660285 0 0 10.1626777 2.03827715 )
     (9.3875599 22.679424 10.1626777 2.03827715 -8.81339456 -16.191383 )
     (15.143539 16.622005 1.34928202 -14.153108 -4.90909004 14.72727 )
     (14.038276 9.8325348 -3.55980825 0.574162603 16.449756 -0.717703223 )
     (18.703346 10.0478458 12.8899517 -0.143540680 -12.8899517 0.143540680 ))
    NATURAL)
   (6
    ((314 116) (291 126) (276 136) (261 148) (248 169) (242 191))
    NIL
    ((-25.148323 9.9760761 0 0 12.8899517 0.143540561 )
     (-18.703346 10.0478458 12.8899517 0.143540561 -16.449756 -0.717702747 )
     (-14.038276 9.8325348 -3.55980825 -0.574162245 4.90909004 14.72727 )
     (-15.143539 16.622009 1.3492825 14.153108 8.81339456 -16.191383 )
     (-9.38755799 22.679424 10.1626777 -2.03827715 -10.1626777 2.03827715 ))
    NATURAL)
   (2
    ((242 191) (242 261))
    NIL
    ((0 70. 0 0 0 0 ))
    NATURAL)
   (5
    ((242 261) (234 286) (216 301) (195 310) (164 315))
    NIL
    ((-5.35714245 27.321426 0 0 -15.857141 -13.9285698 )
     (-13.285713 20.357139 -15.857141 -13.9285698 19.285709 9.6428547 )
     (-19.5 11.249998 3.42857075 -4.28571415 -19.285709 -0.642856598 )
     (-25.714283 6.6428566 -15.857141 -4.92857075 15.857141 4.92857075 ))
    NATURAL)
   (2
    ((164 315) (139 315))
    NIL
    ((-25. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((139 315) (139 351))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 176Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77  8:03:50)
 (MADE-FROM gachalc.cu 0 140 0 0)
 (SPLINES

  ((2
    ((70 84) (30 84))
    NIL
    ((-40. 0 0 0 0 0 ))
    NATURAL)
   (13
    ((30 84) (39 111) (55 131) (76 147) (106 158) (144 161)
     (184 156) (222 142) (249 131) (286 122) (327 124) (356 145)
     (366 161))
    NIL
    ((7.34924794 28.65084 0 0 9.9045086 -9.9050579 )
     (12.301502 23.69831 9.9045086 -9.9050579 -7.5225458 7.52529336 )
     (18.444736 17.5559 2.3819623 -2.37976408 8.18567658 -2.19611978 )
     (24.91954 14.078077 10.56764 -4.57588387 -1.22017288 -4.7408142 )
     (34.87709 7.1317854 9.3474674 -9.31669808 -9.30498506 3.15938091 )
     (39.572067 -0.605221987 0.0424815491 -6.15731717 2.44012308 -7.8967161 )
     (40.83461 -10.710897 2.48260498 -14.054033 -24.455505 22.427482 )
     (31.089466 -13.551187 -21.9729 8.37345124 41.381904 -9.8132267 )
     (29.807518 -10.0843486 19.409004 -1.43977689 -15.07213 10.8254299 )
     (41.680458 -6.1114111 4.33687306 9.38565446 -17.093372 20.511505 )
     (37.470642 13.5299949 -12.7565 29.897159 -12.5543709 -44.871444 )
     (18.436954 20.991428 -25.31087 -14.9742908 25.31087 14.9742908 ))
    NATURAL)
   (2
    ((366 161) (406 161))
    NIL
    ((40. 0 0 0 0 0 ))
    NATURAL)
   (7
    ((406 161) (397 134) (381 114) (360 98) (330 87) (292 84)
     (252 89))
    NIL
    ((-7.3487177 -28.653842 0 0 -9.90769197 9.9230766 )
     (-12.3025627 -23.692306 -9.90769197 9.9230766 7.53846074 -7.6153841 )
     (-18.441024 -17.576919 -2.36923075 2.30769205 -8.24615098 2.5384612 )
     (-24.93333 -13.999998 -10.615383 4.84615326 1.44615364 3.46153832 )
     (-34.825637 -7.42307664 -9.1692295 8.30769158 8.4615364 1.61538505 )
     (-39.764099 1.69230771 -0.707692385 9.9230766 0.707692385 -9.9230766 ))
    NATURAL)
   (7
    ((252 89) (214 103) (187 114) (150 123) (109 121) (80 100)
     (70 84))
    NIL
    ((-41.551277 14.767948 0 0 21.307689 -4.60769177 )
     (-30.897434 12.4641018 21.307689 -4.60769177 -40.538452 5.03846073 )
     (-29.858974 10.3756408 -19.230766 0.430769324 14.846151 -9.546154 )
     (-41.666664 6.03333283 -4.38461495 -9.11538507 17.1538429 -20.853843 )
     (-37.474357 -13.508974 12.7692299 -29.96923 12.5384597 44.961532 )
     (-18.435894 -20.997432 25.307689 14.992307 -25.307689 -14.992307 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/GACHAE.UC1-SF b/obsolete/lispusers/splinefonts/GACHAE.UC1-SF
deleted file mode 100644
index 9cc43ef0..00000000
--- a/obsolete/lispusers/splinefonts/GACHAE.UC1-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY gacha)
 (CHARACTER 101Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 10:14:09)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((25 0) (157 337))
    NIL
    ((132. 337. 0 0 0 0 ))
    NATURAL)
   (2
    ((157 337) (280 337))
    NIL
    ((123. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((280 337) (412 0))
    NIL
    ((132. -337. 0 0 0 0 ))
    NATURAL)
   (2
    ((412 0) (359 0))
    NIL
    ((-53. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((359 0) (321 98))
    NIL
    ((-38. 98. 0 0 0 0 ))
    NATURAL)
   (2
    ((321 98) (116 98))
    NIL
    ((-205. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((116 98) (78 0))
    NIL
    ((-38. -98. 0 0 0 0 ))
    NATURAL)
   (2
    ((78 0) (25 0))
    NIL
    ((-53. 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((305 141) (132 141))
    NIL
    ((-173. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((132 141) (194 301))
    NIL
    ((62. 160. 0 0 0 0 ))
    NATURAL)
   (2
    ((194 301) (243 301))
    NIL
    ((49. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((243 301) (305 141))
    NIL
    ((62. -160. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 102Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 10:21:33)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((3
    ((60 337) (60 337) (60 0))
    NIL
    ((0 84.25 0 0 0 -505.5 )
     (0 -168.5 0 -505.5 0 505.5 ))
    NATURAL)
   (2
    ((60 0) (225 0))
    NIL
    ((165. 0 0 0 0 0 ))
    NATURAL)
   (11
    ((225 0) (268 5) (307 15) (340 32) (364 59) (376 97)
     (370 132) (355 154) (339 167) (312 178) (283 185))
    NIL
    ((43.77365 4.02735329 0 0 -4.64191437 5.83587933 )
     (41.45269 6.94529343 -4.64191437 5.83587933 -0.790425301 0.820601464 )
     (36.415565 13.191473 -5.43233967 6.6564808 -4.19638348 2.88171577 )
     (28.885032 21.28881 -9.62872315 9.53819657 -0.424039841 5.65253067 )
     (19.044288 33.653274 -10.052763 15.190727 -12.107458 -19.491832 )
     (2.9377985 39.098083 -22.160221 -4.3011055 12.85387 -11.6851997 )
     (-12.795486 28.954376 -9.3063507 -15.986305 14.691978 6.2326393 )
     (-14.7558479 16.084388 5.3856287 -9.7536659 -23.621791 10.754642 )
     (-21.181118 11.7080478 -18.236164 1.00097775 19.795204 -7.25122166 )
     (-29.51968 9.08341409 1.5590415 -6.25024415 -1.5590415 6.25024415 ))
    NATURAL)
   (12
    ((283 185) (318 199) (336 212) (349 227) (358 254) (352 287)
     (338 306) (319 319) (297 328) (279 332) (256 335) (225 337))
    NIL
    ((39.205406 14.229002 0 0 -25.232437 -1.37401437 )
     (26.589183 13.541994 -25.232437 -1.37401437 24.162193 0.870072127 )
     (13.437845 12.6030159 -1.07024192 -0.503942251 0.583649278 15.893724 )
     (12.6594276 20.045936 -0.486592591 15.3897838 -20.496791 -4.44498253 )
     (1.924438 33.213226 -20.983387 10.944801 15.403532 -34.113792 )
     (-11.357181 27.101131 -5.579854 -23.16899 0.882661820 20.900169 )
     (-16.495704 14.3822269 -4.69719219 -2.26882028 -0.934181214 -1.48690176 )
     (-21.659988 11.369955 -5.6313734 -3.75572205 14.854061 -2.9525671 )
     (-19.86433 6.13794995 9.22268868 -6.70828915 -16.4820709 7.29716588 )
     (-18.882679 3.07824373 -7.25938416 0.588877082 -2.9257679 -2.2360959 )
     (-27.604946 2.54907274 -10.185152 -1.64721918 10.185152 1.64721918 ))
    NATURAL)
   (2
    ((225 337) (60 337))
    NIL
    ((-165. 0 0 0 0 0 ))
    NATURAL))

  ((6
    ((236 168) (269 163) (292 153) (304 143) (314 128) (319 101))
    NIL
    ((34.904304 -3.62200928 0 0 -11.4258365 -8.26794244 )
     (29.191387 -7.7559805 -11.4258365 -8.26794244 -2.87081337 11.339712 )
     (16.330143 -10.3540668 -14.2966499 3.07177019 16.909088 -7.090909 )
     (10.488037 -10.827751 2.6124401 -4.01913929 -10.7655506 -12.976072 )
     (7.71770287 -21.334926 -8.1531105 -16.995212 8.1531105 16.995212 ))
    NATURAL)
   (6
    ((319 101) (316 75) (304 57) (287 45) (268 39) (236 36))
    NIL
    ((-0.971291781 -27.813396 0 0 -12.1722488 10.8803825 )
     (-7.05741597 -22.373203 -12.1722488 10.8803825 6.8612442 -6.40191365 )
     (-15.799041 -14.693779 -5.31100464 4.4784689 8.72727204 2.72727203 )
     (-16.74641 -8.8516731 3.4162674 7.20574093 -23.770332 -4.5071764 )
     (-25.215309 -3.89952135 -20.354064 2.69856453 20.354064 -2.69856453 ))
    NATURAL)
   (3
    ((236 36) (211 36) (113 36))
    NIL
    ((-6.75 0 0 0 -109.5 0 )
     (-61.5 0 -109.5 0 109.5 0 ))
    NATURAL)
   (2
    ((113 36) (113 168))
    NIL
    ((0 132. 0 0 0 0 ))
    NATURAL)
   (2
    ((113 168) (236 168))
    NIL
    ((123. 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((113 204) (113 302))
    NIL
    ((0 98. 0 0 0 0 ))
    NATURAL)
   (2
    ((113 302) (220 302))
    NIL
    ((107. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((220 302) (245 302))
    NIL
    ((25. 0 0 0 0 0 ))
    NATURAL)
   (5
    ((245 302) (266 299) (291 291) (305 274) (308 253))
    NIL
    ((19.339283 -2.23214292 0 0 9.9642849 -4.60714245 )
     (24.321426 -4.53571415 9.9642849 -4.60714245 -25.821426 -6.96428586 )
     (21.374996 -12.625 -15.857141 -11.571428 3.3214283 8.4642849 )
     (7.17857075 -19.964283 -12.535713 -3.10714245 12.535713 3.10714245 ))
    NATURAL)
   (5
    ((308 253) (303 231) (290 217) (266 208) (245 204))
    NIL
    ((-3.6964283 -23.875 0 0 -7.82142926 11.25 )
     (-7.60714245 -18.25 -7.82142926 11.25 -8.89285279 -8.25 )
     (-19.875 -11.124998 -16.714283 3. 25.392852 3.74999905 )
     (-23.892856 -6.24999905 8.6785698 6.74999905 -8.6785698 -6.74999905 ))
    NATURAL)
   (2
    ((245 204) (220 204))
    NIL
    ((-25. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((220 204) (113 204))
    NIL
    ((-107. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 103Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 11:50:25)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((25
    ((378 260) (370 287) (352 310) (318 332) (271 343) (229 345)
     (186 342) (141 330) (109 310) (85 285) (69 260) (60 236)
     (49 169) (60 102) (69 78) (85 53) (109 28) (141 8)
     (186 -4) (229 -7) (271 -5) (318 6) (352 28) (370 51)
     (378 78))
    NIL
    ((-6.19386483 28.169479 0 0 -10.836809 -7.01689053 )
     (-11.61227 24.661033 -10.836809 -7.01689053 -5.8159504 11.0844516 )
     (-25.357055 23.18637 -16.652759 4.0675621 -1.89938736 -19.320919 )
     (-42.95951 17.593471 -18.5521469 -15.2533588 31.413505 6.199234 )
     (-45.8049 5.43973065 12.8613586 -9.05412484 -15.754644 6.5239849 )
     (-40.82086 -0.352400899 -2.8932867 -2.53013944 -4.39492512 -8.29517556 )
     (-45.911613 -7.03012753 -7.2882118 -10.825315 27.334346 2.65671539 )
     (-39.532653 -16.527084 20.046134 -8.16860009 -14.942476 3.6683216 )
     (-26.957756 -22.861526 5.10365868 -4.50027848 2.43556595 0.669996739 )
     (-20.636314 -27.026805 7.5392246 -3.83028174 5.20021248 23.651683 )
     (-10.4969825 -19.031242 12.739437 19.821403 -29.236415 -89.27673 )
     (-12.375753 -43.848213 -16.496978 -69.455337 57.74546 69.45532 )
     (3.18139791E-6 -78.57588 41.24848 -4.08857977E-6 -57.74546 69.45535 )
     (12.375753 -43.848213 -16.496982 69.45535 29.236419 -89.27676 )
     (10.4969825 -19.031242 12.739439 -19.821411 -5.20021439 23.651691 )
     (20.636314 -27.026805 7.5392246 3.83028364 -2.43556785 0.669993878 )
     (26.957756 -22.861522 5.10365677 4.50027752 14.942482 3.66832447 )
     (39.532653 -16.527084 20.046138 8.168602 -27.33435 2.65670967 )
     (45.911613 -7.03012658 -7.28821374 10.8253116 4.39492703 -8.29516984 )
     (40.82086 -0.352400601 -2.89328623 2.5301404 15.754644 6.52398205 )
     (45.8049 5.4397316 12.8613586 9.0541229 -31.413505 6.19923783 )
     (42.959503 17.593471 -18.5521469 15.2533607 1.89938736 -19.320922 )
     (25.357051 23.18637 -16.652759 -4.0675621 5.8159504 11.0844516 )
     (11.612268 24.661033 -10.836809 7.01689053 10.836809 -7.01689053 ))
    NATURAL)
   (2
    ((378 78) (326 78))
    NIL
    ((-52. 0 0 0 0 0 ))
    NATURAL)
   (14
    ((326 78) (320 55) (309 40) (286 28) (256 24) (230 23)
     (199 26) (177 32) (150 46) (132 64) (116 90) (106 120)
     (102 142) (101 169))
    NIL
    ((-5.3555641 -25.071785 0 0 -3.86661339 12.4307289 )
     (-7.2888708 -18.856422 -3.86661339 12.4307289 -10.666933 -14.153646 )
     (-16.4889488 -13.5025177 -14.533546 -1.72291755 4.53435135 14.1838588 )
     (-28.755321 -8.13350488 -9.9991951 12.460941 22.529521 -12.5817928 )
     (-27.489753 -1.9634602 12.5303287 -0.120852127 -28.652446 6.14331818 )
     (-29.285652 0.987347246 -16.1221199 6.02246667 38.080276 -5.99148369 )
     (-26.36763 4.01407147 21.95816 0.0309827476 -39.668693 11.822618 )
     (-24.243816 9.95636369 -17.710533 11.853601 36.594505 -11.298988 )
     (-23.657093 16.160469 18.883976 0.554612279 -22.709346 9.37333489 )
     (-16.127792 21.401752 -3.82537174 9.927948 12.2428798 -2.19436264 )
     (-13.831724 30.232517 8.41750909 7.73358536 -2.26217842 -24.595874 )
     (-6.5453043 25.668167 6.15533066 -16.862289 -3.1941638 28.577858 )
     (-1.98705554 23.094806 2.96116686 11.71557 -2.96116686 -11.71557 ))
    NATURAL)
   (14
    ((101 169) (102 196) (106 218) (116 248) (132 274) (150 292)
     (177 306) (199 312) (230 315) (256 314) (286 310) (309 298)
     (321 284) (326 260))
    NIL
    ((0.506471396 28.95259 0 0 2.96117163 -11.7155666 )
     (1.98705721 23.09481 2.96117163 -11.7155666 3.19414091 28.577835 )
     (6.54529954 25.668159 6.15531254 16.86227 2.2622652 -24.595783 )
     (13.831745 30.232536 8.41757775 -7.73351479 -12.243206 -2.1946907 )
     (16.1277199 21.401676 -3.82562828 -9.9282055 22.710559 9.37454988 )
     (23.657371 16.160743 18.884933 -0.553655625 -36.599037 -11.303514 )
     (24.242786 9.9553318 -17.714103 -11.85717 39.685585 11.8395099 )
     (26.371479 4.01791764 21.971485 -0.0176593437 -38.143325 -6.0545311 )
     (29.271297 0.972992898 -16.171844 -6.07219124 28.887744 6.37861539 )
     (27.543323 -1.90989017 12.7159 0.306424796 -23.407657 -13.45993 )
     (28.555393 -8.33343125 -10.691759 -13.153507 -1.25710296 17.461109 )
     (17.235084 -12.7563839 -11.948862 4.30760193 4.43607807 -20.384502 )
     (7.504261 -18.641033 -7.512784 -16.0769 7.512784 16.0769 ))
    NATURAL)
   (2
    ((326 260) (378 260))
    NIL
    ((52. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 105Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:00:54)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((3
    ((82 337) (82 337) (82 0))
    NIL
    ((0 84.25 0 0 0 -505.5 )
     (0 -168.5 0 -505.5 0 505.5 ))
    NATURAL)
   (2
    ((82 0) (369 0))
    NIL
    ((287. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((369 0) (369 36))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((369 36) (134 36))
    NIL
    ((-235. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((134 36) (134 161))
    NIL
    ((0 125. 0 0 0 0 ))
    NATURAL)
   (2
    ((134 161) (315 161))
    NIL
    ((181. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((315 161) (315 197))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((315 197) (134 197))
    NIL
    ((-181. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((134 197) (134 301))
    NIL
    ((0 104. 0 0 0 0 ))
    NATURAL)
   (2
    ((134 301) (355 301))
    NIL
    ((221. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((355 301) (355 337))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((355 337) (82 337))
    NIL
    ((-273. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 106Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:01:55)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((328 197) (328 161))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL)
   (2
    ((328 161) (147 161))
    NIL
    ((-181. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((147 161) (147 0))
    NIL
    ((0 -161. 0 0 0 0 ))
    NATURAL)
   (2
    ((147 0) (96 0))
    NIL
    ((-51. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((96 0) (96 337) (96 337))
    NIL
    ((0 421.25 0 0 0 -505.5 )
     (0 168.5 0 -505.5 0 505.5 ))
    NATURAL)
   (2
    ((96 337) (369 337))
    NIL
    ((273. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((369 337) (369 301))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL)
   (2
    ((369 301) (147 301))
    NIL
    ((-222. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((147 301) (147 197))
    NIL
    ((0 -104. 0 0 0 0 ))
    NATURAL)
   (2
    ((147 197) (328 197))
    NIL
    ((181. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 107Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:14:10)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((354 0) (388 0))
    NIL
    ((34. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((388 0) (388 169))
    NIL
    ((0 169. 0 0 0 0 ))
    NATURAL)
   (2
    ((388 169) (208 169))
    NIL
    ((-180. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((208 169) (208 134))
    NIL
    ((0 -35. 0 0 0 0 ))
    NATURAL)
   (2
    ((208 134) (336 134))
    NIL
    ((128. 0 0 0 0 0 ))
    NATURAL)
   (8
    ((336 134) (336 109) (330 76) (314 51) (285 33) (249 24)
     (224 22) (199 26))
    NIL
    ((1.08862924 -22.377876 0 0 -6.53177548 -15.732736 )
     (-2.17725849 -30.244243 -6.53177548 -15.732736 -3.34112072 30.663684 )
     (-10.3795948 -30.645137 -9.8728962 14.93095 -4.1037426 -10.922018 )
     (-22.304363 -21.175193 -13.9766388 4.00893116 1.75609588 7.0243902 )
     (-35.402954 -13.6540699 -12.2205429 11.033321 33.079353 -5.17554093 )
     (-31.083816 -5.20851898 20.85881 5.85778046 -26.073513 1.67777347 )
     (-23.261764 1.48814869 -5.2147026 7.53555394 5.2147026 -7.53555394 ))
    NATURAL)
   (23
    ((199 26) (177 32) (150 46) (131 63) (114 88) (104 118)
     (100 141) (99 169) (101 196) (104 218) (114 250) (129 277)
     (148 294) (173 306) (199 312) (230 315) (259 314) (289 309)
     (309 299) (320 286) (325 270) (325 270) (326 260))
    NIL
    ((-20.09576 3.9550767 0 0 -11.425428 12.2695389 )
     (-25.808475 10.0898456 -11.425428 12.2695389 27.127147 -13.347694 )
     (-23.67033 15.685537 15.701719 -1.07815694 -19.083168 11.121244 )
     (-17.5101928 20.168003 -3.38144875 10.0430889 13.205524 -1.13729667 )
     (-14.288881 29.642444 9.8240757 8.90579225 -3.73893929 -24.572052 )
     (-6.3342743 26.26221 6.0851364 -15.666261 -4.24976254 27.425514 )
     (-2.37401914 24.308708 1.83537364 11.759254 2.73799419 -13.130014 )
     (0.830351830 29.502952 4.57336807 -1.37075996 -6.7022152 -10.9054546 )
     (2.0526123 22.679466 -2.12884712 -12.2762146 12.070867 32.75183 )
     (5.959198 26.77917 9.9420204 20.475616 -5.58125305 -30.101875 )
     (13.1105919 32.203842 4.36076737 -9.62625886 -1.74585771 -2.3443203 )
     (16.59843 21.405426 2.61490965 -11.970579 6.564682 9.4791603 )
     (22.495681 14.1744289 9.17959214 -2.49141884 -12.5128708 -5.57232285 )
     (25.418838 8.89684678 -3.3332796 -8.06374169 13.4868049 6.81013394 )
     (28.82896 4.23817349 10.153526 -1.25360703 -17.4343529 -3.668221 )
     (30.265308 1.15045547 -7.2808275 -4.92182827 14.250612 1.86275148 )
     (30.109787 -2.83999729 6.9697857 -3.05907679 -21.5681 -3.78278589 )
     (26.295524 -7.7904663 -14.598314 -6.84186268 6.02178765 7.26839066 )
     (14.708103 -10.9981346 -8.57652665 0.426528394 3.48095322 -13.290775 )
     (7.8720541 -17.216991 -5.09557343 -12.864248 -1.94560623 45.894706 )
     (1.80367732 -7.13388539 -7.04117966 33.030464 10.3014736 -56.288078 )
     (-0.0867649615 -2.24746179 3.26029491 -23.257614 -3.26029491 23.257614 ))
    NATURAL)
   (2
    ((326 260) (378 260))
    NIL
    ((52. 0 0 0 0 0 ))
    NATURAL)
   (25
    ((378 260) (370 287) (352 310) (318 332) (271 343) (229 345)
     (186 342) (144 331) (109 310) (85 285) (69 260) (60 236)
     (53 209) (49 169) (52 127) (64 83) (83 52) (108 28)
     (141 9) (183 -3) (229 -7) (271 -1) (300 9) (326 26)
     (344 49))
    NIL
    ((-6.1920843 28.170055 0 0 -10.84749 -7.02033616 )
     (-11.615829 24.659885 -10.84749 -7.02033616 -5.76254845 11.1016826 )
     (-25.344593 23.190391 -16.610038 4.08134747 -2.10231399 -19.386398 )
     (-43.00579 17.578537 -18.712352 -15.305053 32.171806 6.44392205 )
     (-45.632232 5.4954462 13.459455 -8.86113168 -18.584922 5.6107149 )
     (-41.46524 -0.560327769 -5.12547016 -3.25041676 6.16789437 -4.88678265 )
     (-43.506767 -6.25413609 1.0424242 -8.1371994 5.9133482 -4.06358147 )
     (-39.507667 -16.423126 6.9557724 -12.2007808 6.17871476 9.14110566 )
     (-29.462539 -24.053352 13.134487 -3.05967522 -6.62821198 3.49915838 )
     (-19.642158 -25.363449 6.50627518 0.439483404 2.33413124 0.862258196 )
     (-11.9688167 -24.492836 8.8404064 1.3017416 -8.708313 -0.948191763 )
     (-7.48256779 -23.665191 0.132091939 0.353549778 2.49913216 -21.069484 )
     (-6.10090924 -33.846382 2.63122415 -20.715938 4.71178627 25.226146 )
     (-1.11379099 -41.949249 7.3430109 4.51021099 2.65371418 -13.835115 )
     (7.556077 -44.356597 9.99672509 -9.3249054 -3.32663918 30.114315 )
     (15.889482 -38.624343 6.6700859 20.789409 -1.34715652 -16.622142 )
     (21.88599 -26.146007 5.32292938 4.16726685 2.71526527 0.374253273 )
     (28.56655 -21.791614 8.03819467 4.54152012 2.48609352 3.12512875 )
     (37.847793 -15.687528 10.524288 7.66664887 -6.6596422 -0.874764443 )
     (45.042259 -8.4582615 3.86464596 6.7918844 -5.84751797 6.3739252 )
     (45.983146 1.52058458 -1.98287248 13.165809 -17.950279 -12.620937 )
     (35.02513 8.37592507 -19.933155 0.544872284 23.648662 8.10982705 )
     (26.916309 12.9757118 3.71550894 8.6546993 -16.644382 -1.81837463 )
     (22.309623 20.721221 -12.9288768 6.8363247 12.9288768 -6.8363247 ))
    NATURAL)
   (2
    ((344 49) (354 0))
    NIL
    ((10. -49. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 110Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:14:57)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((61 0) (61 337))
    NIL
    ((0 337. 0 0 0 0 ))
    NATURAL)
   (2
    ((61 337) (113 337))
    NIL
    ((52. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((113 337) (113 197))
    NIL
    ((0 -140. 0 0 0 0 ))
    NATURAL)
   (2
    ((113 197) (326 197))
    NIL
    ((213. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((326 197) (326 337))
    NIL
    ((0 140. 0 0 0 0 ))
    NATURAL)
   (2
    ((326 337) (378 337))
    NIL
    ((52. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((378 337) (378 0))
    NIL
    ((0 -337. 0 0 0 0 ))
    NATURAL)
   (2
    ((378 0) (326 0))
    NIL
    ((-52. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((326 0) (326 161))
    NIL
    ((0 161. 0 0 0 0 ))
    NATURAL)
   (2
    ((326 161) (113 161))
    NIL
    ((-213. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((113 161) (113 0))
    NIL
    ((0 -161. 0 0 0 0 ))
    NATURAL)
   (2
    ((113 0) (61 0))
    NIL
    ((-52. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 111Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:21:10)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((194 35) (94 35))
    NIL
    ((-100. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((94 35) (94 0))
    NIL
    ((0 -35. 0 0 0 0 ))
    NATURAL)
   (2
    ((94 0) (346 0))
    NIL
    ((252. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((346 0) (346 35))
    NIL
    ((0 35. 0 0 0 0 ))
    NATURAL)
   (2
    ((346 35) (245 35))
    NIL
    ((-101. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((245 35) (245 302))
    NIL
    ((0 267. 0 0 0 0 ))
    NATURAL)
   (2
    ((245 302) (346 302))
    NIL
    ((101. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((346 302) (346 337))
    NIL
    ((0 35. 0 0 0 0 ))
    NATURAL)
   (2
    ((346 337) (94 337))
    NIL
    ((-252. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((94 337) (94 302))
    NIL
    ((0 -35. 0 0 0 0 ))
    NATURAL)
   (2
    ((94 302) (194 302))
    NIL
    ((100. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((194 302) (194 35))
    NIL
    ((0 -267. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 112Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:24:11)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((13
    ((367 83) (358 56) (342 35) (318 18) (286 5) (249 -4)
     (213 -7) (177 -4) (139 5) (108 18) (84 35) (67 56)
     (58 83))
    NIL
    ((-7.5716381 -28.383419 0 0 -8.57017137 8.30051805 )
     (-11.8567238 -24.233158 -8.57017137 8.30051805 0.850863457 -5.50259018 )
     (-20.001464 -18.683937 -7.7193079 2.79792738 -0.833287240 1.70984411 )
     (-28.137416 -15.0310878 -8.55259515 4.50777149 2.48228836 -1.33678722 )
     (-35.448867 -11.191709 -6.07030678 3.17098427 8.90413095 3.63730621 )
     (-37.067108 -6.20207215 2.83382416 6.80829049 -2.09881306 -1.21243572 )
     (-35.282692 0 0.735010863 5.59585476 -6.50887776 1.21243572 )
     (-37.802116 6.20207215 -5.7738676 6.80829049 16.1343269 -3.63730621 )
     (-35.508819 11.191709 10.360462 3.17098427 -4.02844429 1.33678722 )
     (-27.162582 15.0310878 6.3320179 4.50777149 -0.0205554962 -1.70984459 )
     (-20.840839 18.683937 6.3114624 2.7979269 4.11067009 5.50259114 )
     (-12.4740429 24.233158 10.422132 8.30051805 -10.422132 -8.30051805 ))
    NATURAL)
   (2
    ((58 83) (58 125))
    NIL
    ((0 42. 0 0 0 0 ))
    NATURAL)
   (2
    ((58 125) (108 125))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((108 125) (108 83))
    NIL
    ((0 -42. 0 0 0 0 ))
    NATURAL)
   (11
    ((108 83) (117 61) (134 46) (156 37) (185 31) (214 29)
     (241 31) (269 37) (291 46) (308 61) (317 83))
    NIL
    ((7.0843725 -23.486187 0 0 11.493761 8.9171257 )
     (12.831253 -19.027622 11.493761 8.9171257 -9.4688053 -2.58563423 )
     (19.59061 -11.4033146 2.02495432 6.33149148 8.381464 -4.5745859 )
     (25.806297 -7.3591156 10.4064197 1.75690555 -12.057056 2.88397884 )
     (30.184188 -4.1602211 -1.65063834 4.6408844 -2.15322876 -0.961326600 )
     (27.456935 1.59256160E-7 -3.80386734 3.6795578 8.66997529 0.961325646 )
     (27.988056 4.1602211 4.86610794 4.64088345 -14.526672 -2.88397694 )
     (25.590827 7.3591156 -9.6605644 1.75690627 7.43671513 4.574584 )
     (19.64862 11.4033146 -2.22384882 6.3314905 -9.22018624 2.58563518 )
     (12.814678 19.027622 -11.444036 8.9171257 11.444036 -8.9171257 ))
    NATURAL)
   (2
    ((317 83) (317 301))
    NIL
    ((0 218. 0 0 0 0 ))
    NATURAL)
   (2
    ((317 301) (187 301))
    NIL
    ((-130. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((187 301) (187 337))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((187 337) (367 337))
    NIL
    ((180. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((367 337) (367 83))
    NIL
    ((0 -254. 0 0 0 0 ))
    NATURAL))))

((FAMILY GACHA)
 (CHARACTER 113Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:28:21)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((3
    ((73 0) (73 0) (73 337))
    NIL
    ((0 -84.25 0 0 0 505.5 )
     (0 168.5 0 505.5 0 -505.5 ))
    NATURAL)
   (2
    ((73 337) (120 337))
    NIL
    ((47. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((120 337) (120 191))
    NIL
    ((0 -146. 0 0 0 0 ))
    NATURAL)
   (2
    ((120 191) (175 191))
    NIL
    ((55. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((175 191) (320 338))
    NIL
    ((145. 147. 0 0 0 0 ))
    NATURAL)
   (2
    ((320 338) (373 338))
    NIL
    ((53. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((373 338) (214 176))
    NIL
    ((-159. -162. 0 0 0 0 ))
    NATURAL)
   (2
    ((214 176) (418 0))
    NIL
    ((204. -176. 0 0 0 0 ))
    NATURAL)
   (2
    ((418 0) (347 0))
    NIL
    ((-71. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((347 0) (170 155))
    NIL
    ((-177. 155. 0 0 0 0 ))
    NATURAL)
   (2
    ((170 155) (120 155))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((120 155) (120 0))
    NIL
    ((0 -155. 0 0 0 0 ))
    NATURAL)
   (2
    ((120 0) (73 0))
    NIL
    ((-47. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY GACHA)
 (CHARACTER 114Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:29:42)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((82 337) (82 0))
    NIL
    ((0 -337. 0 0 0 0 ))
    NATURAL)
   (2
    ((82 0) (390 0))
    NIL
    ((308. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((390 0) (390 36))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((390 36) (134 36))
    NIL
    ((-256. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((134 36) (134 337))
    NIL
    ((0 301. 0 0 0 0 ))
    NATURAL)
   (2
    ((134 337) (82 337))
    NIL
    ((-52. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY GACHA)
 (CHARACTER 115Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:34:46)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((40 0) (40 337))
    NIL
    ((0 337. 0 0 0 0 ))
    NATURAL)
   (2
    ((40 337) (102 337))
    NIL
    ((62. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((102 337) (219 80))
    NIL
    ((117. -257. 0 0 0 0 ))
    NATURAL)
   (2
    ((219 80) (335 337))
    NIL
    ((116. 257. 0 0 0 0 ))
    NATURAL)
   (2
    ((335 337) (397 337))
    NIL
    ((62. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((397 337) (397 0))
    NIL
    ((0 -337. 0 0 0 0 ))
    NATURAL)
   (2
    ((397 0) (346 0))
    NIL
    ((-51. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((346 0) (346 260))
    NIL
    ((0 260. 0 0 0 0 ))
    NATURAL)
   (2
    ((346 260) (219 -8))
    NIL
    ((-127. -268. 0 0 0 0 ))
    NATURAL)
   (2
    ((219 -8) (92 260))
    NIL
    ((-127. 268. 0 0 0 0 ))
    NATURAL)
   (2
    ((92 260) (92 0))
    NIL
    ((0 -260. 0 0 0 0 ))
    NATURAL)
   (2
    ((92 0) (40 0))
    NIL
    ((-52. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 104Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 21-SEP-77 13:35:12)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((3
    ((51 0) (51 0) (51 337))
    NIL
    ((0 -84.25 0 0 0 505.5 )
     (0 168.5 0 505.5 0 -505.5 ))
    NATURAL)
   (2
    ((51 337) (231 337))
    NIL
    ((180. 0 0 0 0 0 ))
    NATURAL)
   (13
    ((231 337) (280 330) (322 313) (352 291) (373 264) (388 220)
     (393 169) (388 118) (373 74) (352 47) (322 25) (280 8)
     (231 0))
    NIL
    ((50.16728 -4.66153813 0 0 -7.0037012 -14.030771 )
     (46.665428 -11.6769237 -7.0037012 -14.030771 -6.98149396 10.153858 )
     (36.170982 -20.630764 -13.985195 -3.87691164 4.92968178 3.4153304 )
     (24.650627 -22.80001 -9.05551339 -0.461581111 5.26276684 -23.815181 )
     (18.226497 -35.169181 -3.79274607 -24.276763 -7.9807539 19.845397 )
     (10.4433746 -49.523246 -11.7735 -4.4313631 2.66025162 4.43358326 )
     (-3.18512320E-7 -51.737815 -9.1132488 0.00222035451 -2.66025162 4.42026043 )
     (-10.4433746 -49.525467 -11.7735 4.42248154 7.98075486 19.885368 )
     (-18.226497 -35.1603 -3.79274559 24.307849 -5.26276779 -23.961738 )
     (-24.650627 -22.83332 -9.05551339 0.346110821 -4.92968178 3.96159315 )
     (-36.170982 -20.506412 -13.985195 4.30770397 6.9814949 8.1153679 )
     (-46.665428 -12.1410236 -7.00370026 12.4230728 7.00370026 -12.4230728 ))
    NATURAL)
   (2
    ((231 0) (51 0))
    NIL
    ((-180. 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((101 301) (225 301))
    NIL
    ((124. 0 0 0 0 0 ))
    NATURAL)
   (15
    ((225 301) (250 300) (278 295) (298 286) (314 273) (331 245)
     (340 208) (343 169) (340 130) (331 93) (314 65) (298 52)
     (278 43) (250 38) (225 37))
    NIL
    ((23.713207 -0.204053551 0 0 7.72074509 -4.77567864 )
     (27.573581 -2.59189272 7.72074509 -4.77567864 -20.603725 -0.121606826 )
     (24.992462 -7.42837525 -12.882982 -4.89728546 8.6941681 5.2621088 )
     (16.456562 -9.69460679 -4.18881417 0.364823341 9.82705308 -20.926826 )
     (17.181274 -19.793197 5.6382389 -20.562004 -18.00238 12.4452057 )
     (13.818325 -34.132598 -12.364141 -8.1167984 8.1824684 7.145998 )
     (5.54541779 -38.676399 -4.18167305 -0.970800281 -2.72749042 0.970800281 )
     (1.58324837E-7 -39.161796 -6.90916348 3.19420294E-8 2.72748947 0.970800043 )
     (-5.54541779 -38.676399 -4.181674 0.970800162 -8.1824665 7.145998 )
     (-13.818325 -34.132598 -12.364141 8.1167984 18.002376 12.4452057 )
     (-17.181274 -19.793193 5.63823796 20.562004 -9.82705117 -20.926826 )
     (-16.456562 -9.69460488 -4.1888132 -0.364823401 -8.6941681 5.2621088 )
     (-24.992462 -7.4283743 -12.882982 4.89728546 20.603725 -0.121606826 )
     (-27.573581 -2.59189272 7.72074509 4.77567864 -7.72074509 -4.77567864 ))
    NATURAL)
   (2
    ((225 37) (101 36))
    NIL
    ((-124. -1. 0 0 0 0 ))
    NATURAL)
   (2
    ((101 36) (101 301))
    NIL
    ((0 265. 0 0 0 0 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/GACHAE.UC2-SF b/obsolete/lispusers/splinefonts/GACHAE.UC2-SF
deleted file mode 100644
index 56a9f2bd..00000000
--- a/obsolete/lispusers/splinefonts/GACHAE.UC2-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY GACHA)
 (CHARACTER 116Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:42:48)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((3
    ((61 0) (61 0) (111 0))
    NIL
    ((-12.5 0 0 0 75. 0 )
     (25. 0 75. 0 -75. 0 ))
    NATURAL)
   (2
    ((111 0) (111 295))
    NIL
    ((0 295. 0 0 0 0 ))
    NATURAL)
   (2
    ((111 295) (312 0))
    NIL
    ((201. -295. 0 0 0 0 ))
    NATURAL)
   (2
    ((312 0) (376 0))
    NIL
    ((64. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((376 0) (376 337))
    NIL
    ((0 337. 0 0 0 0 ))
    NATURAL)
   (2
    ((376 337) (326 337))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((326 337) (326 42))
    NIL
    ((0 -295. 0 0 0 0 ))
    NATURAL)
   (2
    ((326 42) (125 337))
    NIL
    ((-201. 295. 0 0 0 0 ))
    NATURAL)
   (2
    ((125 337) (61 337))
    NIL
    ((-64. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((61 337) (61 0))
    NIL
    ((0 -337. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 117Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 12:52:08)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((29
    ((222 22) (257 25) (286 34) (316 51) (334 75) (346 105)
     (351 140) (353 169) (351 198) (346 233) (334 263) (316 287)
     (286 304) (255 313) (222 316) (189 313) (158 304) (128 287)
     (110 263) (98 233) (93 198) (91 169) (93 140) (98 105)
     (110 75) (128 51) (158 34) (187 25) (222 22))
    NIL
    ((36.888336 1.854002 0 0 -11.3300247 6.875988 )
     (31.223323 5.291996 -11.3300247 6.875988 20.650123 1.62005996 )
     (30.21836 12.978014 9.32010079 8.49604798 -29.270477 -1.35623073 )
     (24.90322 20.795944 -19.950378 7.13981724 18.431793 -2.19513702 )
     (14.168741 26.838195 -1.51858186 4.9446802 -8.456707 4.13677883 )
     (8.42180444 33.851265 -9.9752903 9.08145906 9.3950348 -20.351982 )
     (3.14403296 32.756729 -0.580255032 -11.270523 -5.1234331 11.271158 )
     (0.00206090975 27.121788 -5.70368862 6.36285287E-4 5.09869957 11.2673397 )
     (-3.15227747 32.756095 -0.604988218 11.2679767 -9.2713661 -20.340518 )
     (-8.39294816 33.853813 -9.8763561 -9.0725422 7.98676587 4.09474373 )
     (-14.2759208 26.82864 -1.88958955 -4.97779846 -16.675693 -2.03846168 )
     (-24.50336 20.831611 -18.565284 -7.01626015 22.716026 -1.94089889 )
     (-31.710632 12.844902 4.15074253 -8.95715905 -8.18842698 3.80206299 )
     (-31.654102 5.78877354 -4.0376854 -5.15509606 4.0376854 -1.26735592 )
     (-33.672943 1.58324837E-7 0 -6.42245198 4.0376854 1.26735496 )
     (-31.654102 -5.78877449 4.0376854 -5.155097 -8.18842698 -3.80206204 )
     (-31.710632 -12.844902 -4.15074253 -8.95715905 22.716026 1.94089889 )
     (-24.503356 -20.831611 18.565284 -7.01626015 -16.675693 2.03846168 )
     (-14.2759208 -26.82864 1.88958955 -4.97779846 7.98676396 -4.09474564 )
     (-8.39294816 -33.853813 9.8763542 -9.0725441 -9.2713642 20.340518 )
     (-3.15227747 -32.756095 0.604989052 11.2679767 5.09869957 -11.2673397 )
     (0.00206130743 -27.121788 5.70368862 6.36285287E-4 -5.1234331 -11.271158 )
     (3.14403296 -32.756729 0.580254913 -11.270523 9.3950348 20.351982 )
     (8.42180444 -33.851265 9.9752903 9.08146096 -8.456707 -4.13678074 )
     (14.168741 -26.838195 1.51858258 4.9446802 18.431793 2.19513607 )
     (24.90322 -20.795944 19.950378 7.13981629 -29.270477 1.35623169 )
     (30.21836 -12.978012 -9.32010079 8.49604798 20.650123 -1.62006092 )
     (31.223323 -5.29199505 11.3300247 6.87598706 -11.3300247 -6.87598706 ))
    NATURAL))

  ((29
    ((42 169) (47 117) (61 78) (80 48) (102 28) (133 10)
     (180 -3) (222 -7) (264 -3) (311 10) (342 28) (364 48)
     (383 78) (397 117) (402 169) (397 221) (383 260) (364 290)
     (342 310) (311 328) (264 341) (222 345) (180 341) (133 328)
     (102 310) (80 290) (61 260) (47 221) (42 169))
    NIL
    ((0.0957953036 -55.136116 9.7570095 0.390455067 0.154199600 17.645336 )
     (9.92990495 -45.922988 9.9112091 18.035793 -5.3130598 -12.5694408 )
     (17.184581 -34.171913 4.5981493 5.46635247 -2.90195894 8.63244058 )
     (20.331752 -24.389339 1.69619012 14.098793 4.92089939 -15.960325 )
     (24.488395 -18.27071 6.61709023 -1.86153316 19.218349 7.20887089 )
     (40.71466 -16.527809 25.835441 5.34733773 -39.794303 5.12484169 )
     (46.652946 -8.6180496 -13.958868 10.472179 13.9589 -3.70823574 )
     (39.67353 1.14440918E-5 3.27086381E-5 6.76394368 13.958702 3.70810032 )
     (46.652915 8.61800576 13.958736 10.472044 -39.793716 -5.12416935 )
     (40.71479 16.527965 -25.834983 5.34787464 19.216178 -7.21142007 )
     (24.487899 18.27013 -6.61880208 -1.86354613 4.92899609 15.969852 )
     (20.333595 24.39151 -1.68980574 14.106308 -2.93216896 -8.66798974 )
     (17.1777038 34.163818 -4.62197495 5.4383173 -5.20031739 12.7020969 )
     (9.9555721 45.953193 -9.8222923 18.140415 -0.266559601 -18.140411 )
     (-6.37024641E-7 55.023399 -10.0888519 1.02214494E-6 0.266559601 -18.140419 )
     (-9.9555721 45.953186 -9.8222923 -18.140419 5.20031739 12.7021007 )
     (-17.1777038 34.163818 -4.62197495 -5.4383173 2.93216944 -8.6679878 )
     (-20.333595 24.39151 -1.68980551 -14.106306 -4.92899609 15.96985 )
     (-24.487899 18.27013 -6.61880208 1.86354565 -19.216178 -7.21142007 )
     (-40.71479 16.527965 -25.834983 -5.34787464 39.793716 -5.12416935 )
     (-46.652915 8.61800386 13.958738 -10.472044 -13.958704 3.70809937 )
     (-39.67353 1.11255794E-5 3.27086381E-5 -6.76394463 -13.9589 -3.70823288 )
     (-46.652946 -8.6180496 -13.958868 -10.472177 39.794303 5.12483883 )
     (-40.71466 -16.527809 25.835441 -5.34733868 -19.218349 7.20887185 )
     (-24.488391 -18.27071 6.61709119 1.86153364 -4.9209013 -15.960327 )
     (-20.331752 -24.389339 1.6961894 -14.0987949 2.90196085 8.63244248 )
     (-17.184581 -34.171913 4.59815026 -5.4663515 5.31305886 -12.5694408 )
     (-9.929903 -45.922988 9.9112091 -18.035793 -0.154199600 17.645336 ))
    PSEUDOCYCLIC))))

((FAMILY gacha)
 (CHARACTER 120Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 13:02:12)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((3
    ((81 0) (81 0) (81 337))
    NIL
    ((0 -84.25 0 0 0 505.5 )
     (0 168.5 0 505.5 0 -505.5 ))
    NATURAL)
   (2
    ((81 337) (261 337))
    NIL
    ((180. 0 0 0 0 0 ))
    NATURAL)
   (13
    ((261 337) (287 336) (318 331) (346 318) (363 300) (375 272)
     (381 236) (375 200) (363 172) (346 154) (318 141) (287 136)
     (261 135))
    NIL
    ((24.635082 -0.447435856 0 0 8.18948937 -3.31538487 )
     (28.729827 -2.10512829 8.18948937 -3.31538487 -10.9474468 -7.42307568 )
     (31.445594 -9.13205148 -2.75795746 -10.7384605 -12.399702 9.0076904 )
     (22.487785 -15.3666668 -15.157659 -1.73076916 12.5462589 -10.6076908 )
     (13.603256 -22.401279 -2.61139917 -12.3384609 -1.78534364 3.42307854 )
     (10.099184 -33.028198 -4.39674282 -8.9153824 -11.404884 8.91538049 )
     (-1.60187482E-7 -37.485893 -15.801628 -5.11072471E-7 11.404884 8.9153843 )
     (-10.099184 -33.028198 -4.39674282 8.9153843 1.78534364 3.42307472 )
     (-13.603256 -22.401279 -2.61139917 12.338459 -12.5462589 -10.6076889 )
     (-22.487785 -15.3666649 -15.157659 1.73077011 12.399702 9.0076885 )
     (-31.445594 -9.13204957 -2.7579565 10.7384586 10.947443 -7.42307377 )
     (-28.729827 -2.10512829 8.18948747 3.31538487 -8.18948747 -3.31538487 ))
    NATURAL)
   (2
    ((261 135) (134 135))
    NIL
    ((-127. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((134 135) (134 0))
    NIL
    ((0 -135. 0 0 0 0 ))
    NATURAL)
   (2
    ((134 0) (81 0))
    NIL
    ((-53. 0 0 0 0 0 ))
    NATURAL))

  ((9
    ((261 301) (283 299) (306 293) (323 270) (329 238) (323 206)
     (306 183) (283 177) (261 175))
    NIL
    ((21.463916 -1.98214268 0 0 3.21649456 -0.107143402 )
     (23.072162 -2.03571415 3.21649456 -0.107143402 -10.0824737 -23.464283 )
     (21.247421 -13.875 -6.8659792 -23.571426 -4.88659764 15.964283 )
     (11.9381427 -29.464283 -11.7525768 -7.60714245 -0.371133804 7.60714245 )
     (-3.18512320E-7 -33.267852 -12.1237106 2.55529982E-7 0.371133804 7.60714055 )
     (-11.9381446 -29.464283 -11.7525768 7.6071415 4.88659859 15.9642849 )
     (-21.247421 -13.874998 -6.86597825 23.571426 10.0824718 -23.464283 )
     (-23.072162 -2.03571415 3.21649504 0.107142448 -3.21649504 -0.107142448 ))
    NATURAL)
   (2
    ((261 175) (134 175))
    NIL
    ((-127. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((134 175) (134 301))
    NIL
    ((0 126. 0 0 0 0 ))
    NATURAL)
   (2
    ((134 301) (261 301))
    NIL
    ((127. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 121Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 13:08:33)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((29
    ((222 22) (187 25) (158 34) (128 51) (110 75) (98 105)
     (93 140) (91 169) (93 198) (98 233) (110 263) (128 287)
     (158 304) (189 313) (222 316) (255 313) (286 304) (316 287)
     (334 263) (346 233) (351 198) (353 169) (351 140) (346 105)
     (334 75) (316 51) (286 34) (257 25) (222 22))
    NIL
    ((-36.888336 1.854002 0 0 11.3300247 6.875988 )
     (-31.223323 5.291996 11.3300247 6.875988 -20.650123 1.62005996 )
     (-30.21836 12.978014 -9.32010079 8.49604798 29.270477 -1.35623073 )
     (-24.90322 20.795944 19.950378 7.13981724 -18.431793 -2.19513702 )
     (-14.168741 26.838195 1.51858186 4.9446802 8.456707 4.13677883 )
     (-8.42180444 33.851265 9.9752903 9.08145906 -9.3950348 -20.351982 )
     (-3.14403296 32.756729 0.580255032 -11.270523 5.1234331 11.271158 )
     (-0.00206090975 27.121788 5.70368862 6.36285287E-4 -5.09869957 11.2673397 )
     (3.15227747 32.756095 0.604988218 11.2679767 9.2713661 -20.340518 )
     (8.39294816 33.853813 9.8763561 -9.0725422 -7.98676587 4.09474373 )
     (14.2759208 26.82864 1.88958955 -4.97779846 16.675693 -2.03846168 )
     (24.50336 20.831611 18.565284 -7.01626015 -22.716026 -1.94089889 )
     (31.710632 12.844902 -4.15074253 -8.95715905 8.18842698 3.80206299 )
     (31.654102 5.78877354 4.0376854 -5.15509606 -4.0376854 -1.26735592 )
     (33.672943 1.58324837E-7 0 -6.42245198 -4.0376854 1.26735496 )
     (31.654102 -5.78877449 -4.0376854 -5.155097 8.18842698 -3.80206204 )
     (31.710632 -12.844902 4.15074253 -8.95715905 -22.716026 1.94089889 )
     (24.503356 -20.831611 -18.565284 -7.01626015 16.675693 2.03846168 )
     (14.2759208 -26.82864 -1.88958955 -4.97779846 -7.98676396 -4.09474564 )
     (8.39294816 -33.853813 -9.8763542 -9.0725441 9.2713642 20.340518 )
     (3.15227747 -32.756095 -0.604989052 11.2679767 -5.09869957 -11.2673397 )
     (-0.00206130743 -27.121788 -5.70368862 6.36285287E-4 5.1234331 -11.271158 )
     (-3.14403296 -32.756729 -0.580254913 -11.270523 -9.3950348 20.351982 )
     (-8.42180444 -33.851265 -9.9752903 9.08146096 8.456707 -4.13678074 )
     (-14.168741 -26.838195 -1.51858258 4.9446802 -18.431793 2.19513607 )
     (-24.90322 -20.795944 -19.950378 7.13981629 29.270477 1.35623169 )
     (-30.21836 -12.978012 9.32010079 8.49604798 -20.650123 -1.62006092 )
     (-31.223323 -5.29199505 -11.3300247 6.87598706 11.3300247 -6.87598706 ))
    NATURAL))

  ((2
    ((264 -3) (256 -5))
    NIL
    ((-8. -2. 0 0 0 0 ))
    NATURAL)
   (5
    ((256 -5) (255 -17) (261 -29) (273 -34) (285 -34))
    NIL
    ((-2.4464283 -11.5892849 0 0 8.6785698 -2.46428537 )
     (1.89285755 -12.821428 8.6785698 -2.46428537 -1.39285564 12.321426 )
     (9.875 -9.1249981 7.28571416 9.8571415 -9.1071415 -4.82142735 )
     (12.607141 -1.67857122 -1.8214283 5.03571415 1.8214283 -5.03571415 ))
    NATURAL)
   (2
    ((285 -34) (367 -34))
    NIL
    ((82. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((367 -34) (367 -69))
    NIL
    ((0 -35. 0 0 0 0 ))
    NATURAL)
   (2
    ((367 -69) (262 -69))
    NIL
    ((-105. 0 0 0 0 0 ))
    NATURAL)
   (6
    ((262 -69) (243 -66) (225 -58) (213 -44) (208 -22) (208 -4))
    NIL
    ((-18.947364 1.91866016 0 0 -0.315789461 6.48803807 )
     (-19.105262 5.16267872 -0.315789461 6.48803807 7.57894707 -2.44019127 )
     (-15.631578 10.430622 7.26315785 4.0478468 -9.53674316E-7 9.27272416 )
     (-8.36841966 19.11483 7.2631569 13.3205719 -1.57894706 -22.650714 )
     (-1.89473653 21.110046 5.68420983 -9.33014298 -5.68420983 9.33014298 ))
    NATURAL)
   (2
    ((208 -4) (180 -3))
    NIL
    ((-28. 1. 0 0 0 0 ))
    NATURAL)
   (27
    ((180 -3) (133 10) (102 28) (80 48) (61 78) (47 117)
     (42 169) (47 221) (61 260) (80 290) (102 310) (133 328)
     (180 341) (222 345) (264 341) (311 328) (342 310) (364 290)
     (383 260) (397 221) (402 169) (397 117) (383 78) (364 48)
     (342 28) (311 10) (264 -3))
    NIL
    ((-50.682457 11.6410236 0 0 22.094749 8.15385057 )
     (-39.635078 15.7179489 22.094749 8.15385057 -14.4737549 -10.7692546 )
     (-24.777206 18.487171 7.62099457 -2.61540413 -6.19972516 16.923168 )
     (-20.256076 24.333354 1.4212687 14.3077659 3.27266073 -8.92342759 )
     (-17.1984749 34.179405 4.69392967 5.38433743 5.10908127 12.7705459 )
     (-9.95000649 45.949012 9.80301095 18.154884 0.291007995 -18.15876 )
     (-0.00149090960 55.02452 10.0940189 -0.00387597363 -0.273111343 -18.135498 )
     (9.95597268 45.952888 9.8209076 -18.139377 -5.19856167 12.7007808 )
     (17.177597 34.163902 4.62234593 -5.43859673 -2.93264007 -8.66763497 )
     (20.333625 24.391487 1.68970585 -14.1062317 4.92912293 15.969757 )
     (24.487892 18.2701339 6.61882878 1.86352634 19.216144 -7.2113981 )
     (40.714798 16.527961 25.834976 -5.34787178 -39.793716 -5.12416458 )
     (46.652908 8.61800767 -13.958744 -10.472036 13.958744 3.7080555 )
     (39.673538 -6.37024641E-7 0 -6.76398087 13.958744 -3.70805359 )
     (46.652908 -8.61800958 13.958744 -10.472034 -39.793716 5.12416172 )
     (40.71479 -16.527961 -25.834976 -5.34787274 19.216144 7.21139908 )
     (24.487892 -18.2701339 -6.61882878 1.86352634 4.92912197 -15.969757 )
     (20.333625 -24.391487 -1.68970608 -14.1062317 -2.93264055 8.66763497 )
     (17.177597 -34.163902 -4.62234688 -5.43859577 -5.1985607 -12.7007808 )
     (9.95597077 -45.952888 -9.8209076 -18.139377 -0.273111343 18.135498 )
     (-0.00149186514 -55.02452 -10.0940189 -0.00387699622 0.291007995 18.15876 )
     (-9.95000649 -45.949012 -9.80301095 18.154884 5.10908127 -12.7705478 )
     (-17.198478 -34.179405 -4.69392967 5.38433647 3.2726612 8.9234295 )
     (-20.256076 -24.33335 -1.42126846 14.3077659 -6.19972706 -16.923168 )
     (-24.777206 -18.487171 -7.6209955 -2.6154046 -14.4737529 10.7692546 )
     (-39.635078 -15.7179489 -22.094749 8.15385057 22.094749 -8.15385057 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 122Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 13:19:31)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((3
    ((73 0) (73 0) (73 337))
    NIL
    ((0 -84.25 0 0 0 505.5 )
     (0 168.5 0 505.5 0 -505.5 ))
    NATURAL)
   (2
    ((73 337) (244 337))
    NIL
    ((171. 0 0 0 0 0 ))
    NATURAL)
   (7
    ((244 337) (280 335) (316 328) (345 311) (362 286) (367 255)
     (367 242))
    NIL
    ((35.673072 -1.27820491 0 0 1.96153855 -4.33076954 )
     (36.653839 -3.44358969 1.96153855 -4.33076954 -9.80769158 -8.34615136 )
     (33.711532 -11.947435 -7.8461542 -12.6769218 -4.73076725 7.71538354 )
     (23.499996 -20.766666 -12.576921 -4.9615383 -1.26923179 -10.5153846 )
     (10.2884597 -30.985897 -13.846153 -15.476923 9.80769158 46.346145 )
     (1.34615373 -23.289741 -4.03846169 30.869228 4.03846169 -30.869228 ))
    NATURAL)
   (6
    ((367 242) (367 229) (362 198) (345 173) (316 156) (292 151))
    NIL
    ((0.732057333 -7.84210587 0 0 -4.39234448 -30.947364 )
     (-1.46411466 -23.315788 -4.39234448 -30.947364 -8.03827668 46.73683 )
     (-9.875597 -30.894733 -12.430622 15.789472 -5.45454407 -11.999998 )
     (-25.033493 -21.105262 -17.885166 3.78947306 29.856456 13.2631569 )
     (-27.990428 -10.6842098 11.9712906 17.052631 -11.9712906 -17.052631 ))
    NATURAL)
   (2
    ((292 151) (360 0))
    NIL
    ((68. -151. 0 0 0 0 ))
    NATURAL)
   (2
    ((360 0) (305 0))
    NIL
    ((-55. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((305 0) (239 147))
    NIL
    ((-66. 147. 0 0 0 0 ))
    NATURAL)
   (2
    ((239 147) (120 147))
    NIL
    ((-119. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((120 147) (120 0))
    NIL
    ((0 -147. 0 0 0 0 ))
    NATURAL)
   (2
    ((120 0) (73 0))
    NIL
    ((-47. 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((120 183) (120 301))
    NIL
    ((0 118. 0 0 0 0 ))
    NATURAL)
   (2
    ((120 301) (226 301))
    NIL
    ((106. 0 0 0 0 0 ))
    NATURAL)
   (6
    ((226 301) (272 299) (293 292) (307 280) (313 265) (315 242))
    NIL
    ((52.330139 -1. 0 0 -37.980857 -6. )
     (33.339706 -4. -37.980857 -6. 39.904296 0 )
     (15.311004 -10. 1.92344451 -6. -13.63636 6. )
     (10.416267 -13. -11.712917 0 8.6411457 -12. )
     (3.0239234 -19. -3.07177019 -12. 3.07177019 12. ))
    NATURAL)
   (6
    ((315 242) (313 219) (307 204) (293 192) (272 185) (226 183))
    NIL
    ((-1.48803806 -24.999996 0 0 -3.07177067 11.999998 )
     (-3.0239234 -18.999996 -3.07177067 11.999998 -8.6411457 -11.999996 )
     (-10.416267 -12.999998 -11.712917 2.54313135E-7 13.636358 5.9999981 )
     (-15.311004 -9.9999981 1.92344212 5.99999905 -39.904289 9.53674316E-7 )
     (-33.339714 -4. -37.98085 6. 37.98085 -6. ))
    NATURAL)
   (2
    ((226 183) (120 183))
    NIL
    ((-106. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 123Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 13:39:15)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((370 259) (328 259))
    NIL
    ((-42. 0 0 0 0 0 ))
    NATURAL)
   (19
    ((328 259) (319 283) (296 300) (270 309) (220 313) (178 311)
     (154 307) (129 297) (113 280) (109 264) (115 239) (145 218)
     (182 212) (218 209) (273 203) (318 191) (350 172) (371 140)
     (378 88))
    NIL
    ((-4.98698998 25.367855 0 0 -24.07806 -8.2071476 )
     (-17.02602 21.264282 -24.07806 -8.2071476 36.390304 -0.964258195 )
     (-22.908927 12.575006 12.312244 -9.1714058 -55.48316 6.06417847 )
     (-38.338264 6.43568993 -43.17092 -3.10722733 59.54238 -5.29245758 )
     (-51.737999 0.682233811 16.371463 -8.3996849 9.31360246 9.10564996 )
     (-30.709728 -3.16462517 25.685066 0.705966711 -36.796806 -7.13014699 )
     (-23.423069 -6.02373219 -11.1117458 -6.42418099 23.873664 -4.58506012 )
     (-22.597984 -14.740444 12.761919 -11.009241 1.30215072 19.470386 )
     (-9.1849899 -16.014488 14.0640697 8.4611473 -11.0822677 -25.296493 )
     (-0.662053824 -20.201587 2.9818015 -16.835346 31.026916 21.71558 )
     (17.833206 -26.179142 34.00872 4.88023567 -29.025417 16.434162 )
     (37.329216 -13.081827 4.98330307 21.314399 -16.925239 -21.452232 )
     (33.849899 -2.4935441 -11.941936 -0.137833327 48.72637 -2.62523365 )
     (46.271156 -3.943995 36.784439 -2.76306724 -57.98026 -4.04682827 )
     (54.06546 -8.73047639 -21.195827 -6.8098955 9.19470979 0.812546731 )
     (37.466987 -15.134098 -12.0011177 -5.99734879 3.20141602 -5.20335579 )
     (27.066577 -23.733127 -8.7997017 -11.2007045 -10.00037 -15.9991169 )
     (13.266689 -42.933387 -18.800071 -27.199821 18.800071 27.199821 ))
    NATURAL)
   (11
    ((378 88) (369 49) (349 23) (314 4) (273 -6) (214 -9)
     (151 -5) (106 7) (73 25) (46 52) (36 84))
    NIL
    ((-7.0958252 -42.124916 0 0 -11.425045 18.749504 )
     (-12.8083477 -32.75016 -11.425045 18.749504 -8.87477494 -15.74752 )
     (-28.67078 -21.87442 -20.299819 3.00198221 22.924152 8.2405815 )
     (-37.508522 -14.752147 2.62433576 11.242565 -28.821849 -5.2148094 )
     (-49.295112 -6.11698628 -26.197517 6.02775574 20.363262 0.618652344 )
     (-65.311004 0.220096260 -5.8342533 6.64640809 31.368785 2.74019813 )
     (-55.46086 8.2366047 25.534534 9.3866062 -13.838428 -5.57944775 )
     (-36.845535 14.833486 11.6961059 3.80715847 -12.015068 7.5775995 )
     (-31.156967 22.429443 -0.318962395 11.384758 25.898704 -6.7309475 )
     (-18.52658 30.448726 25.579742 4.6538105 -25.579742 -4.6538105 ))
    NATURAL)
   (2
    ((36 84) (88 84))
    NIL
    ((52. 0 0 0 0 0 ))
    NATURAL)
   (4
    ((88 84) (103 56) (127 40) (166 28))
    NIL
    ((13.599998 -30.93333 0 0 8.3999996 17.599998 )
     (17.799999 -22.133331 8.3999996 17.599998 11.999998 -15.999998 )
     (32.199997 -12.5333328 20.399997 1.5999999 -20.399997 -1.5999999 ))
    NATURAL)
   (25
    ((166 28) (208 23) (248 25) (287 31) (320 57) (330 99)
     (322 135) (292 152) (248 159) (193 165) (140 174) (103 188)
     (75 209) (60 237) (57 264) (69 299) (91 320) (124 334)
     (165 343) (216 345) (261 343) (300 335) (336 316) (360 289)
     (370 259))
    NIL
    ((42.478797 -6.88853169 0 0 -2.87278843 11.331192 )
     (41.042396 -1.22293496 -2.87278843 11.331192 2.36394262 -14.6559658 )
     (39.351585 2.78027391 -0.508845687 -3.32477379 -0.582982898 29.292675 )
     (38.551246 14.1018409 -1.09182858 25.967903 -30.032005 -6.51475526 )
     (22.443412 36.812362 -31.123836 19.453147 18.711029 -27.23365 )
     (0.675090075 42.648689 -12.412805 -7.7805023 -14.812124 -16.550632 )
     (-19.1437759 26.592868 -27.224929 -24.331134 16.53746 15.43618 )
     (-38.099975 9.97982408 -10.6874675 -8.89495469 -3.3377304 8.805912 )
     (-50.456306 5.48782635 -14.025198 -0.0890419930 14.813459 3.34016419 )
     (-57.074775 7.06886674 0.788262964 3.25112248 22.083881 1.83342743 )
     (-45.244567 11.2367038 22.872146 5.0845499 -19.14899 1.3261261 )
     (-31.946922 16.984317 3.7231555 6.410676 12.512073 4.8620653 )
     (-21.967727 25.826026 16.235229 11.272741 -6.89930726 -20.774387 )
     (-9.1821537 26.711574 9.33592225 -9.50164796 9.0851593 30.235496 )
     (4.69634819 32.327667 18.421081 20.733848 -11.4413375 -46.167587 )
     (17.3967628 29.977726 6.97974396 -25.433738 6.68019105 22.434852 )
     (27.716602 15.761413 13.659935 -2.9988861 -9.27941896 -1.57182884 )
     (36.736824 11.976614 4.3805151 -4.57071495 12.4374847 -4.14753914 )
     (47.336082 5.33212757 16.818 -8.7182541 -28.470516 6.1619911 )
     (49.918823 -0.305130005 -11.652515 -2.55626249 5.4445772 -2.50043249 )
     (40.988594 -4.1116085 -6.2079382 -5.05669499 6.69220734 -8.16025926 )
     (38.126762 -13.248434 0.484269857 -13.216955 -14.213407 5.14147759 )
     (31.504329 -23.894649 -13.729139 -8.0754776 -3.83857536 5.59434796 )
     (15.855903 -29.172954 -17.567714 -2.48112965 17.567714 2.48112965 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 124Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 13:44:08)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((192 0) (192 301))
    NIL
    ((0 301. 0 0 0 0 ))
    NATURAL)
   (2
    ((192 301) (52 301))
    NIL
    ((-140. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((52 301) (52 337))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((52 337) (388 337))
    NIL
    ((336. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((388 337) (388 301))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL)
   (2
    ((388 301) (254 301))
    NIL
    ((-134. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((254 301) (254 0))
    NIL
    ((0 -301. 0 0 0 0 ))
    NATURAL)
   (2
    ((254 0) (192 0))
    NIL
    ((-62. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 125Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 13:47:06)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((13
    ((390 83) (381 56) (364 35) (340 18) (309 5) (271 -4)
     (220 -8) (169 -4) (132 5) (100 18) (76 35) (60 56)
     (51 83))
    NIL
    ((-7.24374676 -28.381198 0 0 -10.5375175 8.2871933 )
     (-12.512506 -24.237598 -10.5375175 8.2871933 4.6875944 -5.4359722 )
     (-20.706226 -18.668392 -5.84992314 2.85122108 -2.21286487 1.45669841 )
     (-27.662582 -15.088821 -8.062788 4.3079195 4.16386414 -0.390820980 )
     (-33.643432 -10.9763126 -3.8989234 3.91709852 -14.4425907 0.106587886 )
     (-44.763656 -7.00592137 -18.341514 4.0236864 17.606502 5.96446896 )
     (-54.301918 6.37024641E-7 -0.735011101 9.98815537 22.016567 -5.9644699 )
     (-44.02864 7.00592137 21.281559 4.02368546 -21.67279 -0.106587410 )
     (-33.58348 10.9763126 -0.391231656 3.91709805 10.6745968 0.390821457 )
     (-28.637413 15.088821 10.283365 4.3079195 -3.02559567 -1.45669794 )
     (-19.866848 18.668392 7.25776959 2.85122156 1.42778682 5.43597126 )
     (-11.895185 24.237602 8.6855564 8.2871933 -8.6855564 -8.2871933 ))
    NATURAL)
   (2
    ((51 83) (51 337))
    NIL
    ((0 254. 0 0 0 0 ))
    NATURAL)
   (2
    ((51 337) (101 337))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((101 337) (101 83))
    NIL
    ((0 -254. 0 0 0 0 ))
    NATURAL)
   (10
    ((101 83) (110 61) (127 46) (149 37) (196 30) (245 30)
     (292 37) (314 46) (331 61) (340 83))
    NIL
    ((6.73856164 -23.4566 0 0 13.568626 8.7396221 )
     (13.5228748 -19.086792 13.568626 8.7396221 -19.843132 -1.69811344 )
     (17.169933 -11.196226 -6.27450753 7.04150868 47.803909 -7.94716836 )
     (34.797386 -8.1283016 41.529403 -0.905660153 -51.372535 9.4867897 )
     (50.640518 -4.29056549 -9.8431358 8.58113099 19.686271 0 )
     (50.640518 4.29056549 9.8431358 8.58113099 -51.372535 -9.4867897 )
     (34.797378 8.1283016 -41.529403 -0.905660153 47.803909 7.94716836 )
     (17.169933 11.196226 6.27450944 7.04150868 -19.843135 1.69811344 )
     (13.5228748 19.086792 -13.568626 8.7396221 13.568626 -8.7396221 ))
    NATURAL)
   (2
    ((340 83) (340 337))
    NIL
    ((0 254. 0 0 0 0 ))
    NATURAL)
   (2
    ((340 337) (390 337))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((390 337) (390 83))
    NIL
    ((0 -254. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 126Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 13:51:38)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((21 337) (192 0))
    NIL
    ((171. -337. 0 0 0 0 ))
    NATURAL)
   (2
    ((192 0) (248 0))
    NIL
    ((56. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((248 0) (420 337))
    NIL
    ((172. 337. 0 0 0 0 ))
    NATURAL)
   (2
    ((420 337) (370 337))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((370 337) (220 44))
    NIL
    ((-150. -293. 0 0 0 0 ))
    NATURAL)
   (2
    ((220 44) (71 337))
    NIL
    ((-149. 293. 0 0 0 0 ))
    NATURAL)
   (2
    ((71 337) (21 337))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 127Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 13:57:20)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((24 337) (90 0))
    NIL
    ((66. -337. 0 0 0 0 ))
    NATURAL)
   (2
    ((90 0) (143 0))
    NIL
    ((53. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((143 0) (221 288))
    NIL
    ((78. 288. 0 0 0 0 ))
    NATURAL)
   (2
    ((221 288) (298 0))
    NIL
    ((77. -288. 0 0 0 0 ))
    NATURAL)
   (2
    ((298 0) (351 0))
    NIL
    ((53. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((351 0) (417 337))
    NIL
    ((66. 337. 0 0 0 0 ))
    NATURAL)
   (2
    ((417 337) (367 337))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((367 337) (317 79))
    NIL
    ((-50. -258. 0 0 0 0 ))
    NATURAL)
   (2
    ((317 79) (247 337))
    NIL
    ((-70. 258. 0 0 0 0 ))
    NATURAL)
   (2
    ((247 337) (194 337))
    NIL
    ((-53. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((194 337) (124 79))
    NIL
    ((-70. -258. 0 0 0 0 ))
    NATURAL)
   (2
    ((124 79) (74 337))
    NIL
    ((-50. 258. 0 0 0 0 ))
    NATURAL)
   (2
    ((74 337) (24 337))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 130Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 14:06:06)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((49 0) (107 0))
    NIL
    ((58. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((107 0) (219 142))
    NIL
    ((112. 142. 0 0 0 0 ))
    NATURAL)
   (2
    ((219 142) (331 0))
    NIL
    ((112. -142. 0 0 0 0 ))
    NATURAL)
   (2
    ((331 0) (389 0))
    NIL
    ((58. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((389 0) (248 179))
    NIL
    ((-141. 179. 0 0 0 0 ))
    NATURAL)
   (2
    ((248 179) (372 337))
    NIL
    ((124. 158. 0 0 0 0 ))
    NATURAL)
   (2
    ((372 337) (314 337))
    NIL
    ((-58. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((314 337) (219 216))
    NIL
    ((-95. -121. 0 0 0 0 ))
    NATURAL)
   (2
    ((219 216) (125 337))
    NIL
    ((-94. 121. 0 0 0 0 ))
    NATURAL)
   (2
    ((125 337) (66 337))
    NIL
    ((-59. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((66 337) (189 179))
    NIL
    ((123. -158. 0 0 0 0 ))
    NATURAL)
   (2
    ((189 179) (49 0))
    NIL
    ((-140. -179. 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 131Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 14:08:44)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((190 0) (190 154))
    NIL
    ((0 154. 0 0 0 0 ))
    NATURAL)
   (2
    ((190 154) (30 337))
    NIL
    ((-160. 183. 0 0 0 0 ))
    NATURAL)
   (2
    ((30 337) (91 337))
    NIL
    ((61. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((91 337) (219 188))
    NIL
    ((128. -149. 0 0 0 0 ))
    NATURAL)
   (2
    ((219 188) (347 337))
    NIL
    ((128. 149. 0 0 0 0 ))
    NATURAL)
   (2
    ((347 337) (408 337))
    NIL
    ((61. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((408 337) (247 154))
    NIL
    ((-161. -183. 0 0 0 0 ))
    NATURAL)
   (2
    ((247 154) (247 0))
    NIL
    ((0 -154. 0 0 0 0 ))
    NATURAL)
   (2
    ((247 0) (190 0))
    NIL
    ((-57. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY gacha)
 (CHARACTER 132Q)
 (FACE M R E)
 (WIDTH 441 0)
 (FIDUCIAL 480 480)
 (VERSION 0 19-SEP-77 14:10:13)
 (MADE-FROM gachac.cu 0 140 0 0)
 (SPLINES

  ((2
    ((72 337) (72 301))
    NIL
    ((0 -36. 0 0 0 0 ))
    NATURAL)
   (2
    ((72 301) (293 301))
    NIL
    ((221. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((293 301) (61 29))
    NIL
    ((-232. -272. 0 0 0 0 ))
    NATURAL)
   (2
    ((61 29) (61 0))
    NIL
    ((0 -29. 0 0 0 0 ))
    NATURAL)
   (2
    ((61 0) (378 0))
    NIL
    ((317. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((378 0) (378 36))
    NIL
    ((0 36. 0 0 0 0 ))
    NATURAL)
   (2
    ((378 36) (124 36))
    NIL
    ((-254. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((124 36) (355 308))
    NIL
    ((231. 272. 0 0 0 0 ))
    NATURAL)
   (2
    ((355 308) (355 337))
    NIL
    ((0 29. 0 0 0 0 ))
    NATURAL)
   (2
    ((355 337) (72 337))
    NIL
    ((-283. 0 0 0 0 0 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/SFFONT b/obsolete/lispusers/splinefonts/SFFONT
deleted file mode 100644
index 5723b532..00000000
--- a/obsolete/lispusers/splinefonts/SFFONT
+++ /dev/null
@@ -1,717 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED " 1-Oct-91 14:10:29" |{PELE:MV:ENVOS}<LISPUSERS>MEDLEY>SFFONT.;2| 36558  
-
-      changes to%:  (VARS SFFONTCOMS)
-
-      previous date%: " 4-Feb-87 23:04:29" |{PELE:MV:ENVOS}<LISPUSERS>MEDLEY>SFFONT.;1|)
-
-
-(* ; "
-Copyright (c) 1991 by Venue.  All rights reserved.
-")
-
-(PRETTYCOMPRINT SFFONTCOMS)
-
-(RPAQQ SFFONTCOMS
-       ((RECORDS SF.CHARACTER SF.CHARDESC SF.DERIVATIVE SF.FACE SF.FAMILY SF.FIDUCIAL SF.MADE-FROM 
-               SF.SPLINE SF.SPLINES SF.VERSION SF.WIDTH)
-        (FNS READ.SPLINE.FONT SF.DERIVS.TO.BEZIER SF.PRINT SFDRAW SFDRAW.CLOSED.CURVE TEST 
-             VIEW.FONT.FILES \LOOKUPSPLINEFONT \SETSPLINEFONT ginit)
-        (DECLARE%: EVAL@LOAD DONTCOPY (FILES (LOADCOMP)
-                                             IRISSTREAM)
-               (VARS TIMESROMANDFILES TRA TRB TRC TRFILES))
-        (INITVARS (\SPLINEFONTSINCORE (LIST NIL)))
-        (GLOBALVARS \SPLINEFONTSINCORE)
-        (CONSTANTS (\CHARSEGMENTS.IRIS 10))))
-(DECLARE%: EVAL@COMPILE
-
-(RECORD SF.CHARACTER (CHARCODE))
-
-(ASSOCRECORD SF.CHARDESC (FAMILY CHARACTER FACE WIDTH FIDUCIAL VERSION SPLINES)
-                             (ACCESSFNS (SF.WIDTH (FETCH WIDTH OF DATUM))))
-
-(RECORD SF.DERIVATIVE (XPRIME YPRIME XDPRIME YDPRIME XTPRIME YTPRIME))
-
-(RECORD SF.FACE (WEIGHT SLOPE EXPANSION))
-
-(RECORD SF.FAMILY (SFFAMILY))
-
-(RECORD SF.FIDUCIAL (XFIDUCIAL YFIDUCIAL))
-
-(RECORD SF.MADE-FROM (FILENAME XCHAR.ORIGIN YCHAR.ORIGIN XFIDUCIAL.ORIGIN YFIDUCIAL.ORIGIN))
-
-(RECORD SF.SPLINE (%#OFKNOTS KNOTLIST WEIGHTLIST DERIVATIVELIST . OPTIONALSOLNMETHOD))
-
-(RECORD SF.SPLINES (CLOSEDCURVELIST))
-
-(RECORD SF.VERSION (VERSION DATE TIME))
-
-(RECORD SF.WIDTH (XWIDTH YWIDTH))
-)
-(DEFINEQ
-
-(READ.SPLINE.FONT
-  [LAMBDA (FILES FAMILY CHARSET)                             (* ; "Edited  4-Feb-87 22:54 by gbn")
-
-(* ;;; "reads SF files and updates \SPLINEFONTSINCORE.  \SPLINEFONTSINCORE looks like (((FAMILY1 CHARSET#) FONTARRAY1) ...)")
-
-(* ;;; "should learn about sd files")
-
-    (PROG (FONTARRAY FAM I CHAR)
-          (PROG1 (RETURN (BIND INPUTSTREAM for F in (OR (LISTP FILES)
-                                                        (LIST FILES))
-                            collect (RESETLST (RESETSAVE NIL (LIST 'CLOSEF? INPUTSTREAM))
-                                           (SETQ INPUTSTREAM (OPENSTREAM F 'INPUT))
-                                           (SETQ CHAR (READ INPUTSTREAM FILERDTBL))
-                                           [SETQ FAM (OR FAMILY (U-CASE (fetch SFFAMILY
-                                                                           of (fetch FAMILY
-                                                                                 of CHAR]
-                                                             (* ; 
-     "the fontarray can already be here, since a single file need not contain a whole character set.")
-                                           [if (NOT (SETQ FONTARRAY (\LOOKUPSPLINEFONT FAM CHARSET)))
-                                               then (\SETSPLINEFONT FAM CHARSET (SETQ FONTARRAY
-                                                                                 (ARRAY (ADD1 
-                                                                                         \MAXTHINCHAR
-                                                                                              ]
-                                           (PROG1 (CONS FAM
-                                                        (bind C
-                                                           repeatwhile (NEQ 'STOP (SETQ CHAR
-                                                                                   (READ INPUTSTREAM 
-                                                                                         FILERDTBL)))
-                                                           collect (SETA FONTARRAY
-                                                                         (SETQ C
-                                                                          (fetch CHARCODE
-                                                                             of (fetch CHARACTER
-                                                                                   of CHAR)))
-                                                                         CHAR)
-                                                                 (PRINTOUT PROMPTWINDOW
-                                                                        (SETQ C (CHARACTER C)))
-                                                                 C))
-                                                  (CLOSEF INPUTSTREAM])
-
-(SF.DERIVS.TO.BEZIER
-  [LAMBDA (KNOT XOFFSET YOFFSET SCALE DERIVATIVES)           (* gbn " 1-Aug-84 05:51")
-          
-          (* * Compute the Bezier control points from the derivative coefficients.
-          Stolen from <cedar5.1>graphics>cgcubicimpl.mesa Returns an array of 4 xyz 
-          points suitable for handing to the iris draw curve function
-          (IRIS.CURVE format))
-
-    (PROG [[BEZ (create BEZIER
-                       B0X _ (PLUS XOFFSET (TIMES SCALE (fetch XCOORD of KNOT)))
-                       B0Y _ (PLUS YOFFSET (TIMES SCALE (fetch YCOORD of KNOT]
-           (DERIVS (for I from 1 to (LENGTH DERIVATIVES)
-                      collect (TIMES SCALE (QUOTIENT (CAR (NTH DERIVATIVES I))
-                                                  (ELT \FACT.IRIS (IQUOTIENT (ADD1 I)
-                                                                         2]
-          (replace B1X of BEZ with (PLUS (fetch B0X of BEZ)
-                                         (QUOTIENT (fetch XPRIME of DERIVS)
-                                                3)))
-          (replace B1Y of BEZ with (PLUS (fetch B0Y of BEZ)
-                                         (QUOTIENT (fetch YPRIME of DERIVS)
-                                                3)))
-          (replace B2X of BEZ with (PLUS (fetch B1X of BEZ)
-                                         (QUOTIENT (PLUS (fetch XPRIME of DERIVS)
-                                                         (fetch XDPRIME of DERIVS))
-                                                3)))
-          (replace B2Y of BEZ with (PLUS (fetch B1Y of BEZ)
-                                         (QUOTIENT (PLUS (fetch YPRIME of DERIVS)
-                                                         (fetch YDPRIME of DERIVS))
-                                                3)))
-          (replace B3X of BEZ with (PLUS (fetch B0X of BEZ)
-                                         (fetch XPRIME of DERIVS)
-                                         (fetch XDPRIME of DERIVS)
-                                         (fetch XTPRIME of DERIVS)))
-          (replace B3Y of BEZ with (PLUS (fetch B0Y of BEZ)
-                                         (fetch YPRIME of DERIVS)
-                                         (fetch YDPRIME of DERIVS)
-                                         (fetch YTPRIME of DERIVS)))
-          (RETURN BEZ])
-
-(SF.PRINT
-  [LAMBDA (STRING FONTFAMILY SCALE STREAM)                   (* ; "Edited 16-Jan-87 16:22 by gbn")
-    (DECLARE%: (GLOBALVARS \SPLINEFONTSINCORE))
-
-(* ;;; "Uses SFDRAW to draw a single char at a time to print out a string in the chosen font.  Defaults to GACHA")
-
-    (PROG ((FONTARRAY (ASSOC (OR FONTFAMILY 'GACHA)
-                             \SPLINEFONTSINCORE))
-           CHAR CHARDESC)
-          (if FONTARRAY
-              then (SETQ FONTARRAY (CADR FONTARRAY))
-            else (printout T "Spline font" %, FONTFAMILY %, 
-                        "not in core.  Load it with READ.SPLINE.FONT")
-                 (LISPERROR))
-          (for I to (NCHARS STRING) do (SETQ CHAR (NTHCHARCODE STRING I))
-                                       (SETQ CHARDESC (ELT FONTARRAY CHAR))
-                                       (if CHARDESC
-                                           then (SFDRAW CHARDESC NIL NIL NIL SCALE STREAM)
-                                         else                (* ; 
-                                "well, what to do?  ignore for now.  The char is not currently there")
-                                           ))
-          (FLUSHOUTPUT STREAM)
-          (RETURN STRING])
-
-(SFDRAW
-  [LAMBDA (CHARDESC PRECISION XOFFSET YOFFSET SCALE STREAM)  (* gbn "24-Oct-85 16:59")
-          
-          (* * takes a character descriptor in SF format and draws it on STREAM)
-
-    (PROG ((PRECISION (OR PRECISION \CHARSEGMENTS.IRIS))
-           (X (OR XOFFSET (DSPXPOSITION NIL STREAM)))
-           (Y (OR YOFFSET (DSPYPOSITION NIL STREAM)))
-           (SCALE (OR SCALE 1.0))
-           XWIDTH)
-          (for CCURVE in (fetch SPLINES of CHARDESC)
-             do (SFDRAW.CLOSED.CURVE CCURVE PRECISION X Y SCALE STREAM))
-          (MOVETO [IPLUS X (SETQ XWIDTH (TIMES SCALE (fetch XWIDTH of (fetch SF.WIDTH of CHARDESC]
-                 [IPLUS Y (TIMES SCALE (fetch YWIDTH of (fetch SF.WIDTH of CHARDESC]
-                 STREAM)
-          (RETURN XWIDTH])
-
-(SFDRAW.CLOSED.CURVE
-  [LAMBDA (CCURVE PRECISION XOFFSET YOFFSET SCALE STREAM)    (* gbn "21-Jun-85 03:00")
-          
-          (* * A closed curve looks like a list of splines.
-          Each spline is described by the record SF.SPLINE)
-
-    (PROG ((STREAM (if (EQ (TYPENAME STREAM)
-                           'WINDOW)
-                       then (WINDOWPROP STREAM 'DSP)
-                     else STREAM))
-           (SCALE (OR SCALE 1.0))
-           SPPOUTSTREAM)
-          [for SPLINE in CCURVE
-             do 
-          
-          (* if necessary destructively change the knot list to be a list of postions)
-
-                [if [NOT (type? POSITION (CAR (fetch KNOTLIST of SPLINE]
-                    then (for KNOT in (fetch KNOTLIST of SPLINE) do (RPLACD KNOT (CADR KNOT] 
-                                                             (* draw a single spline, driven off 
-                                                             the stream type)
-                (SELECTQ (TYPENAME (fetch IMAGEDATA of STREAM))
-                    (IRISDATA 
-          
-          (* this is for the iris colour monitor, which is interested in Bezier control 
-          points. Use the knots together with the derivative list to produce the Bezier 
-          points to send to the Iris)
-
-                              (SETQ SPPOUTSTREAM (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM)))
-                              (bind BEZIER for I to (SUB1 (fetch %#OFKNOTS of SPLINE)) as KNOT
-                                 in (fetch KNOTLIST of SPLINE) as DERIVS
-                                 in (fetch DERIVATIVELIST of SPLINE)
-                                 do (SETQ BEZIER (SF.DERIVS.TO.BEZIER KNOT XOFFSET YOFFSET SCALE 
-                                                        DERIVS)) 
-          
-          (* get the bezier control points corresponding to the parametric
-          (derivative) definition)
-
-                                    (SELECTQ \IRIS.VERSION
-                                        (GL2 (IRIS.CRV BEZIER SPPOUTSTREAM))
-                                        (R1C (IRIS.CURVE PRECISION \BEZIERBASIS.IRIS BEZIER 
-                                                    SPPOUTSTREAM))
-                                        (ERROR))))
-                    (\DISPLAYDATA 
-          
-          (* since the display is interested in the control points in the derivative form 
-          as found here, just call the internal parametric spline drawing routine for the 
-          display)
-                                                             (* (GLOBALRESOURCE \BRUSHBBT
-                                                             (PROG ((%#KNOTS (fetch %#OFKNOTS of 
-                                                             SPLINE)) (BBT \BRUSHBBT)
-                                                             (RESULT)) (SETQ RESULT
-                                                             (create SPLINE %#KNOTS _ %#KNOTS DX _
-                                                             (ARRAY %#KNOTS 0 0.0) DDX _
-                                                             (ARRAY %#KNOTS 0 0.0) DDDX _
-                                                             (ARRAY %#KNOTS 0 0.0) DY _
-                                                             (ARRAY %#KNOTS 0 0.0) DDY _
-                                                             (ARRAY %#KNOTS 0 0.0) DDDY _
-                                                             (ARRAY %#KNOTS 0 0.0) X _
-                                                             (ARRAY %#KNOTS 0 0.0) Y _
-                                                             (ARRAY %#KNOTS 0 0.0)))
-                                                             (for I to (SUB1 %#KNOTS) as KNOT in
-                                                             (fetch KNOTLIST of SPLINE) as DERIVS 
-                                                             in (fetch DERIVATIVELIST of SPLINE) do
-                                                             (SETA (fetch X of RESULT) I
-                                                             (PLUS XOFFSET (TIMES SCALE
-                                                             (fetch XCOORD of KNOT))))
-                                                             (SETA (fetch Y of RESULT) I
-                                                             (PLUS YOFFSET (TIMES SCALE
-                                                             (fetch YCOORD of KNOT))))
-                                                             (SETA (fetch (SPLINE DX) of RESULT) I
-                                                             (TIMES SCALE (fetch XPRIME of DERIVS)))
-                                                             (SETA (fetch DY of RESULT) I
-                                                             (TIMES SCALE (fetch YPRIME of DERIVS)))
-                                                             (SETA (fetch DDX of RESULT) I
-                                                             (TIMES SCALE (fetch XDPRIME of DERIVS)))
-                                                             (SETA (fetch DDY of RESULT) I
-                                                             (TIMES SCALE (fetch YDPRIME of DERIVS)))
-                                                             (SETA (fetch DDDX of RESULT) I
-                                                             (TIMES SCALE (fetch XTPRIME of DERIVS)))
-                                                             (SETA (fetch DDDY of RESULT) I
-                                                             (TIMES SCALE (fetch YTPRIME of DERIVS))) 
-                                                             finally (\CURVE2 RESULT 1 NIL BBT 
-                                                             STREAM)))))
-                                  )
-                    (PROGN 
-          
-          (* Don't know what kind of stream so just do it using the standard DSP fns.)
-          
-          (* * "JUNK TO NOT TYPE AGAIN" (SETQ %#KNOTS
-          (fetch %#OFKNOTS of SPLINE)) (replace %#KNOTS of RESULT with %#KNOTS)
-          (replace DX OF RESULT WITH (ARRAY %#KNOTS 0 0.0))
-          (replace DDX of RESULT with (ARRAY %#KNOTS 0 0.0))
-          (replace DDDX of RESULT with (ARRAY %#KNOTS 0 0.0))
-          (replace DY of RESULT with (ARRAY %#KNOTS 0 0.0))
-          (replace DDY of RESULT with (ARRAY %#KNOTS 0 0.0))
-          (replace DDDY of RESULT with (ARRAY %#KNOTS 0 0.0))
-          (replace X of RESULT with (ARRAY %#KNOTS 0 0.0))
-          (replace Y of RESULT with (ARRAY %#KNOTS 0 0.0)))
-
-                           (if SCALE
-                               then (printout T 
-                                           "SCALE specified for device which does not support it")
-                                    (LISPERROR))
-                           (DRAWCURVE (for KNOT in (fetch KNOTLIST of SPLINE)
-                                         collect (create POSITION
-                                                        XCOORD _ (PLUS (fetch XCOORD of KNOT)
-                                                                       XOFFSET)
-                                                        YCOORD _ (PLUS (fetch YCOORD of KNOT)
-                                                                       YOFFSET)))
-                                  NIL NIL NIL STREAM]
-          (RETURN])
-
-(TEST
-  [LAMBDA (STRING COLOR SCALE)                               (* gbn " 1-Aug-84 02:45")
-          
-          (* * comment)
-
-    (PROG NIL
-          (IRIS.COLOR IRIS.BLACK)
-          (IRIS.CLEAR)
-          (IRIS.COLOR (OR COLOR IRIS.BLUE))
-          (SF.PRINT (OR STRING "Greg")
-                 NIL SCALE STR)
-          (IRIS.GFLUSH)
-          (RETURN])
-
-(VIEW.FONT.FILES
-  [LAMBDA (FILES)                                            (* edited%: " 9-Aug-84 05:35")
-          
-          (* * comment)
-
-    (PROG (FONTARRAY FAMILY I CHAR)
-          (RETURN (for F in (OR (LISTP FILES)
-                                (LIST FILES))
-                     collect (SETQ I (OPENSTREAM F 'INPUT))
-                           (SETQ CHAR (READ I))
-                           (CONS FAMILY (bind C repeatwhile (NEQ 'STOP (SETQ CHAR (READ I)))
-                                           collect [SETQ C (CHARACTER (fetch CHARCODE
-                                                                         of (fetch CHARACTER
-                                                                               of CHAR]
-                                                 (printout T C %,)
-                                                 C finally (CLOSEF I])
-
-(\LOOKUPSPLINEFONT
-  [LAMBDA (FAMILY CHARSET)                                   (* gbn "22-Oct-85 12:09")
-          
-          (* * if there is a font array in core for this charset of this font family, 
-          this returns it, else nil)
-
-    (LET ((ENTRY (SASSOC (LIST FAMILY CHARSET)
-                        \SPLINEFONTSINCORE)))
-         (AND ENTRY (CDR ENTRY])
-
-(\SETSPLINEFONT
-  [LAMBDA (FAMILY CHARSET ARRAY)                             (* gbn "22-Oct-85 11:42")
-          
-          (* * installs a font array in \splinefontsincore for this family and charset)
-
-    (PUTASSOC (LIST FAMILY CHARSET)
-           ARRAY \SPLINEFONTSINCORE])
-
-(ginit
-  [LAMBDA NIL                                                (* edited%: " 6-Aug-84 12:00")
-    (if (MOUSECONFIRM 
-               "do you really want to ginit. You destroy font definitions which must be reloaded?" 
-               NIL (if (HASTTYWINDOWP)
-                       then T
-                     else PROMPTWINDOW))
-        then (IRIS.GINIT)
-             (IRIS.CURSOFF)
-             (IRIS.CLEAR)
-             (makecolormap)
-             (IRIS.SETCURSOR 0 1 255)
-             (IRIS.COLOR IRIS.RED])
-)
-(DECLARE%: EVAL@LOAD DONTCOPY 
-
-(FILESLOAD (LOADCOMP)
-       IRISSTREAM)
-
-
-(RPAQQ TIMESROMANDFILES (TIMESROMAND.LC1-SF;1 TIMESROMAND.LC2-SF;1 TIMESROMAND.NUM-SF;1 
-                                   TIMESROMAND.S1-SF;1 TIMESROMAND.S3-SF;1 TIMESROMAND.UC1-SF;1 
-                                   TIMESROMAND.UC2-SF;1))
-
-(RPAQQ TRA
-       [(FAMILY TIMESROMAND)
-        (CHARACTER 97)
-        (FACE M R R)
-        (WIDTH 237 0)
-        (FIDUCIAL 385 385)
-        (VERSION 0 29-SEP-77 |16:35:46|)
-        (MADE-FROM NIL 121 130 62 40)
-        (SPLINES ((2 ((200 . 153)
-                      (200 . 45))
-                     NIL
-                     ((0 -108.0 0 0 0 0))
-                     NATURAL)
-                  (4 ((200 . 45)
-                      (202 . 28)
-                      (214 . 23)
-                      (223 . 27))
-                     NIL
-                     ((-0.866666 -19.6 0 0 17.2 15.6)
-                      (7.733334 -11.8 17.2 15.6 -26.0 -6.000002)
-                      (11.93333 0.8000005 -8.8 9.599998 8.8 -9.599998))
-                     NATURAL)
-                  (2 ((223 . 27)
-                      (227 . 20))
-                     NIL
-                     ((4.0 -7.0 0 0 0 0))
-                     NATURAL)
-                  (7 ((227 . 20)
-                      (216 . 9)
-                      (197 . -1)
-                      (170 . -6)
-                      (144 . -2)
-                      (126 . 7)
-                      (117 . 23))
-                     NIL
-                     ((-9.420512 -11.06538 0 0 -9.476924 0.3923078)
-                      (-14.15898 -10.86923 -9.476924 0.3923078 -0.6153832 4.038461)
-                      (-23.94359 -8.457692 -10.09231 4.430769 11.93846 7.453844)
-                      (-28.06666 -0.2999992 1.846154 11.88461 6.861538 -9.853844)
-                      (-22.78974 6.657692 8.707692 2.030769 2.615385 7.961536)
-                      (-12.77436 12.66923 11.32308 9.992306 -11.32308 -9.992306))
-                     NATURAL)
-                  (10 ((117 . 23)
-                       (89 . 4)
-                       (62 . -3)
-                       (37 . 3)
-                       (18 . 25)
-                       (18 . 52)
-                       (32 . 77)
-                       (60 . 98)
-                       (92 . 113)
-                       (118 . 125))
-                      NIL
-                      ((-28.15654 -21.56226 0 0 0.9392528 15.37358)
-                       (-27.68691 -13.87547 0.9392528 15.37358 1.303736 -4.867924)
-                       (-26.0958 -0.9358488 2.242989 10.50566 -0.1541991 10.09811)
-                       (-23.9299 14.61887 2.08879 20.60377 23.31306 -17.52453)
-                       (-10.18458 26.46038 25.40185 3.079245 -15.09804 -6.0)
-                       (7.668246 26.53962 10.30381 -2.920755 7.079094 -0.4754715)
-                       (21.51161 23.38113 17.3829 -3.396226 -13.21835 -4.098113)
-                       (32.28533 17.93585 4.164558 -7.494339 -14.20569 4.867924)
-                       (29.34705 12.87547 -10.04114 -2.626415 10.04114 2.626415))
-                      NATURAL)
-                  (2 ((118 . 125)
-                      (118 . 166))
-                     NIL
-                     ((0 41.0 0 0 0 0))
-                     NATURAL)
-                  (17 ((118 . 166)
-                       (110 . 187)
-                       (91 . 189)
-                       (88 . 171)
-                       (98 . 152)
-                       (85 . 130)
-                       (59 . 124)
-                       (32 . 132)
-                       (21 . 154)
-                       (31 . 182)
-                       (55 . 198)
-                       (86 . 205)
-                       (118 . 208)
-                       (148 . 205)
-                       (175 . 196)
-                       (195 . 177)
-                       (200 . 153))
-                      NIL
-                      ((-4.255993 24.64079 0 0 -22.46404 -21.84477)
-                       (-15.48801 13.71841 -22.46404 -21.84477 46.32022 -4.776135)
-                       (-14.79195 -10.51443 23.85617 -26.62091 -0.8168106 34.94932)
-                       (8.655816 -19.66068 23.03936 8.328413 -61.05298 -21.02116)
-                       (1.168687 -21.84285 -38.01361 -12.69275 29.0287 37.13531)
-                       (-22.33057 -15.96793 -8.984904 24.44257 4.938131 -13.52012)
-                       (-28.8464 1.714581 -4.046773 10.92245 23.21877 4.945154)
-                       (-21.2838 15.10961 19.172 15.86761 4.186775 -6.260496)
-                       (-0.01840973 27.84697 23.35877 9.607112 -9.965858 -27.90316)
-                       (18.35743 23.5025 13.39291 -18.29605 -6.323341 9.873148)
-                       (28.58868 10.14302 7.069574 -8.422904 -6.740779 6.410579)
-                       (32.28786 4.925408 0.3287937 -2.012324 -2.713542 -5.515475)
-                       (31.25988 0.1553465 -2.384749 -7.527798 -0.4050512 3.651317)
-                       (28.67261 -5.546795 -2.7898 -3.876482 -1.666252 -9.089788)
-                       (25.04968 -13.96817 -4.456052 -12.96627 -16.92993 8.707838)
-                       (12.12866 -22.58052 -21.38599 -4.258433 21.38599 4.258433))
-                      NATURAL))
-               ((2 ((118 . 108)
-                    (118 . 58))
-                   NIL
-                   ((0 -50.0 0 0 0 0))
-                   NATURAL)
-                (9 ((118 . 58)
-                    (118 . 49)
-                    (111 . 38)
-                    (97 . 39)
-                    (90 . 49)
-                    (88 . 66)
-                    (93 . 83)
-                    (104 . 99)
-                    (118 . 108))
-                   NIL
-                   ((1.256443 -7.739323 0 0 -7.53866 -7.564064)
-                    (-2.512887 -11.52136 -7.53866 -7.564064 -4.3067 25.82032)
-                    (-12.2049 -6.175257 -11.84536 18.25626 24.76546 -11.71723)
-                    (-11.66752 6.222386 12.9201 6.539029 -10.75515 3.048599)
-                    (-4.124999 14.28571 2.164949 9.587628 6.255152 -12.47717)
-                    (1.167526 17.63475 8.420102 -2.889543 -2.265462 4.860088)
-                    (8.454898 17.17526 6.154639 1.970545 -3.193299 -12.96318)
-                    (13.01289 12.66421 2.96134 -10.99263 -2.96134 10.99263))
-                   NATURAL])
-
-(RPAQQ TRB
-       [(FAMILY TIMESROMAND)
-        (CHARACTER 99)
-        (FACE M R R)
-        (WIDTH 211 0)
-        (FIDUCIAL 385 385)
-        (VERSION 0 29-SEP-77 |16:50:06|)
-        (MADE-FROM NIL 118 130 57 78)
-        (SPLINES ((2 ((181 . 46)
-                      (189 . 37))
-                     NIL
-                     ((8.0 -9.0 0 0 0 0))
-                     NATURAL)
-                  (32 ((189 . 37)
-                       (166 . 14)
-                       (135 . -1)
-                       (92 . -4)
-                       (59 . 7)
-                       (33 . 30)
-                       (16 . 66)
-                       (12 . 101)
-                       (17 . 136)
-                       (30 . 166)
-                       (51 . 189)
-                       (86 . 204)
-                       (125 . 206)
-                       (154 . 202)
-                       (180 . 189)
-                       (196 . 168)
-                       (196 . 143)
-                       (178 . 127)
-                       (155 . 124)
-                       (138 . 134)
-                       (130 . 155)
-                       (130 . 176)
-                       (124 . 189)
-                       (111 . 184)
-                       (96 . 160)
-                       (91 . 129)
-                       (93 . 95)
-                       (102 . 63)
-                       (117 . 42)
-                       (144 . 33)
-                       (167 . 39)
-                       (181 . 46))
-                      NIL
-                      ((-21.8826 -24.50792 0 0 -6.704422 9.047542)
-                       (-25.23481 -19.98415 -6.704422 9.047542 -14.47789 2.762293)
-                       (-39.17817 -9.555464 -21.18231 11.80983 40.61599 3.903284)
-                       (-40.05249 4.206011 19.43367 15.71312 -15.98606 -6.375422)
-                       (-28.61185 16.73142 3.447612 9.337696 5.328262 9.5984)
-                       (-22.50011 30.86831 8.775874 18.9361 6.673012 -26.01818)
-                       (-10.38772 36.79532 15.44889 -7.082087 -8.020304 10.47433)
-                       (1.051008 34.95039 7.428581 3.392247 1.408212 -9.879148)
-                       (9.183696 33.40307 8.836792 -6.486902 -3.612545 -0.9577408)
-                       (16.21421 26.4373 5.224247 -7.444641 13.04197 1.710107)
-                       (27.95945 19.84771 18.26621 -5.734535 -12.55532 -11.88268)
-                       (39.948 8.171835 5.710896 -17.61722 -22.82069 15.82064)
-                       (34.24855 -1.535063 -17.1098 -1.796579 19.83808 -9.399882)
-                       (27.05779 -8.031584 2.728286 -11.19646 -14.53163 3.778893)
-                       (22.52026 -17.3386 -11.80335 -7.417568 -3.711554 0.2843065)
-                       (8.861142 -24.61401 -15.5149 -7.133261 -6.622156 19.08388)
-                       (-9.964836 -22.20533 -22.13706 11.95062 18.20018 1.380173)
-                       (-23.0018 -9.564632 -3.936874 13.33079 11.82142 -0.6045686)
-                       (-21.02796 3.463873 7.884551 12.72622 0.5141201 1.038099)
-                       (-12.88635 16.70915 8.39867 13.76432 4.122093 -15.54783)
-                       (-2.426633 22.69955 12.52076 -1.783509 -23.00249 -4.846774)
-                       (-1.407115 18.49265 -10.48173 -6.630284 3.887866 -13.06508)
-                       (-9.944906 5.329831 -6.59386 -19.69536 1.451023 -2.892914)
-                       (-15.81326 -15.81199 -5.142837 -22.58827 20.30804 18.63673)
-                       (-10.80207 -29.08189 15.16521 -3.951541 -10.6832 0.3459764)
-                       (-0.978461 -32.86044 4.482012 -3.605564 4.424731 3.979362)
-                       (5.715916 -34.47633 8.906742 0.373798 -7.015726 13.73657)
-                       (11.1148 -27.23424 1.891017 14.11037 17.63817 -4.92565)
-                       (21.8249 -15.5867 19.52919 9.184722 -27.53697 11.96602)
-                       (27.5856 -0.4189663 -8.007784 21.15074 -3.490269 -24.93843)
-                       (17.83268 8.262562 -11.49805 -3.787686 11.49805 3.787686))
-                      NATURAL])
-
-(RPAQQ TRC
-       [(FAMILY TIMESROMAND)
-        (CHARACTER 100)
-        (FACE M R R)
-        (WIDTH 250 0)
-        (FIDUCIAL 385 385)
-        (VERSION 0 29-SEP-77 |16:56:16|)
-        (MADE-FROM NIL 103 130 57 78)
-        (SPLINES ((2 ((136 . 269)
-                      (136 . 189))
-                     NIL
-                     ((0 -80.0 0 0 0 0))
-                     NATURAL)
-                  (15 ((136 . 189)
-                       (114 . 204)
-                       (86 . 211)
-                       (57 . 203)
-                       (40 . 190)
-                       (25 . 168)
-                       (16 . 140)
-                       (12 . 110)
-                       (13 . 82)
-                       (20 . 51)
-                       (32 . 28)
-                       (52 . 8)
-                       (82 . -2)
-                       (111 . 7)
-                       (136 . 25))
-                      NIL
-                      ((-20.69145 16.12365 0 0 -7.851328 -6.741922)
-                       (-24.61711 12.75269 -7.851328 -6.741922 3.256639 -14.29039)
-                       (-30.84012 -1.134427 -4.594689 -21.03232 24.82477 21.9035)
-                       (-23.02242 -11.21499 20.23008 0.8711902 -24.55573 -13.32363)
-                       (-15.0702 -17.00562 -4.325648 -12.45244 13.39815 7.391023)
-                       (-12.69677 -25.76255 9.072504 -5.061419 -5.036883 1.759538)
-                       (-6.142708 -29.9442 4.035622 -3.30188 0.749383 9.57082)
-                       (-1.732394 -28.46066 4.785005 6.268941 2.039351 -16.04282)
-                       (4.072286 -30.21314 6.824355 -9.773884 -2.906779 24.60048)
-                       (9.443252 -27.68678 3.917576 14.82659 3.587763 -16.35907)
-                       (15.15471 -21.03973 7.505339 -1.532484 6.555731 10.83583)
-                       (25.93791 -17.1543 14.06107 9.303344 -17.81069 15.01576)
-                       (31.09364 -0.3430727 -3.749619 24.31911 -1.312975 -16.89888)
-                       (26.68753 15.52659 -5.062595 7.420223 5.062595 -7.420223))
-                      NATURAL)
-                  (2 ((136 . 25)
-                      (136 . -3))
-                     NIL
-                     ((0 -28.0 0 0 0 0))
-                     NATURAL)
-                  (2 ((136 . -3)
-                      (241 . 10))
-                     NIL
-                     ((105.0 13.0 0 0 0 0))
-                     NATURAL)
-                  (2 ((241 . 10)
-                      (241 . 15))
-                     NIL
-                     ((0 5.0 0 0 0 0))
-                     NATURAL)
-                  (5 ((241 . 15)
-                      (231 . 19)
-                      (222 . 26)
-                      (217 . 37)
-                      (217 . 50))
-                     NIL
-                     ((-10.07143 3.446428 0 0 0.4285715 3.321429)
-                      (-9.857142 5.107143 0.4285715 3.321429 3.857143 1.392856)
-                      (-7.5 9.125 4.285714 4.714285 2.142858 -2.892857)
-                      (-2.142857 12.39286 6.428572 1.821428 -6.428572 -1.821428))
-                     NATURAL)
-                  (2 ((217 . 50)
-                      (217 . 300))
-                     NIL
-                     ((0 250.0 0 0 0 0))
-                     NATURAL)
-                  (2 ((217 . 300)
-                      (117 . 300))
-                     NIL
-                     ((-100.0 0 0 0 0 0))
-                     NATURAL)
-                  (2 ((117 . 300)
-                      (117 . 295))
-                     NIL
-                     ((0 -5.0 0 0 0 0))
-                     NATURAL)
-                  (4 ((117 . 295)
-                      (128 . 291)
-                      (134 . 283)
-                      (136 . 269))
-                     NIL
-                     ((12.06667 -3.333333 0 0 -6.4 -4.0)
-                      (8.866666 -5.333333 -6.4 -4.0 2.0 -4.0)
-                      (3.466666 -11.33333 -4.4 -8.0 4.4 8.0))
-                     NATURAL))
-               ((2 ((136 . 159)
-                    (136 . 79))
-                   NIL
-                   ((0 -80.0 0 0 0 0))
-                   NATURAL)
-                (12 ((136 . 79)
-                     (133 . 52)
-                     (122 . 34)
-                     (108 . 40)
-                     (100 . 62)
-                     (96 . 88)
-                     (95 . 116)
-                     (97 . 143)
-                     (104 . 168)
-                     (117 . 179)
-                     (130 . 174)
-                     (136 . 159))
-                    NIL
-                    ((-1.169987 -27.97882 0 0 -10.98008 5.872907)
-                     (-6.660026 -25.04236 -10.98008 5.872907 6.900384 24.63546)
-                     (-14.18991 -6.851724 -4.079692 30.50837 13.37854 -14.41478)
-                     (-11.58033 16.44926 9.298848 16.0936 -6.414546 -14.97637)
-                     (-5.488757 25.05467 2.884301 1.117225 0.279644 2.320276)
-                     (-2.464635 27.33204 3.163945 3.437501 -0.7040282 -6.304729)
-                     (0.3472968 27.61717 2.459917 -2.867228 2.536468 4.898638)
-                     (4.075448 27.19927 4.996385 2.03141 2.558155 -19.28982)
-                     (10.35091 19.58576 7.55454 -17.25841 -6.769083 0.2606583)
-                     (14.52091 2.457678 0.785456 -16.99775 -11.48182 6.247193)
-                     (9.565454 -11.41648 -10.69636 -10.75056 10.69636 10.75056))
-                    NATURAL])
-
-(RPAQQ TRFILES ({INDIGO}<PRESSFONTS>OLDSF>TIMESROMAND.LC1-SF;1 
-                          {INDIGO}<PRESSFONTS>OLDSF>TIMESROMAND.LC2-SF;1 
-                          {INDIGO}<PRESSFONTS>OLDSF>TIMESROMAND.NUM-SF;1 
-                          {INDIGO}<PRESSFONTS>OLDSF>TIMESROMAND.S1-SF;1 
-                          {INDIGO}<PRESSFONTS>OLDSF>TIMESROMAND.S3-SF;1 
-                          {INDIGO}<PRESSFONTS>OLDSF>TIMESROMAND.UC1-SF;1 
-                          {INDIGO}<PRESSFONTS>OLDSF>TIMESROMAND.UC2-SF;1))
-)
-
-(RPAQ? \SPLINEFONTSINCORE (LIST NIL))
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS \SPLINEFONTSINCORE)
-)
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ \CHARSEGMENTS.IRIS 10)
-
-
-(CONSTANTS (\CHARSEGMENTS.IRIS 10))
-)
-(PUTPROPS SFFONT COPYRIGHT ("Venue" 1991))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (1784 19991 (READ.SPLINE.FONT 1794 . 4813) (SF.DERIVS.TO.BEZIER 4815 . 7456) (SF.PRINT 
-7458 . 8733) (SFDRAW 8735 . 9574) (SFDRAW.CLOSED.CURVE 9576 . 17439) (TEST 17441 . 17819) (
-VIEW.FONT.FILES 17821 . 18759) (\LOOKUPSPLINEFONT 18761 . 19148) (\SETSPLINEFONT 19150 . 19442) (ginit
- 19444 . 19989)))))
-STOP
diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.LC1-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.LC1-SF
deleted file mode 100644
index 3746dd3c..00000000
--- a/obsolete/lispusers/splinefonts/TIMESROMAN.LC1-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY TIMESROMAND)
 (CHARACTER 141Q)
 (FACE M R R)
 (WIDTH 237 0)
 (FIDUCIAL 385 385)
 (VERSION 0 29-SEP-77 16:35:46)
 (MADE-FROM NIL 121 130 62 40)
 (SPLINES

  ((2
    ((200 153) (200 45))
    NIL
    ((0 -108. 0 0 0 0 ))
    NATURAL)
   (4
    ((200 45) (202 28) (214 23) (223 27))
    NIL
    ((-0.866666079 -19.599998 0 0 17.1999969 15.6 )
     (7.73333359 -11.799999 17.1999969 15.6 -25.999996 -6.0000019 )
     (11.933332 0.800000430 -8.79999925 9.59999848 8.79999925 -9.59999848 ))
    NATURAL)
   (2
    ((223 27) (227 20))
    NIL
    ((4. -7. 0 0 0 0 ))
    NATURAL)
   (7
    ((227 20) (216 9) (197 -1) (170 -6) (144 -2) (126 7)
     (117 23))
    NIL
    ((-9.42051126 -11.0653839 0 0 -9.476923 0.392307758 )
     (-14.1589737 -10.86923 -9.476923 0.392307758 -0.615383148 4.03846073 )
     (-23.943588 -8.4576912 -10.092306 4.43076897 11.938459 7.45384408 )
     (-28.066665 -0.299999237 1.84615373 11.884613 6.86153699 -9.8538437 )
     (-22.789741 6.65769196 8.7076912 2.03076935 2.61538505 7.9615364 )
     (-12.7743587 12.669231 11.323076 9.99230577 -11.323076 -9.99230577 ))
    NATURAL)
   (10
    ((117 23) (89 4) (62 -3) (37 3) (18 25) (18 52)
     (32 77) (60 98) (92 113) (118 125))
    NIL
    ((-28.156539 -21.562263 0 0 0.939252735 15.373584 )
     (-27.686912 -13.875471 0.939252735 15.373584 1.30373621 -4.86792374 )
     (-26.095794 -0.935848833 2.24298906 10.505661 -0.154199123 10.09811 )
     (-23.9299 14.6188678 2.08878994 20.603771 23.313056 -17.524524 )
     (-10.1845836 26.460376 25.401847 3.07924461 -15.098037 -5.99999905 )
     (7.6682453 26.539619 10.30381 -2.92075443 7.07909394 -0.475471497 )
     (21.511604 23.38113 17.382904 -3.39622593 -13.218345 -4.09811306 )
     (32.285331 17.935848 4.16455746 -7.494339 -14.205694 4.86792374 )
     (29.347045 12.875471 -10.0411377 -2.62641525 10.0411377 2.62641525 ))
    NATURAL)
   (2
    ((118 125) (118 166))
    NIL
    ((0 41. 0 0 0 0 ))
    NATURAL)
   (17
    ((118 166) (110 187) (91 189) (88 171) (98 152) (85 130)
     (59 124) (32 132) (21 154) (31 182) (55 198) (86 205)
     (118 208) (148 205) (175 196) (195 177) (200 153))
    NIL
    ((-4.25599289 24.640792 0 0 -22.464042 -21.844772 )
     (-15.488014 13.718408 -22.464042 -21.844772 46.320213 -4.77613449 )
     (-14.79195 -10.5144329 23.85617 -26.620906 -0.816810609 34.949317 )
     (8.6558151 -19.660678 23.03936 8.328413 -61.05297 -21.02116 )
     (1.16868734 -21.842845 -38.01361 -12.692747 29.028705 37.135314 )
     (-22.330566 -15.967931 -8.98490335 24.442573 4.93813038 -13.52012 )
     (-28.846405 1.71458101 -4.04677296 10.9224529 23.218769 4.94515419 )
     (-21.283794 15.109611 19.171997 15.867607 4.1867752 -6.26049615 )
     (-0.0184097290 27.846969 23.358772 9.60711099 -9.96585847 -27.90316 )
     (18.357429 23.502498 13.3929138 -18.296051 -6.3233404 9.87314797 )
     (28.588676 10.1430206 7.0695734 -8.42290307 -6.74077893 6.41057873 )
     (32.287857 4.9254074 0.328793704 -2.01232386 -2.71354198 -5.5154743 )
     (31.25988 0.155346542 -2.38474846 -7.52779866 -0.405051231 3.65131664 )
     (28.672607 -5.54679394 -2.78979969 -3.876482 -1.66625213 -9.08978845 )
     (25.049678 -13.96817 -4.45605183 -12.96627 -16.929931 8.70783807 )
     (12.128662 -22.58052 -21.385986 -4.25843239 21.385986 4.25843239 ))
    NATURAL))

  ((2
    ((118 108) (118 58))
    NIL
    ((0 -50. 0 0 0 0 ))
    NATURAL)
   (9
    ((118 58) (118 49) (111 38) (97 39) (90 49) (88 66)
     (93 83) (104 99) (118 108))
    NIL
    ((1.25644326 -7.73932267 0 0 -7.53866006 -7.564064 )
     (-2.51288652 -11.5213546 -7.53866006 -7.564064 -4.30669976 25.82032 )
     (-12.2048969 -6.17525674 -11.8453598 18.256256 24.76546 -11.7172279 )
     (-11.667524 6.2223854 12.920101 6.53902817 -10.7551517 3.04859924 )
     (-4.12499905 14.285713 2.16494894 9.5876274 6.25515175 -12.477169 )
     (1.16752624 17.634754 8.42010118 -2.88954306 -2.26546192 4.8600874 )
     (8.4548969 17.175254 6.15463925 1.97054457 -3.19329929 -12.9631767 )
     (13.012886 12.664211 2.96133995 -10.9926338 -2.96133995 10.9926338 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 142Q)
 (FACE M R R)
 (WIDTH 252 0)
 (FIDUCIAL 385 385)
 (VERSION 0 29-SEP-77 16:44:21)
 (MADE-FROM NIL 88 130 57 78)
 (SPLINES

  ((2
    ((112 300) (112 183))
    NIL
    ((0 -117. 0 0 0 0 ))
    NATURAL)
   (15
    ((112 183) (138 201) (165 207) (195 200) (219 179) (232 150)
     (238 103) (232 67) (216 33) (186 8) (156 -2) (126 -3)
     (101 2) (84 11) (67 26))
    NIL
    ((26.012008 20.539005 0 0 -0.0720686913 -15.234035 )
     (25.975975 12.921987 -0.0720686913 -15.234035 6.36034299 4.17017746 )
     (29.084079 -0.226958573 6.28827477 -11.063858 -13.3693046 -7.44667435 )
     (28.687698 -15.014154 -7.08103085 -18.510532 -6.8831148 19.616527 )
     (18.165111 -23.716423 -13.964145 1.10599708 10.901762 -35.019447 )
     (9.6518459 -40.120147 -3.06238365 -33.913452 -12.723934 60.46128 )
     (0.227496445 -43.802963 -15.7863178 26.547828 9.9939747 -32.82569 )
     (-10.561834 -33.667976 -5.79234314 -6.2778654 -15.2519607 16.841495 )
     (-23.980155 -31.525096 -21.044303 10.563631 27.013866 7.45970345 )
     (-31.517528 -17.231613 5.96956349 18.023334 -8.80351258 -10.680305 )
     (-29.949722 -4.5484333 -2.83395004 7.343029 8.20018579 -0.738483429 )
     (-28.683578 2.42535353 5.36623669 6.6045456 6.0027647 -4.36575794 )
     (-20.315956 6.84702016 11.369001 2.23878765 -14.211252 6.20151425 )
     (-16.0525818 12.186565 -2.84225082 8.4403019 2.84225082 -8.4403019 ))
    NATURAL)
   (2
    ((67 26) (36 -3))
    NIL
    ((-31. -29. 0 0 0 0 ))
    NATURAL)
   (2
    ((36 -3) (31 -3))
    NIL
    ((-5. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((31 -3) (31 269))
    NIL
    ((0 272. 0 0 0 0 ))
    NATURAL)
   (4
    ((31 269) (29 283) (23 291) (12 295))
    NIL
    ((-1.26666665 15.333332 0 0 -4.39999962 -8. )
     (-3.4666667 11.333332 -4.39999962 -8. -2. 4. )
     (-8.8666668 5.333333 -6.3999996 -4. 6.3999996 4. ))
    NATURAL)
   (2
    ((12 295) (12 300))
    NIL
    ((0 5. 0 0 0 0 ))
    NATURAL)
   (2
    ((12 300) (112 300))
    NIL
    ((100. 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((112 44) (112 151))
    NIL
    ((0 107. 0 0 0 0 ))
    NATURAL)
   (13
    ((112 151) (119 172) (133 174) (144 161) (150 140) (152 115)
     (152 86) (150 56) (144 30) (134 16) (123 13) (114 24)
     (112 44))
    NIL
    ((4.9868555 25.152385 0 0 12.078863 -24.914325 )
     (11.026287 12.6952228 12.078863 -24.914325 -18.394321 10.57164 )
     (13.907989 -6.9332838 -6.3154583 -14.3426857 1.4984293 6.62775994 )
     (8.34174539 -17.962089 -4.817029 -7.71492577 0.400608063 4.91731739 )
     (3.72502089 -23.218357 -4.41642094 -2.79760837 2.89913463 -2.29703045 )
     (0.758167506 -27.164478 -1.51728606 -5.09463883 0.00285267830 4.2708044 )
     (-0.757692457 -30.123714 -1.51443338 -0.823834062 -2.91054487 3.21380949 )
     (-3.7273984 -29.340644 -4.42497826 2.38997555 -0.360672951 12.8739547 )
     (-8.33271218 -20.51369 -4.7856512 15.263931 4.3532362 -6.70962716 )
     (-10.9417457 -8.6045761 -0.432414532 8.5543041 0.947724820 7.9645443 )
     (-10.900297 3.93200302 0.515310288 16.518848 9.85586167 -7.14856339 )
     (-5.457057 16.876571 10.3711719 9.37028504 -10.3711719 -9.37028504 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 143Q)
 (FACE M R R)
 (WIDTH 211 0)
 (FIDUCIAL 385 385)
 (VERSION 0 29-SEP-77 16:50:06)
 (MADE-FROM NIL 118 130 57 78)
 (SPLINES

  ((2
    ((181 46) (189 37))
    NIL
    ((8. -9. 0 0 0 0 ))
    NATURAL)
   (32
    ((189 37) (166 14) (135 -1) (92 -4) (59 7) (33 30)
     (16 66) (12 101) (17 136) (30 166) (51 189) (86 204)
     (125 206) (154 202) (180 189) (196 168) (196 143) (178 127)
     (155 124) (138 134) (130 155) (130 176) (124 189) (111 184)
     (96 160) (91 129) (93 95) (102 63) (117 42) (144 33)
     (167 39) (181 46))
    NIL
    ((-21.882595 -24.507923 0 0 -6.704422 9.04754067 )
     (-25.234806 -19.984149 -6.704422 9.04754067 -14.47789 2.76229286 )
     (-39.178169 -9.5554638 -21.182312 11.809833 40.615982 3.90328407 )
     (-40.05249 4.20601082 19.433673 15.713117 -15.986061 -6.37542153 )
     (-28.611846 16.731418 3.4476118 9.33769609 5.32826138 9.5984001 )
     (-22.500103 30.868312 8.77587319 18.936096 6.67301179 -26.01818 )
     (-10.3877239 36.795318 15.4488849 -7.0820856 -8.02030374 10.4743309 )
     (1.05100774 34.950393 7.42858029 3.39224672 1.40821170 -9.87914659 )
     (9.18369485 33.403068 8.836792 -6.48690034 -3.61254501 -0.957740784 )
     (16.214214 26.437301 5.22424698 -7.4446411 13.041965 1.71010685 )
     (27.959445 19.847713 18.266212 -5.73453427 -12.5553169 -11.8826828 )
     (39.947998 8.17183496 5.71089459 -17.617218 -22.820686 15.820638 )
     (34.24855 -1.53506326 -17.109794 -1.79657936 19.838077 -9.39988137 )
     (27.057792 -8.0315838 2.72828531 -11.1964607 -14.531629 3.77889252 )
     (22.520263 -17.3386 -11.8033447 -7.4175682 -3.71155357 0.284306526 )
     (8.8611412 -24.614013 -15.514898 -7.13326169 -6.62215615 19.083877 )
     (-9.9648361 -22.205333 -22.137054 11.9506168 18.20018 1.38017273 )
     (-23.0018 -9.5646324 -3.93687344 13.330789 11.821422 -0.604568482 )
     (-21.027961 3.4638729 7.8845501 12.726221 0.514120102 1.03809929 )
     (-12.8863506 16.709144 8.3986702 13.76432 4.1220932 -15.547828 )
     (-2.42663336 22.699546 12.520763 -1.78350925 -23.002487 -4.8467741 )
     (-1.40711474 18.492652 -10.4817257 -6.63028336 3.88786602 -13.0650749 )
     (-9.9449062 5.32983113 -6.59385968 -19.695358 1.4510231 -2.89291382 )
     (-15.813255 -15.811985 -5.14283657 -22.588272 20.30804 18.63673 )
     (-10.8020706 -29.08189 15.1652069 -3.95154047 -10.683195 0.345976353 )
     (-0.978460909 -32.860443 4.4820118 -3.60556412 4.4247303 3.979362 )
     (5.71591568 -34.476326 8.9067421 0.373797953 -7.01572514 13.736572 )
     (11.1147956 -27.234241 1.89101648 14.11037 17.638172 -4.92564965 )
     (21.824897 -15.586696 19.52919 9.184721 -27.536972 11.96602 )
     (27.585601 -0.418966293 -8.0077839 21.150741 -3.4902687 -24.938427 )
     (17.832683 8.2625618 -11.4980526 -3.78768539 11.4980526 3.78768539 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 144Q)
 (FACE M R R)
 (WIDTH 250 0)
 (FIDUCIAL 385 385)
 (VERSION 0 29-SEP-77 16:56:16)
 (MADE-FROM NIL 103 130 57 78)
 (SPLINES

  ((2
    ((136 269) (136 189))
    NIL
    ((0 -80. 0 0 0 0 ))
    NATURAL)
   (15
    ((136 189) (114 204) (86 211) (57 203) (40 190) (25 168)
     (16 140) (12 110) (13 82) (20 51) (32 28) (52 8)
     (82 -2) (111 7) (136 25))
    NIL
    ((-20.691444 16.123653 0 0 -7.8513279 -6.74192143 )
     (-24.617107 12.752691 -7.8513279 -6.74192143 3.25663948 -14.2903919 )
     (-30.840114 -1.13442683 -4.59468842 -21.032314 24.824771 21.903503 )
     (-23.022419 -11.2149887 20.230083 0.871190191 -24.555728 -13.323631 )
     (-15.0701999 -17.005615 -4.32564736 -12.452442 13.398151 7.39102364 )
     (-12.6967716 -25.762546 9.07250405 -5.06141854 -5.0368824 1.75953817 )
     (-6.14270783 -29.944194 4.03562165 -3.30188036 0.749382973 9.57081986 )
     (-1.73239398 -28.460662 4.7850046 6.26894093 2.03935051 -16.0428238 )
     (4.07228565 -30.213134 6.82435513 -9.7738838 -2.90677929 24.600475 )
     (9.44325067 -27.686782 3.91757584 14.826591 3.58776283 -16.359073 )
     (15.1547088 -21.039726 7.50533867 -1.53248405 6.5557308 10.8358268 )
     (25.937912 -17.1542969 14.061069 9.3033428 -17.810688 15.015764 )
     (31.093635 -0.343072712 -3.749619 24.319107 -1.31297540 -16.8988838 )
     (26.68753 15.526592 -5.0625944 7.42022229 5.0625944 -7.42022229 ))
    NATURAL)
   (2
    ((136 25) (136 -3))
    NIL
    ((0 -28. 0 0 0 0 ))
    NATURAL)
   (2
    ((136 -3) (241 10))
    NIL
    ((105. 13. 0 0 0 0 ))
    NATURAL)
   (2
    ((241 10) (241 15))
    NIL
    ((0 5. 0 0 0 0 ))
    NATURAL)
   (5
    ((241 15) (231 19) (222 26) (217 37) (217 50))
    NIL
    ((-10.071428 3.4464283 0 0 0.428571463 3.32142878 )
     (-9.8571415 5.10714245 0.428571463 3.32142878 3.85714245 1.39285612 )
     (-7.5 9.125 4.28571415 4.7142849 2.14285755 -2.8928566 )
     (-2.14285707 12.392856 6.4285717 1.8214283 -6.4285717 -1.8214283 ))
    NATURAL)
   (2
    ((217 50) (217 300))
    NIL
    ((0 250. 0 0 0 0 ))
    NATURAL)
   (2
    ((217 300) (117 300))
    NIL
    ((-100. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((117 300) (117 295))
    NIL
    ((0 -5. 0 0 0 0 ))
    NATURAL)
   (4
    ((117 295) (128 291) (134 283) (136 269))
    NIL
    ((12.0666656 -3.33333302 0 0 -6.3999996 -4. )
     (8.8666649 -5.333333 -6.3999996 -4. 2. -4. )
     (3.46666622 -11.333332 -4.39999962 -8. 4.39999962 8. ))
    NATURAL))

  ((2
    ((136 159) (136 79))
    NIL
    ((0 -80. 0 0 0 0 ))
    NATURAL)
   (12
    ((136 79) (133 52) (122 34) (108 40) (100 62) (96 88)
     (95 116) (97 143) (104 168) (117 179) (130 174) (136 159))
    NIL
    ((-1.1699872 -27.978817 0 0 -10.9800758 5.87290669 )
     (-6.6600256 -25.042362 -10.9800758 5.87290669 6.90038396 24.635463 )
     (-14.189909 -6.85172368 -4.07969189 30.508373 13.378538 -14.4147758 )
     (-11.5803318 16.44926 9.2988472 16.093597 -6.414546 -14.9763717 )
     (-5.48875714 25.054672 2.88430118 1.11722469 0.279644012 2.32027578 )
     (-2.46463442 27.332035 3.1639452 3.43750048 -0.704028130 -6.30472756 )
     (0.347296834 27.617172 2.45991707 -2.86722755 2.53646755 4.89863777 )
     (4.07544804 27.199264 4.99638462 2.03141022 2.55815506 -19.289821 )
     (10.35091 19.585762 7.55453969 -17.258411 -6.76908303 0.260658264 )
     (14.520908 2.45767784 0.785455943 -16.997753 -11.481819 6.24719239 )
     (9.56545449 -11.416479 -10.696363 -10.7505607 10.696363 10.7505607 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 145Q)
 (FACE M R R)
 (WIDTH 211 0)
 (FIDUCIAL 385 385)
 (VERSION 0 29-SEP-77 17:02:38)
 (MADE-FROM NIL 118 130 57 78)
 (SPLINES

  ((19
    ((200 104) (197 137) (186 166) (170 186) (148 200) (119 206)
     (86 205) (51 189) (30 166) (17 136) (12 101) (16 66)
     (32 30) (59 7) (92 -5) (123 -5) (153 7) (175 25)
     (195 50))
    NIL
    ((-1.13248205 33.50447 0 0 -11.2051067 -3.02686691 )
     (-6.73503495 31.991043 -11.2051067 -3.02686691 8.02553369 -8.86566545 )
     (-13.9273739 24.531341 -3.1795721 -11.892532 -2.89703178 8.48953248 )
     (-18.555461 16.883575 -6.0766039 -3.4029994 -2.43740368 -7.09246636 )
     (-25.850769 9.93434335 -8.51400758 -10.495466 6.6466446 7.880332 )
     (-31.041454 3.37904358 -1.86736274 -2.61513424 -6.14917756 -18.428859 )
     (-35.983406 -8.45052148 -8.01654054 -21.043994 29.950065 17.835117 )
     (-29.024913 -20.576957 21.933525 -3.20887518 -17.651088 -4.9116268 )
     (-15.916933 -26.241645 4.28243447 -8.12050248 4.65429688 1.81138706 )
     (-9.30734826 -33.45645 8.93673135 -6.3091154 -0.966098786 9.66608239 )
     (-0.853666306 -34.932525 7.97063256 3.35696745 5.21010018 -10.475719 )
     (9.72201539 -36.813415 13.1807327 -7.11875249 -1.8743 26.236793 )
     (21.965599 -30.813774 11.3064327 19.118042 -3.71290112 -10.4714679 )
     (31.41558 -16.931465 7.5935316 8.646574 -13.274093 3.64907837 )
     (32.372062 -6.46035195 -5.68056298 12.295652 8.8092842 1.87515449 )
     (31.096145 6.7728777 3.12872219 14.1708069 -15.963047 -11.1496887 )
     (26.243343 15.368839 -12.8343258 3.02111721 13.0429058 6.72360325 )
     (19.930469 21.751758 0.208581745 9.74472047 -0.208581745 -9.74472047 ))
    NATURAL)
   (2
    ((195 50) (185 59))
    NIL
    ((-10. 9. 0 0 0 0 ))
    NATURAL)
   (7
    ((185 59) (165 43) (143 36) (114 46) (99 67) (94 87)
     (93 104))
    NIL
    ((-20.189743 -17.4038429 0 0 1.13846111 8.42307664 )
     (-19.62051 -13.192306 1.13846111 8.42307664 -17.692302 11.884613 )
     (-27.328205 1.17307806 -16.553844 20.307689 39.63076 -7.9615383 )
     (-24.066661 17.5 23.076919 12.346151 -14.830766 -16.0384559 )
     (-8.40512658 21.826919 8.24615289 -3.692307 -4.30769062 0.115384102 )
     (-2.31282043 18.192306 3.93846178 -3.57692289 -3.93846178 3.57692289 ))
    NATURAL)
   (2
    ((93 104) (200 104))
    NIL
    ((107. 0 0 0 0 0 ))
    NATURAL))

  ((9
    ((93 122) (92 141) (93 158) (97 178) (111 188) (125 178)
     (129 158) (130 141) (129 122))
    NIL
    ((-1.5 19.855667 0 0 3. -5.13401985 )
     (0 17.288658 3. -5.13401985 -3. 13.670101 )
     (1.5 18.989688 0 8.5360813 15. -19.546386 )
     (9. 17.7525749 15. -11.010307 -15. -13.484535 )
     (16.5 -9.53674316E-7 0 -24.494842 -15. 13.484533 )
     (8.9999981 -17.7525749 -15. -11.010309 15. 19.54639 )
     (1.49999976 -18.989688 1.27768117E-7 8.5360813 -3. -13.670101 )
     (0 -17.288658 -3. -5.13401985 3. 5.13401985 ))
    NATURAL)
   (2
    ((129 122) (93 122))
    NIL
    ((-36. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 146Q)
 (FACE M R R)
 (WIDTH 206 0)
 (FIDUCIAL 385 385)
 (VERSION 0 29-SEP-77 17:13:04)
 (MADE-FROM NIL 141 130 57 78)
 (SPLINES

  ((2
    ((123 36) (123 182))
    NIL
    ((0 146. 0 0 0 0 ))
    NATURAL)
   (2
    ((123 182) (153 182))
    NIL
    ((30. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((153 182) (153 200))
    NIL
    ((0 18. 0 0 0 0 ))
    NATURAL)
   (2
    ((153 200) (123 200))
    NIL
    ((-30. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((123 200) (123 240))
    NIL
    ((0 40. 0 0 0 0 ))
    NATURAL)
   (17
    ((123 240) (121 259) (120 275) (128 285) (134 278) (134 266)
     (148 248) (171 244) (191 257) (191 283) (174 298) (150 303)
     (125 303) (94 297) (69 286) (48 266) (41 240))
    NIL
    ((-1.63036418 19.686523 0 0 -2.21781492 -4.11915779 )
     (-2.73927164 17.626945 -2.21781492 -4.11915779 17.089073 2.59579229 )
     (3.58745146 14.805685 14.871259 -1.52336526 -18.138488 -24.264011 )
     (9.3894653 1.15031027 -3.26723003 -25.78738 -10.53511 28.460277 )
     (0.854681612 -10.4069309 -13.802341 2.67289829 36.27893 -17.577106 )
     (5.1918087 -16.5225868 22.476593 -14.904209 -14.580635 35.848144 )
     (20.378082 -13.5027198 7.89595795 20.943939 -7.9563837 -5.81549454 )
     (24.295848 4.53347206 -0.0604261532 15.128444 -25.593822 5.4138298 )
     (11.4385109 22.368831 -25.65425 20.542274 8.3316803 -39.83982 )
     (-10.0499019 22.991195 -17.32257 -19.297546 10.267128 9.9454651 )
     (-22.238906 8.66637994 -7.05544186 -9.3520813 10.5997829 6.05795956 )
     (-23.994457 2.34327888 3.54434252 -3.29412127 -16.666267 -4.17730904 )
     (-28.783252 -3.03949785 -13.121927 -7.47143078 26.0653 4.65127945 )
     (-28.872528 -8.18528939 12.9433727 -2.82015133 -15.594938 -8.42780686 )
     (-23.726623 -15.219345 -2.65156555 -11.247959 24.314453 5.05994892 )
     (-14.220962 -23.937328 21.662887 -6.1880102 -21.662887 6.1880102 ))
    NATURAL)
   (2
    ((41 240) (41 200))
    NIL
    ((0 -40. 0 0 0 0 ))
    NATURAL)
   (2
    ((41 200) (11 200))
    NIL
    ((-30. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((11 200) (11 182))
    NIL
    ((0 -18. 0 0 0 0 ))
    NATURAL)
   (2
    ((11 182) (41 182))
    NIL
    ((30. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((41 182) (41 36))
    NIL
    ((0 -146. 0 0 0 0 ))
    NATURAL)
   (4
    ((41 36) (38 19) (30 11) (18 8))
    NIL
    ((-1.93333339 -19.066665 0 0 -6.3999996 12.3999996 )
     (-5.1333332 -12.8666649 -6.3999996 12.3999996 2. -8. )
     (-10.5333328 -4.46666622 -4.39999962 4.39999962 4.39999962 -4.39999962 ))
    NATURAL)
   (2
    ((18 8) (18 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((18 0) (146 0))
    NIL
    ((128. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((146 0) (146 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((146 8) (134 11) (126 19) (123 36))
    NIL
    ((-12.7333316 2.26666641 0 0 4.39999962 4.39999962 )
     (-10.5333328 4.46666622 4.39999962 4.39999962 2. 8. )
     (-5.1333332 12.8666668 6.3999996 12.3999996 -6.3999996 -12.3999996 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 147Q)
 (FACE M R R)
 (WIDTH 243 0)
 (FIDUCIAL 385 385)
 (VERSION 0 29-SEP-77 17:37:45)
 (MADE-FROM NIL 114 130 44 38)
 (SPLINES

  ((2
    ((228 196) (228 173))
    NIL
    ((0 -23. 0 0 0 0 ))
    NATURAL)
   (2
    ((228 173) (198 173))
    NIL
    ((-30. 0 0 0 0 0 ))
    NATURAL)
   (29
    ((198 173) (209 151) (211 124) (201 98) (178 80) (151 70)
     (121 68) (95 64) (89 55) (101 47) (129 44) (161 43)
     (187 38) (209 28) (222 17) (229 3) (230 -24) (218 -47)
     (192 -64) (156 -74) (119 -76) (91 -75) (66 -72) (41 -66)
     (20 -53) (15 -37) (28 -25) (47 -19) (63 -14))
    NIL
    ((12.78347 -20.712417 0 0 -10.7008228 -7.7254791 )
     (7.43305874 -24.575157 -10.7008228 -7.7254791 -0.495885849 8.62739755 )
     (-3.51570749 -27.986938 -11.1967086 0.901919008 -5.31562805 9.21588326 )
     (-17.370227 -22.477077 -16.512336 10.1178035 15.758396 -3.49094486 )
     (-26.003368 -14.1047439 -0.753939868 6.6268587 -3.71796274 4.74789715 )
     (-28.61629 -5.1039362 -4.47190285 11.3747558 5.11345577 -15.500644 )
     (-30.531463 -1.47950363 0.641553402 -4.12588978 25.264133 -2.74530792 )
     (-17.257843 -6.97804738 25.905689 -6.8711977 -10.169996 8.48187829 )
     (3.56284761 -9.60830499 15.7356929 1.61068225 3.41583443 4.81778527 )
     (21.006458 -5.58872986 19.151527 6.42846776 -15.493345 -3.75302172 )
     (32.411308 -1.03677320 3.65818119 2.67544603 -13.442436 -7.8056984 )
     (29.348274 -2.26417684 -9.78425599 -5.13025284 9.2631035 -1.02417946 )
     (24.195571 -7.90651894 -0.521150828 -6.1544323 -11.609985 5.90241528 )
     (17.869426 -11.109743 -12.1311378 -0.252016604 7.17684079 1.41451549 )
     (9.32670976 -10.6545028 -4.95429707 1.16249895 0.902627946 -23.560474 )
     (4.82372666 -21.272243 -4.05166912 -22.397975 -10.787355 32.8274 )
     (-4.62162113 -27.256519 -14.839025 10.429424 0.246803283 -5.7491474 )
     (-19.3372459 -19.701667 -14.592222 4.68027687 3.80014229 2.1691885 )
     (-32.029396 -13.936798 -10.7920799 6.84946538 8.55262567 3.07239437 )
     (-38.545158 -5.5511341 -2.23945331 9.92185975 15.989345 -8.45877076 )
     (-32.789939 0.141339540 13.749893 1.46308779 -12.5100116 0.762699366 )
     (-25.295055 1.9857769 1.23988032 2.22578716 -1.94929528 -0.592023611 )
     (-25.029823 3.91555214 -0.709414959 1.63376355 2.30719423 7.60539437 )
     (-24.585639 9.35201264 1.59777927 9.2391586 16.720512 -5.8295555 )
     (-14.627601 15.676393 18.318294 3.40960312 2.81072998 -8.2871742 )
     (5.0960598 14.942409 21.129024 -4.87757206 -15.963432 -3.02174187 )
     (18.243366 8.5539665 5.1655922 -7.8993139 -10.956989 8.3741417 )
     (17.930465 4.84172344 -5.7913971 0.474828482 5.7913971 -0.474828482 ))
    NATURAL)
   (8
    ((63 -14) (45 -8) (30 3) (22 20) (25 40) (40 55)
     (59 64) (81 71))
    NIL
    ((-18.455513 5.01511479 0 0 2.73308134 5.90930939 )
     (-17.08897 7.96976948 2.73308134 5.90930939 4.33459187 0.453452110 )
     (-12.1885948 14.105804 7.06767369 6.3627615 3.92854786 -1.72311878 )
     (-3.15664673 19.607006 10.9962215 4.6396427 3.95121765 -11.560976 )
     (9.81518365 18.466159 14.947439 -6.9213333 -13.733423 -0.0329771042 )
     (17.895908 11.528339 1.21401572 -6.9543104 2.98248005 5.69288826 )
     (20.601165 7.42047406 4.196496 -1.26142215 -4.196496 1.26142215 ))
    NATURAL)
   (13
    ((81 71) (49 84) (30 100) (17 122) (16 147) (23 169)
     (38 186) (57 197) (84 203) (112 205) (133 204) (160 199)
     (178 196))
    NIL
    ((-35.25244 12.5588417 0 0 19.514675 2.64694261 )
     (-25.495105 13.8823127 19.514675 2.64694261 -19.573375 4.76528645 )
     (-15.76712 18.911899 -0.0587015748 7.41222954 16.778831 -3.70809364 )
     (-7.43640328 24.470081 16.7201309 3.7041359 -11.541971 -7.93291188 )
     (3.51274204 24.207763 5.17815876 -4.22877598 5.38906956 -0.560255051 )
     (11.385435 19.69886 10.567228 -4.78903103 -10.014303 -1.82606792 )
     (16.9455108 13.9967937 0.552924156 -6.61509896 10.668148 1.86452961 )
     (22.832511 8.3139591 11.221073 -4.75056935 -8.6582985 0.367947578 )
     (29.724433 3.74736357 2.5627737 -4.38262177 -18.034942 2.6636815 )
     (23.269737 0.696582556 -15.4721698 -1.71894026 32.798072 -5.02267456 )
     (24.196609 -3.53369522 17.325908 -6.7416153 -35.157379 11.427019 )
     (23.943824 -4.56180096 -17.831474 4.68540383 17.831474 -4.68540383 ))
    NATURAL)
   (2
    ((178 196) (228 196))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL))

  ((11
    ((122 -17) (160 -21) (170 -36) (153 -54) (124 -60) (99 -58)
     (82 -51) (73 -36) (80 -21) (99 -16) (122 -17))
    NIL
    ((33.954147 -1.97819113 34.128494 1.78905892 -78.110366 -17.498027 )
     (29.027458 -8.9381466 -43.981872 -15.708971 17.780868 10.755794 )
     (-6.06398297 -19.269218 -26.201004 -4.95317555 12.9869098 22.474849 )
     (-25.77153 -12.984966 -13.214094 17.521675 20.271484 -10.655218 )
     (-28.849884 -0.790901423 7.05739117 6.86645699 1.92713833 -3.85396195 )
     (-20.828922 4.14857388 8.9845295 3.01249504 -3.9800415 8.0710678 )
     (-13.834413 11.1966037 5.00448799 11.0835628 13.9930248 -10.430311 )
     (-1.83341241 17.06501 18.997512 0.653250337 -3.99206352 -14.349813 )
     (15.1680698 10.543352 15.005449 -13.6965637 -22.024765 7.82957268 )
     (19.161136 0.761575103 -7.01931763 -5.86699105 44.091133 7.0315218 ))
    PSEUDOCYCLIC))

  ((17
    ((113 84) (123 90) (128 103) (131 119) (131 137) (131 155)
     (128 171) (123 184) (113 190) (103 184) (98 171) (95 155)
     (95 137) (95 119) (98 103) (103 90) (113 84))
    NIL
    ((11.253885 0.0487168580 0.0133232101 14.7384567 -7.56328488 -8.50767137 )
     (7.48556615 10.5333366 -7.54996205 6.23078538 7.73648549 -3.89238644 )
     (3.8038473 14.81793 0.186523854 2.33839893 -5.3826561 0.0772185326 )
     (1.29904294 17.194938 -5.19613266 2.41561746 7.7941389 -2.41648722 )
     (-1.98682137E-5 18.402309 2.59800672 -8.69973097E-4 -7.7939005 -2.41126728 )
     (-1.29896378 17.195808 -5.19589424 -2.41213751 5.3814659 0.0615592003 )
     (-3.80412483 14.814449 0.185572236 -2.35057831 -7.73196507 -3.83496952 )
     (-7.4845352 10.5463867 -7.5463934 -6.18554783 7.5463934 -8.72167588 )
     (-11.25773 -3.18512320E-7 2.55536235E-7 -14.907224 7.54639149 8.72167588 )
     (-7.4845352 -10.5463867 7.54639245 -6.18554879 -7.7319641 3.83497095 )
     (-3.80412483 -14.814449 -0.185571968 -2.35057783 5.3814659 -0.0615596771 )
     (-1.29896354 -17.195808 5.19589424 -2.41213751 -7.7939005 2.41126728 )
     (-1.97092667E-5 -18.402309 -2.59800672 -8.69973213E-4 7.79413796 2.41648722 )
     (1.29904318 -17.194938 5.1961317 2.41561746 -5.38265515 -0.0772185326 )
     (3.8038473 -14.81793 -0.186523586 2.33839893 7.73648549 3.89238644 )
     (7.48556615 -10.5333366 7.54996205 6.23078538 -7.56328488 8.50767137 ))
    PSEUDOCYCLIC))))

((FAMILY TIMESROMAND)
 (CHARACTER 150Q)
 (FACE M R R)
 (WIDTH 259 0)
 (FIDUCIAL 385 385)
 (VERSION 0 29-SEP-77 17:58:05)
 (MADE-FROM NIL 88 130 57 78)
 (SPLINES

  ((2
    ((112 300) (112 183))
    NIL
    ((0 -117. 0 0 0 0 ))
    NATURAL)
   (8
    ((112 183) (130 196) (152 207) (176 212) (198 208) (217 196)
     (231 169) (235 142))
    NIL
    ((17.098247 13.2576427 0 0 5.41051197 -1.54586053 )
     (19.803501 12.484712 5.41051197 -1.54586053 -3.05255985 -4.27069664 )
     (23.687732 8.80350305 2.35795212 -5.81655789 -5.2002735 -5.37134838 )
     (23.445549 0.301270485 -2.84232187 -11.187906 -0.146341800 7.75609589 )
     (20.530056 -7.0085888 -2.98866367 -3.43181038 -0.214358806 -19.653034 )
     (17.434211 -20.266918 -3.20302248 -23.084846 -10.9962196 28.856056 )
     (8.7330799 -28.923736 -14.199243 5.77121258 14.199243 -5.77121258 ))
    NATURAL)
   (2
    ((235 142) (235 42))
    NIL
    ((0 -100. 0 0 0 0 ))
    NATURAL)
   (4
    ((235 42) (235 26) (239 13) (247 8))
    NIL
    ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 )
     (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 )
     (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 ))
    NATURAL)
   (2
    ((247 8) (247 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((247 0) (135 0))
    NIL
    ((-112. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((135 0) (135 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((135 8) (143 13) (147 26) (147 42))
    NIL
    ((8.79999925 3.0666666 0 0 -4.80000019 11.599998 )
     (6.3999996 8.8666668 -4.80000019 11.599998 9.53674316E-7 -9.9999981 )
     (1.59999966 15.466665 -4.79999924 1.5999999 4.79999924 -1.5999999 ))
    NATURAL)
   (2
    ((147 42) (147 142))
    NIL
    ((0 100. 0 0 0 0 ))
    NATURAL)
   (6
    ((147 142) (146 159) (139 170) (124 168) (115 157) (113 142))
    NIL
    ((-0.0478469506 17.827751 0 0 -5.71291828 -4.9665079 )
     (-2.90430641 15.3444957 -5.71291828 -4.9665079 -7.43540669 -11.167459 )
     (-12.3349266 4.79425717 -13.1483249 -16.133968 23.454544 7.63636208 )
     (-13.755979 -7.5215311 10.306219 -8.49760629 -2.38277435 4.62200833 )
     (-4.6411476 -13.7081337 7.92344475 -3.87559795 -7.92344475 3.87559795 ))
    NATURAL)
   (2
    ((113 142) (113 42))
    NIL
    ((0 -100. 0 0 0 0 ))
    NATURAL)
   (4
    ((113 42) (113 26) (117 13) (125 8))
    NIL
    ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 )
     (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 )
     (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 ))
    NATURAL)
   (2
    ((125 8) (125 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((125 0) (17 0))
    NIL
    ((-108. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((17 0) (17 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((17 8) (27 13) (31 26) (31 42))
    NIL
    ((11.333332 3.0666666 0 0 -8. 11.599998 )
     (7.333333 8.8666668 -8. 11.599998 4. -9.9999981 )
     (1.33333325 15.466665 -4. 1.5999999 4. -1.5999999 ))
    NATURAL)
   (2
    ((31 42) (31 269))
    NIL
    ((0 227. 0 0 0 0 ))
    NATURAL)
   (4
    ((31 269) (29 283) (23 291) (12 292))
    NIL
    ((-1.26666665 15.133333 0 0 -4.39999962 -6.8000002 )
     (-3.4666667 11.7333316 -4.39999962 -6.8000002 -2. -1.99999904 )
     (-8.8666668 3.93333292 -6.3999996 -8.79999925 6.3999996 8.79999925 ))
    NATURAL)
   (2
    ((12 292) (12 300))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((12 300) (112 300))
    NIL
    ((100. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 151Q)
 (FACE M R R)
 (WIDTH 146 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 10:05:21)
 (MADE-FROM NIL 177 130 57 78)
 (SPLINES

  ((2
    ((115 205) (13 205))
    NIL
    ((-102. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((13 205) (13 197))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (4
    ((13 197) (24 196) (30 188) (32 174))
    NIL
    ((12.0666656 0.466666520 0 0 -6.3999996 -8.79999925 )
     (8.8666649 -3.9333334 -6.3999996 -8.79999925 2. 2. )
     (3.46666622 -11.7333335 -4.39999962 -6.79999924 4.39999962 6.79999924 ))
    NATURAL)
   (2
    ((32 174) (32 34))
    NIL
    ((0 -140. 0 0 0 0 ))
    NATURAL)
   (5
    ((32 34) (31 25) (28 16) (22 11) (14 8))
    NIL
    ((-0.642857075 -8.75 0 0 -2.14285707 -1.5 )
     (-1.71428561 -9.5 -2.14285707 -1.5 -1.28571415 7.5 )
     (-4.5 -7.24999905 -3.42857122 6. 1.28571415 -4.5 )
     (-7.28571416 -3.49999952 -2.14285707 1.49999976 2.14285707 -1.49999976 ))
    NATURAL)
   (2
    ((14 8) (14 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((14 0) (133 0))
    NIL
    ((119. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((133 0) (133 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (5
    ((133 8) (125 11) (119 16) (116 25) (115 34))
    NIL
    ((-8.3571415 2.74999952 0 0 2.14285707 1.50000024 )
     (-7.28571416 3.5 2.14285707 1.50000024 1.28571415 4.4999981 )
     (-4.49999905 7.25 3.42857122 5.99999905 -1.28571415 -7.4999981 )
     (-1.71428561 9.4999981 2.14285707 -1.49999976 -2.14285707 1.49999976 ))
    NATURAL)
   (2
    ((115 34) (115 205))
    NIL
    ((0 171. 0 0 0 0 ))
    NATURAL))

  ((17
    ((73 305) (91 302) (105 294) (113 282) (116 271) (113 260)
     (105 248) (91 240) (73 237) (55 240) (41 248) (33 260)
     (30 271) (33 282) (41 294) (55 302) (73 305))
    NIL
    ((18.854923 -0.116663769 -0.497396290 -6.39998913 -3.63736725 1.89995003 )
     (16.538845 -5.56667805 -4.13476372 -4.5000391 -2.82878303 -1.09981155 )
     (10.9896888 -10.6166229 -6.96354676 -5.59985066 2.95249748 8.49929238 )
     (5.5023918 -11.966827 -4.01104927 2.89944172 -2.98120499 -2.89735794 )
     (7.40051269E-4 -10.5160637 -6.99225426 0.00208338676 2.97232246 -2.90985823 )
     (-5.50535298 -11.96891 -4.0199318 -2.90777492 -2.90808678 8.53679086 )
     (-10.979326 -10.6082897 -6.92801858 5.62901592 2.66002369 -1.23730755 )
     (-16.577331 -5.59792614 -4.26799488 4.39170838 4.26799488 2.41243648 )
     (-18.71133 3.18512320E-7 0 6.80414487 4.26799488 -2.41243648 )
     (-16.577331 5.5979271 4.26799488 4.39170838 2.66002273 1.23730755 )
     (-10.979326 10.6082897 6.9280176 5.62901592 -2.90808678 -8.53679086 )
     (-5.50535202 11.96891 4.01993084 -2.90777492 2.97232437 2.90985775 )
     (7.40210526E-4 10.5160637 6.9922552 0.00208325917 -2.98120689 2.89735842 )
     (5.50239277 11.966827 4.01104832 2.89944172 2.95249843 -8.49929048 )
     (10.9896888 10.6166229 6.96354676 -5.5998497 -2.82878303 1.09980964 )
     (16.538845 5.56667805 4.13476372 -4.50004006 -3.63736725 -1.89994907 ))
    PSEUDOCYCLIC))))

((FAMILY TIMESROMAND)
 (CHARACTER 152Q)
 (FACE M R R)
 (WIDTH 162 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 10:08:40)
 (MADE-FROM NIL 146 130 57 78)
 (SPLINES

  ((2
    ((146 205) (44 205))
    NIL
    ((-102. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((44 205) (44 197))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (4
    ((44 197) (55 196) (61 188) (63 174))
    NIL
    ((12.0666656 0.466666520 0 0 -6.3999996 -8.79999925 )
     (8.8666649 -3.9333334 -6.3999996 -8.79999925 2. 2. )
     (3.46666622 -11.7333335 -4.39999962 -6.79999924 4.39999962 6.79999924 ))
    NATURAL)
   (2
    ((63 174) (63 6))
    NIL
    ((0 -168. 0 0 0 0 ))
    NATURAL)
   (16
    ((63 6) (66 -15) (68 -40) (66 -55) (58 -54) (56 -33)
     (40 -18) (19 -20) (10 -35) (13 -56) (36 -71) (74 -76)
     (111 -68) (136 -46) (146 -18) (146 6))
    NIL
    ((3.14361906 -19.411846 0 0 -0.861714364 -9.52890206 )
     (2.71276188 -24.1763 -0.861714364 -9.52890206 -1.69142818 23.644516 )
     (1.00533318 -21.882942 -2.55314255 14.1156139 -10.3725719 -1.04916954 )
     (-6.73409558 -8.291914 -12.925714 13.066444 31.181716 16.552154 )
     (-4.06895066 13.0506077 18.256004 29.618598 -42.354309 -41.159439 )
     (-6.9900999 22.089481 -24.098304 -11.5408439 18.235511 -7.9143753 )
     (-21.970645 6.5914507 -5.86279106 -19.455219 23.412258 6.81695367 )
     (-16.127304 -9.45529176 17.549469 -12.638265 -9.88456727 4.64655018 )
     (-3.52012062 -19.770282 7.66490174 -7.99171544 16.126018 16.596843 )
     (12.207792 -19.463573 23.79092 8.60513116 -6.61951447 0.966056824 )
     (32.688949 -10.3754139 17.171405 9.57118798 -19.647953 3.53892136 )
     (40.036384 0.965236307 -2.47654915 13.110109 -10.78866 2.87825394 )
     (32.165504 15.5144729 -13.265209 15.988363 -3.19739914 -9.05192758 )
     (17.301593 26.976871 -16.462608 6.9364357 5.57826233 -14.670543 )
     (3.62811518 26.578033 -10.884346 -7.7341089 10.884346 7.7341089 ))
    NATURAL)
   (2
    ((146 6) (146 205))
    NIL
    ((0 199. 0 0 0 0 ))
    NATURAL))

  ((17
    ((104 305) (122 302) (136 294) (144 282) (147 271) (144 260)
     (136 248) (122 240) (104 237) (86 240) (72 248) (64 260)
     (61 271) (64 282) (72 294) (86 302) (104 305))
    NIL
    ((18.854923 -0.116663769 -0.497396290 -6.39998913 -3.63736725 1.89995003 )
     (16.538845 -5.56667805 -4.13476372 -4.5000391 -2.82878303 -1.09981155 )
     (10.9896888 -10.6166229 -6.96354676 -5.59985066 2.95249748 8.49929238 )
     (5.5023918 -11.966827 -4.01104927 2.89944172 -2.98120499 -2.89735794 )
     (7.40051269E-4 -10.5160637 -6.99225426 0.00208338676 2.97232246 -2.90985823 )
     (-5.50535298 -11.96891 -4.0199318 -2.90777492 -2.90808678 8.53679086 )
     (-10.979326 -10.6082897 -6.92801858 5.62901592 2.66002369 -1.23730755 )
     (-16.577331 -5.59792614 -4.26799488 4.39170838 4.26799488 2.41243648 )
     (-18.71133 3.18512320E-7 0 6.80414487 4.26799488 -2.41243648 )
     (-16.577331 5.5979271 4.26799488 4.39170838 2.66002273 1.23730755 )
     (-10.979326 10.6082897 6.9280176 5.62901592 -2.90808678 -8.53679086 )
     (-5.50535202 11.96891 4.01993084 -2.90777492 2.97232437 2.90985775 )
     (7.40210526E-4 10.5160637 6.9922552 0.00208325917 -2.98120689 2.89735842 )
     (5.50239277 11.966827 4.01104832 2.89944172 2.95249843 -8.49929048 )
     (10.9896888 10.6166229 6.96354676 -5.5998497 -2.82878303 1.09980964 )
     (16.538845 5.56667805 4.13476372 -4.50004006 -3.63736725 -1.89994907 ))
    PSEUDOCYCLIC))))

((FAMILY TIMESROMAND)
 (CHARACTER 153Q)
 (FACE M R R)
 (WIDTH 259 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 10:19:29)
 (MADE-FROM NIL 88 130 57 78)
 (SPLINES

  ((2
    ((114 300) (113 117))
    NIL
    ((-1. -183. 0 0 0 0 ))
    NATURAL)
   (2
    ((113 117) (142 155))
    NIL
    ((29. 38. 0 0 0 0 ))
    NATURAL)
   (5
    ((142 155) (150 170) (147 185) (138 193) (129 195))
    NIL
    ((10.5178566 14.607141 0 0 -15.107141 2.35714245 )
     (2.9642849 15.785713 -15.107141 2.35714245 9.5357132 -11.785711 )
     (-7.375 12.249998 -5.5714283 -9.4285698 6.9642849 2.78571319 )
     (-9.4642849 4.2142849 1.39285707 -6.6428566 -1.39285707 6.6428566 ))
    NATURAL)
   (3
    ((129 195) (129 205) (129 205))
    NIL
    ((0 12.5 0 0 0 -15. )
     (0 5. 0 -15. 0 15. ))
    NATURAL)
   (2
    ((129 205) (229 205))
    NIL
    ((100. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((229 205) (229 195))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (5
    ((229 195) (209 189) (192 178) (177 164) (165 150))
    NIL
    ((-20.714283 -4.875 0 0 4.28571415 -6.75 )
     (-18.571426 -8.25 4.28571415 -6.75 -3.42857122 3.75000048 )
     (-15.999998 -13.125 0.857142807 -2.99999952 3.42857122 3.74999905 )
     (-13.4285698 -14.249998 4.28571415 0.749999881 -4.28571415 -0.749999881 ))
    NATURAL)
   (2
    ((165 150) (233 23))
    NIL
    ((68. -127. 0 0 0 0 ))
    NATURAL)
   (3
    ((233 23) (242 10) (247 8))
    NIL
    ((10. -15.75 0 0 -6. 16.5 )
     (7. -7.5 -6. 16.5 6. -16.5 ))
    NATURAL)
   (2
    ((247 8) (247 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((247 0) (135 0))
    NIL
    ((-112. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((135 0) (135 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((135 8) (143 11) (146 18) (141 30))
    NIL
    ((8.79999925 2.26666641 0 0 -4.80000019 4.39999962 )
     (6.3999996 4.46666622 -4.80000019 4.39999962 -5.99999905 2. )
     (-1.40000009 9.8666668 -10.799999 6.3999996 10.799999 -6.3999996 ))
    NATURAL)
   (2
    ((141 30) (113 90))
    NIL
    ((-28. 60. 0 0 0 0 ))
    NATURAL)
   (2
    ((113 90) (113 39))
    NIL
    ((0 -51. 0 0 0 0 ))
    NATURAL)
   (4
    ((113 39) (115 24) (120 13) (125 8))
    NIL
    ((1.20000004 -15.666666 0 0 4.79999924 4. )
     (3.5999999 -13.666666 4.79999924 4. -5.99999905 4. )
     (5.3999996 -7.66666604 -1.19999981 8. 1.19999981 -8. ))
    NATURAL)
   (2
    ((125 8) (125 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((125 0) (13 0))
    NIL
    ((-112. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((13 0) (13 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((13 8) (23 13) (31 26) (31 42))
    NIL
    ((10. 3.0666666 0 0 0 11.599998 )
     (10. 8.8666668 0 11.599998 -12. -9.9999981 )
     (4. 15.466665 -12. 1.5999999 12. -1.5999999 ))
    NATURAL)
   (2
    ((31 42) (31 269))
    NIL
    ((0 227. 0 0 0 0 ))
    NATURAL)
   (5
    ((31 269) (30 276) (29 283) (23 290) (12 292))
    NIL
    ((-1.26785707 7.0892849 0 0 1.60714268 -0.535714150 )
     (-0.464285731 6.8214283 1.60714268 -0.535714150 -8.0357132 2.67857075 )
     (-2.875 7.625 -6.42857075 2.1428566 0.535714150 -10.1785698 )
     (-9.0357132 4.67857075 -5.8928566 -8.0357132 5.8928566 8.0357132 ))
    NATURAL)
   (2
    ((12 292) (12 300))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((12 300) (114 300))
    NIL
    ((102. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 154Q)
 (FACE M R R)
 (WIDTH 145 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 10:25:22)
 (MADE-FROM NIL 167 130 57 78)
 (SPLINES

  ((2
    ((14 0) (14 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((14 8) (24 13) (32 26) (32 42))
    NIL
    ((10. 3.0666666 0 0 0 11.599998 )
     (10. 8.8666668 0 11.599998 -12. -9.9999981 )
     (4. 15.466665 -12. 1.5999999 12. -1.5999999 ))
    NATURAL)
   (2
    ((32 42) (32 269))
    NIL
    ((0 227. 0 0 0 0 ))
    NATURAL)
   (5
    ((32 269) (31 276) (29 283) (22 290) (9 292))
    NIL
    ((-0.982142807 7.0892849 0 0 -0.107142925 -0.535714150 )
     (-1.03571415 6.8214283 -0.107142925 -0.535714150 -5.4642849 2.67857075 )
     (-3.875 7.625 -5.5714283 2.1428566 -2.03571415 -10.1785698 )
     (-10.4642849 4.67857075 -7.60714245 -8.0357132 7.60714245 8.0357132 ))
    NATURAL)
   (2
    ((9 292) (9 300))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((9 300) (114 300))
    NIL
    ((105. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((114 300) (114 42))
    NIL
    ((0 -258. 0 0 0 0 ))
    NATURAL)
   (4
    ((114 42) (114 26) (122 13) (132 8))
    NIL
    ((-2. -16.266666 0 0 12. 1.60000038 )
     (4. -15.466665 12. 1.60000038 -12. 9.9999981 )
     (10. -8.8666649 0 11.599998 0 -11.599998 ))
    NATURAL)
   (2
    ((132 8) (132 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((132 0) (14 0))
    NIL
    ((-118. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 155Q)
 (FACE M R R)
 (WIDTH 378 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 10:35:30)
 (MADE-FROM NIL 88 130 86 90)
 (SPLINES

  ((2
    ((112 179) (112 205))
    NIL
    ((0 26. 0 0 0 0 ))
    NATURAL)
   (2
    ((112 205) (14 205))
    NIL
    ((-98. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((14 205) (14 205) (14 197))
    NIL
    ((0 2. 0 0 0 -12. )
     (0 -4. 0 -12. 0 12. ))
    NATURAL)
   (4
    ((14 197) (24 192) (30 179) (31 163))
    NIL
    ((10.7333316 -3.0666666 0 0 -4.39999962 -11.599998 )
     (8.5333328 -8.8666668 -4.39999962 -11.599998 -2. 9.9999981 )
     (3.1333332 -15.466665 -6.3999996 -1.5999999 6.3999996 1.5999999 ))
    NATURAL)
   (2
    ((31 163) (31 42))
    NIL
    ((0 -121. 0 0 0 0 ))
    NATURAL)
   (4
    ((31 42) (31 26) (27 13) (17 8))
    NIL
    ((0.666666627 -16.266666 0 0 -4. 1.60000038 )
     (-1.33333325 -15.466665 -4. 1.60000038 -4. 9.9999981 )
     (-7.333333 -8.8666649 -8. 11.599998 8. -11.599998 ))
    NATURAL)
   (2
    ((17 8) (17 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((17 0) (125 0))
    NIL
    ((108. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((125 0) (125 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((125 8) (117 13) (113 26) (113 42))
    NIL
    ((-8.79999925 3.0666666 0 0 4.80000019 11.599998 )
     (-6.3999996 8.8666668 4.80000019 11.599998 -9.53674316E-7 -9.9999981 )
     (-1.59999966 15.466665 4.79999924 1.5999999 -4.79999924 -1.5999999 ))
    NATURAL)
   (2
    ((113 42) (113 142))
    NIL
    ((0 100. 0 0 0 0 ))
    NATURAL)
   (6
    ((113 142) (115 157) (124 168) (139 170) (146 159) (147 142))
    NIL
    ((0.679425836 15.645931 0 0 7.92344475 -3.87559795 )
     (4.64114857 13.7081337 7.92344475 -3.87559795 2.38277435 -4.62201023 )
     (13.755979 7.52153016 10.306219 -8.49760819 -23.454544 -7.63636017 )
     (12.3349266 -4.79425907 -13.1483249 -16.133968 7.43540669 11.167461 )
     (2.90430593 -15.344497 -5.71291828 -4.96650696 5.71291828 4.96650696 ))
    NATURAL)
   (2
    ((147 142) (147 42))
    NIL
    ((0 -100. 0 0 0 0 ))
    NATURAL)
   (4
    ((147 42) (147 26) (143 13) (135 8))
    NIL
    ((0.799999953 -16.266666 0 0 -4.80000019 1.60000038 )
     (-1.5999999 -15.466665 -4.80000019 1.60000038 9.53674316E-7 9.9999981 )
     (-6.3999996 -8.8666649 -4.79999924 11.599998 4.79999924 -11.599998 ))
    NATURAL)
   (2
    ((135 8) (135 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((135 0) (241 0))
    NIL
    ((106. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((241 0) (241 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((241 8) (233 13) (229 26) (229 42))
    NIL
    ((-8.79999925 3.0666666 0 0 4.80000019 11.599998 )
     (-6.3999996 8.8666668 4.80000019 11.599998 -9.53674316E-7 -9.9999981 )
     (-1.59999966 15.466665 4.79999924 1.5999999 -4.79999924 -1.5999999 ))
    NATURAL)
   (2
    ((229 42) (229 142))
    NIL
    ((0 100. 0 0 0 0 ))
    NATURAL)
   (6
    ((229 142) (231 157) (240 168) (255 170) (262 159) (263 142))
    NIL
    ((0.679425836 15.645931 0 0 7.92344475 -3.87559795 )
     (4.64114857 13.7081337 7.92344475 -3.87559795 2.38277435 -4.62201023 )
     (13.755979 7.52153016 10.306219 -8.49760819 -23.454544 -7.63636017 )
     (12.3349266 -4.79425907 -13.1483249 -16.133968 7.43540669 11.167461 )
     (2.90430593 -15.344497 -5.71291828 -4.96650696 5.71291828 4.96650696 ))
    NATURAL)
   (2
    ((263 142) (263 42))
    NIL
    ((0 -100. 0 0 0 0 ))
    NATURAL)
   (4
    ((263 42) (263 26) (259 13) (251 8))
    NIL
    ((0.799999953 -16.266666 0 0 -4.80000019 1.60000038 )
     (-1.5999999 -15.466665 -4.80000019 1.60000038 9.53674316E-7 9.9999981 )
     (-6.3999996 -8.8666649 -4.79999924 11.599998 4.79999924 -11.599998 ))
    NATURAL)
   (2
    ((251 8) (251 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((251 0) (363 0))
    NIL
    ((112. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((363 0) (363 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((363 8) (355 13) (351 26) (351 42))
    NIL
    ((-8.79999925 3.0666666 0 0 4.80000019 11.599998 )
     (-6.3999996 8.8666668 4.80000019 11.599998 -9.53674316E-7 -9.9999981 )
     (-1.59999966 15.466665 4.79999924 1.5999999 -4.79999924 -1.5999999 ))
    NATURAL)
   (2
    ((351 42) (351 142))
    NIL
    ((0 100. 0 0 0 0 ))
    NATURAL)
   (9
    ((351 142) (349 162) (343 179) (329 197) (308 208) (283 209)
     (261 202) (242 190) (225 175))
    NIL
    ((-1.39175248 20.968242 0 0 -3.64948463 -5.8094616 )
     (-3.21649456 18.0635109 -3.64948463 -5.8094616 -5.75257683 11.0473098 )
     (-9.7422676 17.777706 -9.40206147 5.23784924 2.65979385 -14.379783 )
     (-17.81443 15.82566 -6.7422676 -9.14193536 1.11340236 -1.52816772 )
     (-24. 5.91964245 -5.62886524 -10.670103 10.8865966 2.49245453 )
     (-24.185565 -3.50423479 5.25773144 -8.17764855 -2.6597929 3.55835629 )
     (-20.257728 -9.90270616 2.59793854 -4.61929226 -0.247423649 1.27411556 )
     (-17.783504 -13.884941 2.35051489 -3.3451767 -2.35051489 3.3451767 ))
    NATURAL)
   (6
    ((225 175) (205 200) (179 209) (153 206) (129 194) (112 179))
    NIL
    ((-18.397129 28.583728 0 0 -9.61722375 -21.502391 )
     (-23.205741 17.832534 -9.61722375 -21.502391 12.086122 11.5119629 )
     (-26.779903 2.08612347 2.46889925 -9.9904289 -2.72727251 -0.545455933 )
     (-25.67464 -8.17703248 -0.258373320 -10.5358848 10.8229656 8.6698551 )
     (-20.52153 -14.3779888 10.564592 -1.86602878 -10.564592 1.86602878 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.LC2-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.LC2-SF
deleted file mode 100644
index 1f75fd04..00000000
--- a/obsolete/lispusers/splinefonts/TIMESROMAN.LC2-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY TIMESROMAND)
 (CHARACTER 156Q)
 (FACE M R R)
 (WIDTH 259 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 10:57:27)
 (MADE-FROM NIL 88 130 57 78)
 (SPLINES

  ((2
    ((112 205) (112 183))
    NIL
    ((0 -22. 0 0 0 0 ))
    NATURAL)
   (8
    ((112 183) (130 196) (152 207) (176 212) (198 208) (217 196)
     (231 169) (235 142))
    NIL
    ((17.098247 13.2576427 0 0 5.41051197 -1.54586053 )
     (19.803501 12.484712 5.41051197 -1.54586053 -3.05255985 -4.27069664 )
     (23.687732 8.80350305 2.35795212 -5.81655789 -5.2002735 -5.37134838 )
     (23.445549 0.301270485 -2.84232187 -11.187906 -0.146341800 7.75609589 )
     (20.530056 -7.0085888 -2.98866367 -3.43181038 -0.214358806 -19.653034 )
     (17.434211 -20.266918 -3.20302248 -23.084846 -10.9962196 28.856056 )
     (8.7330799 -28.923736 -14.199243 5.77121258 14.199243 -5.77121258 ))
    NATURAL)
   (2
    ((235 142) (235 42))
    NIL
    ((0 -100. 0 0 0 0 ))
    NATURAL)
   (4
    ((235 42) (235 26) (239 13) (247 8))
    NIL
    ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 )
     (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 )
     (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 ))
    NATURAL)
   (2
    ((247 8) (247 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((247 0) (135 0))
    NIL
    ((-112. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((135 0) (135 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((135 8) (143 13) (147 26) (147 42))
    NIL
    ((8.79999925 3.0666666 0 0 -4.80000019 11.599998 )
     (6.3999996 8.8666668 -4.80000019 11.599998 9.53674316E-7 -9.9999981 )
     (1.59999966 15.466665 -4.79999924 1.5999999 4.79999924 -1.5999999 ))
    NATURAL)
   (2
    ((147 42) (147 142))
    NIL
    ((0 100. 0 0 0 0 ))
    NATURAL)
   (6
    ((147 142) (146 159) (139 170) (124 168) (115 157) (113 142))
    NIL
    ((-0.0478469506 17.827751 0 0 -5.71291828 -4.9665079 )
     (-2.90430641 15.3444957 -5.71291828 -4.9665079 -7.43540669 -11.167459 )
     (-12.3349266 4.79425717 -13.1483249 -16.133968 23.454544 7.63636208 )
     (-13.755979 -7.5215311 10.306219 -8.49760629 -2.38277435 4.62200833 )
     (-4.6411476 -13.7081337 7.92344475 -3.87559795 -7.92344475 3.87559795 ))
    NATURAL)
   (2
    ((113 142) (113 42))
    NIL
    ((0 -100. 0 0 0 0 ))
    NATURAL)
   (4
    ((113 42) (113 26) (117 13) (125 8))
    NIL
    ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 )
     (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 )
     (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 ))
    NATURAL)
   (2
    ((125 8) (125 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((125 0) (17 0))
    NIL
    ((-108. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((17 0) (17 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((17 8) (27 13) (31 26) (31 42))
    NIL
    ((11.333332 3.0666666 0 0 -8. 11.599998 )
     (7.333333 8.8666668 -8. 11.599998 4. -9.9999981 )
     (1.33333325 15.466665 -4. 1.5999999 4. -1.5999999 ))
    NATURAL)
   (2
    ((31 42) (31 174))
    NIL
    ((0 132. 0 0 0 0 ))
    NATURAL)
   (4
    ((31 174) (29 188) (23 196) (12 197))
    NIL
    ((-1.26666665 15.133333 0 0 -4.39999962 -6.8000002 )
     (-3.4666667 11.7333316 -4.39999962 -6.8000002 -2. -1.99999904 )
     (-8.8666668 3.93333292 -6.3999996 -8.79999925 6.3999996 8.79999925 ))
    NATURAL)
   (2
    ((12 197) (12 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((12 205) (112 205))
    NIL
    ((100. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 157Q)
 (FACE M R R)
 (WIDTH 235 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 11:02:40)
 (MADE-FROM NIL 109 130 57 78)
 (SPLINES

  ((21
    ((118 187) (130 178) (136 158) (138 141) (139 122) (140 98)
     (139 74) (138 55) (136 38) (130 18) (118 9) (106 18)
     (100 38) (98 55) (97 74) (96 98) (97 122) (98 141)
     (100 158) (106 178) (118 187))
    NIL
    ((13.420864 0.182411194 -0.271320581 -20.803161 -7.71122647 7.3150177 )
     (9.29393006 -16.963241 -7.98254777 -13.4881439 4.184062 22.243881 )
     (3.4034133 -19.329444 -3.79848528 8.7557373 2.97497558 -12.2905426 )
     (1.09241581 -16.718975 -0.823509694 -3.5348053 1.91603374 -3.08171177 )
     (1.22692299 -21.794639 1.09252405 -6.61651707 -4.63911057 6.61738969 )
     (-1.08202453E-4 -25.102458 -3.54658651 8.72911885E-4 4.64040852 6.6121521 )
     (-1.22649026 -21.795509 1.09382224 6.61302567 -1.92252469 -3.06600189 )
     (-1.09393048 -16.715484 -0.828702450 3.54702377 -2.95030975 -12.348144 )
     (-3.39778805 -19.342533 -3.7790122 -8.80112077 -4.27623368 22.45858 )
     (-9.3149166 -16.9143638 -8.05524636 13.657459 8.05524636 6.5138092 )
     (-13.3425407 3.20374965E-7 0 20.171268 8.05524636 -6.5138073 )
     (-9.3149166 16.9143638 8.05524636 13.657461 -4.27623368 -22.45858 )
     (-3.39778757 19.342533 3.77901268 -8.80112077 -2.95031023 12.3481426 )
     (-1.09393024 16.715484 0.828702331 3.5470233 -1.92252445 3.06600237 )
     (-1.22649026 21.795509 -1.09382224 6.61302567 4.64040852 -6.6121521 )
     (-1.08162406E-4 25.102458 3.54658651 8.72911885E-4 -4.63911057 -6.61738969 )
     (1.22692299 21.794639 -1.09252405 -6.61651707 1.91603374 3.08171272 )
     (1.09241581 16.7189789 0.823509694 -3.53480434 2.97497558 12.2905388 )
     (3.4034133 19.329444 3.79848528 8.7557354 4.18406296 -22.243877 )
     (9.29393006 16.963237 7.9825487 -13.488142 -7.71122838 -7.3150158 ))
    PSEUDOCYCLIC))

  ((25
    ((118 205) (148 202) (173 194) (195 179) (213 155) (222 131)
     (225 98) (222 65) (213 41) (195 17) (173 2) (148 -6)
     (118 -9) (88 -6) (63 2) (41 17) (23 41) (14 65)
     (11 98) (14 131) (23 155) (41 179) (63 194) (88 202)
     (118 205))
    NIL
    ((31.161361 -1.97820449 0 0 -6.9681711 -6.1307726 )
     (27.677272 -5.04359055 -6.9681711 -6.1307726 4.8408575 0.653862953 )
     (23.129531 -10.847431 -2.12731314 -5.47690964 -0.395261765 -8.48467637 )
     (20.804588 -20.56668 -2.5225749 -13.961586 -9.2598076 21.284843 )
     (13.652109 -23.885841 -11.7823829 7.32325936 7.434494 -22.654708 )
     (5.58697129 -27.889938 -4.34788895 -15.331449 -2.47816563 15.333984 )
     (-1.59256160E-7 -35.55439 -6.82605458 0.00253645284 2.47816467 15.318765 )
     (-5.58697224 -27.892475 -4.3478899 15.321302 -7.43449307 -22.609054 )
     (-13.652109 -23.875698 -11.7823829 -7.28775216 9.2598076 21.117458 )
     (-20.804588 -20.604721 -2.52257538 13.829706 0.395262241 -7.86078168 )
     (-23.129531 -10.705406 -2.12731314 5.96892452 -4.8408575 -1.67433166 )
     (-27.677272 -5.5736475 -6.9681711 4.29459286 6.9681711 2.55811024 )
     (-31.161361 1.59256160E-7 0 6.8527031 6.9681711 -2.55811024 )
     (-27.677272 5.57364846 6.9681711 4.29459286 -4.84085846 1.67433071 )
     (-23.129531 10.705406 2.12731266 5.96892357 0.395262718 7.8607826 )
     (-20.804588 20.604721 2.52257538 13.829706 9.2598076 -21.117458 )
     (-13.652109 23.875698 11.7823829 -7.28775216 -7.43449307 22.609054 )
     (-5.58697224 27.892475 4.3478899 15.321304 2.47816467 -15.318767 )
     (1.59256160E-7 35.55439 6.82605458 0.00253645284 -2.47816467 -15.333984 )
     (5.58697224 27.889938 4.3478899 -15.331449 7.43449307 22.654708 )
     (13.652109 23.885841 11.7823829 7.32325936 -9.2598076 -21.284847 )
     (20.804588 20.56668 2.52257538 -13.9615879 -0.395262241 8.48467828 )
     (23.129531 10.847431 2.12731314 -5.47690964 4.8408575 -0.653862000 )
     (27.677272 5.04359055 6.9681711 -6.13077164 -6.9681711 6.13077164 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 160Q)
 (FACE M R R)
 (WIDTH 252 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 11:10:37)
 (MADE-FROM NIL 119 130 57 78)
 (SPLINES

  ((5
    ((138 -62) (129 -60) (121 -55) (117 -45) (115 -28))
    NIL
    ((-9.0178566 1.42857146 0 0 0.107142925 3.42857122 )
     (-8.9642849 3.14285708 0.107142925 3.42857122 5.4642849 0.857142926 )
     (-6.12499905 7. 5.5714283 4.28571415 -3.96428537 5.14285565 )
     (-2.53571415 13.857143 1.60714292 9.4285698 -1.60714292 -9.4285698 ))
    NATURAL)
   (2
    ((115 -28) (115 18))
    NIL
    ((0 46. 0 0 0 0 ))
    NATURAL)
   (15
    ((115 18) (141 2) (171 -5) (198 5) (220 25) (233 53)
     (239 89) (239 121) (233 152) (219 180) (202 199) (179 209)
     (155 208) (134 198) (115 180))
    NIL
    ((24.77045 -17.354595 0 0 7.37729645 8.12758447 )
     (28.459098 -13.2908039 7.37729645 8.12758447 -12.886484 13.3620777 )
     (29.39315 1.51781845 -5.5091877 21.489662 2.16864204 -13.575897 )
     (24.968284 16.219532 -3.34054565 7.913764 -7.7880821 -1.05849075 )
     (17.733696 23.604049 -11.1286277 6.85527325 4.9836874 5.8098688 )
     (9.0969143 33.364257 -6.14494038 12.665142 -0.146670341 -22.180988 )
     (2.87863922 34.938903 -6.2916107 -9.51584817 1.60299492 10.9141025 )
     (-2.61147404 30.880107 -4.6886158 1.39825439 -6.26530839 -3.47542334 )
     (-10.4327449 30.540649 -10.953924 -2.07716894 11.458244 -9.0124092 )
     (-15.657547 23.957275 0.504320979 -11.0895786 -9.56767846 3.52506352 )
     (-19.937065 14.6302318 -9.0633583 -7.5645151 8.8124714 -5.0878458 )
     (-24.594184 4.5217924 -0.250885904 -12.6523609 4.31778717 4.8263235 )
     (-22.686176 -5.7174053 4.06690216 -7.8260374 -2.0836277 -2.21745205 )
     (-19.66109 -14.65217 1.98327422 -10.043489 -1.98327422 10.043489 ))
    NATURAL)
   (2
    ((115 180) (115 208))
    NIL
    ((0 28. 0 0 0 0 ))
    NATURAL)
   (2
    ((115 208) (12 195))
    NIL
    ((-103. -13. 0 0 0 0 ))
    NATURAL)
   (2
    ((12 195) (12 187))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (5
    ((12 187) (22 182) (28 176) (32 166) (33 152))
    NIL
    ((10.982141 -4.9464283 0 0 -5.8928566 -0.321428776 )
     (8.0357132 -5.10714245 -5.8928566 -0.321428776 5.4642849 -4.39285565 )
     (4.87499905 -7.625 -0.428571522 -4.7142849 -3.9642849 -0.107143402 )
     (2.46428537 -12.392856 -4.3928566 -4.8214283 4.3928566 4.8214283 ))
    NATURAL)
   (3
    ((33 152) (33 152) (33 -28))
    NIL
    ((0 45. 0 0 0 -270. )
     (0 -90. 0 -270. 0 270. ))
    NATURAL)
   (5
    ((33 -28) (32 -42) (29 -54) (22 -60) (13 -62))
    NIL
    ((-0.714285612 -14.1785698 0 0 -1.71428585 1.07142877 )
     (-1.57142853 -13.642856 -1.71428585 1.07142877 -3.42857075 6.64285565 )
     (-5. -9.2499981 -5.1428566 7.7142849 3.42857075 -3.6428566 )
     (-8.4285698 -3.35714245 -1.71428561 4.0714283 1.71428561 -4.0714283 ))
    NATURAL)
   (2
    ((13 -62) (13 -70))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((13 -70) (138 -70))
    NIL
    ((125. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((138 -70) (138 -62))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL))

  ((3
    ((115 58) (115 58) (115 138))
    NIL
    ((0 -20. 0 0 0 120. )
     (0 40. 0 120. 0 -120. ))
    NATURAL)
   (12
    ((115 138) (117 155) (124 168) (137 169) (148 150) (152 121)
     (153 86) (150 60) (144 38) (129 29) (117 43) (115 58))
    NIL
    ((1.09614515 17.554847 0 0 5.42312908 -3.32910729 )
     (3.80770969 15.8902969 5.42312908 -3.32910729 2.88435459 -7.35446358 )
     (10.6730156 8.8839569 8.30748368 -10.6835708 -10.960546 -15.253032 )
     (13.500225 -9.4261303 -2.65306425 -25.936603 -7.04216004 20.366596 )
     (7.3260803 -25.179435 -9.69522477 -5.5700054 9.12919045 -6.21336556 )
     (2.19545078 -33.856124 -0.566033244 -11.7833709 -5.4746065 28.486862 )
     (-1.10788536 -31.39606 -6.04063988 16.703491 6.7692318 -17.7340889 )
     (-3.76390886 -23.559616 0.728592634 -1.03060031 -15.602321 12.4495067 )
     (-10.836477 -18.365459 -14.873729 11.418907 19.640056 21.93605 )
     (-15.890178 4.02147007 4.76632786 33.354957 9.04208947 -40.193695 )
     (-6.6028061 17.279579 13.808418 -6.8387394 -13.808418 6.8387394 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 161Q)
 (FACE M R R)
 (WIDTH 253 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 11:20:18)
 (MADE-FROM NIL 73 130 57 78)
 (SPLINES

  ((5
    ((244 -62) (235 -60) (227 -55) (223 -45) (221 -28))
    NIL
    ((-9.0178566 1.42857146 0 0 0.107142925 3.42857122 )
     (-8.9642849 3.14285708 0.107142925 3.42857122 5.4642849 0.857142926 )
     (-6.12499905 7. 5.5714283 4.28571415 -3.96428537 5.14285565 )
     (-2.53571415 13.857143 1.60714292 9.4285698 -1.60714292 -9.4285698 ))
    NATURAL)
   (2
    ((221 -28) (221 213))
    NIL
    ((0 241. 0 0 0 0 ))
    NATURAL)
   (2
    ((221 213) (214 213))
    NIL
    ((-7. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((214 213) (184 184))
    NIL
    ((-30. -29. 0 0 0 0 ))
    NATURAL)
   (16
    ((184 184) (167 199) (140 211) (104 214) (65 204) (43 189)
     (27 168) (16 142) (11 101) (14 71) (24 40) (41 17)
     (61 4) (86 -1) (114 8) (139 30))
    NIL
    ((-14.8281898 15.390228 0 0 -13.030853 -2.34137916 )
     (-21.343616 14.219539 -13.030853 -2.34137916 5.15427208 -6.29310418 )
     (-31.797332 8.73160745 -7.8765812 -8.63448335 -1.58623886 -8.48620225 )
     (-40.467033 -4.14597798 -9.46282006 -17.120685 37.19068 16.237926 )
     (-31.33451 -13.147699 27.727863 -0.882758380 -27.176502 -8.46551896 )
     (-17.1949 -18.2632179 0.551357627 -9.34827806 5.5153446 11.624151 )
     (-13.8858719 -21.799419 6.06670285 2.27587318 -0.884872437 -32.031082 )
     (-8.2616043 -35.539085 5.1818304 -29.75521 4.02414227 56.500183 )
     (-1.06770372 -37.044204 9.20597268 26.744976 -3.21169567 -37.969665 )
     (6.5324211 -29.284065 5.994277 -11.224693 2.82264042 23.378486 )
     (13.9380188 -28.819515 8.8169174 12.153795 -8.07886506 -1.54428863 )
     (18.715499 -17.437862 0.738050580 10.6095066 5.4928274 -5.20133877 )
     (22.199966 -9.42902566 6.23087884 5.40816784 -1.89244747 10.349649 )
     (27.484622 1.15396976 4.33843136 15.757818 -9.92303849 -0.197273254 )
     (26.861534 16.813148 -5.58460713 15.5605449 5.58460713 -15.5605449 ))
    NATURAL)
   (2
    ((139 30) (139 -28))
    NIL
    ((0 -58. 0 0 0 0 ))
    NATURAL)
   (5
    ((139 -28) (138 -42) (135 -54) (128 -60) (119 -62))
    NIL
    ((-0.714285612 -14.1785698 0 0 -1.71428585 1.07142877 )
     (-1.57142853 -13.642856 -1.71428585 1.07142877 -3.42857075 6.64285565 )
     (-5. -9.2499981 -5.1428566 7.7142849 3.42857075 -3.6428566 )
     (-8.4285698 -3.35714245 -1.71428561 4.0714283 1.71428561 -4.0714283 ))
    NATURAL)
   (2
    ((119 -62) (119 -70))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((119 -70) (244 -70))
    NIL
    ((125. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((244 -70) (244 -62))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL))

  ((14
    ((137 120) (137 84) (133 49) (120 35) (109 38) (101 56)
     (97 87) (96 120) (98 156) (104 185) (118 195) (130 184)
     (136 154) (137 120))
    NIL
    ((0.397950232 -35.027526 0 0 -2.38770151 -5.83479405 )
     (-0.795900465 -37.94493 -2.38770151 -5.83479405 -12.061491 35.173965 )
     (-9.21434785 -26.192737 -14.4491939 29.339176 20.63367 -14.861099 )
     (-13.346704 -4.28410912 6.1844778 14.4780769 -4.47319508 0.270425796 )
     (-9.3988247 10.3291797 1.71128201 14.7485027 3.25911093 1.77940941 )
     (-6.0579872 25.967388 4.97039318 16.527912 -2.56325197 -19.388069 )
     (-2.36922026 32.801261 2.40714121 -2.86015797 0.993899346 9.77287675 )
     (0.534870506 34.827545 3.40104055 6.91271878 -1.41234493 -13.703434 )
     (3.22973871 34.888542 1.98869562 -6.7907152 10.655479 -14.9591388 )
     (10.546175 20.618259 12.644176 -21.749855 -17.209579 1.5399971 )
     (14.5855598 -0.361596405 -4.56540394 -20.209857 -1.81715488 -3.20084763 )
     (9.111578 -22.171875 -6.38255883 -23.410705 0.478199005 23.263381 )
     (2.96811962 -33.950889 -5.9043598 -0.147323548 5.9043598 0.147323548 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 162Q)
 (FACE M R R)
 (WIDTH 200 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 11:25:39)
 (MADE-FROM NIL 88 130 57 78)
 (SPLINES

  ((2
    ((112 205) (112 176))
    NIL
    ((0 -29. 0 0 0 0 ))
    NATURAL)
   (10
    ((112 176) (136 200) (161 210) (183 200) (188 180) (174 159)
     (147 157) (132 168) (117 158) (113 142))
    NIL
    ((23.768428 26.483066 0 0 1.38941908 -14.8984089 )
     (24.463138 19.033863 1.38941908 -14.8984089 -0.947096229 -9.50795175 )
     (25.379009 -0.618523598 0.442322791 -24.40636 -21.601032 16.930221 )
     (15.0208149 -16.559772 -21.15871 -7.47613717 3.35123825 1.78705024 )
     (-4.46227646 -23.142383 -17.807472 -5.6890869 -3.80392075 29.921569 )
     (-24.17171 -13.870685 -21.611393 24.232482 47.86444 -1.47332763 )
     (-21.850879 9.6251316 26.253051 22.759155 -37.653862 -60.028259 )
     (-14.4247627 2.37015486 -11.400814 -37.269104 30.751018 37.58638 )
     (-10.4500675 -16.105758 19.350204 0.317277312 -19.350204 -0.317277312 ))
    NATURAL)
   (2
    ((113 142) (113 42))
    NIL
    ((0 -100. 0 0 0 0 ))
    NATURAL)
   (5
    ((113 42) (114 31) (117 19) (124 12) (133 8))
    NIL
    ((0.714285612 -10.4285698 0 0 1.71428585 -3.42857122 )
     (1.57142853 -12.1428566 1.71428585 -3.42857122 3.42857075 11.1428547 )
     (5. -9.9999981 5.1428566 7.7142849 -3.42857075 -5.1428566 )
     (8.4285698 -4.85714245 1.71428561 2.5714283 -1.71428561 -2.5714283 ))
    NATURAL)
   (2
    ((133 8) (133 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((133 0) (12 0))
    NIL
    ((-121. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((12 0) (12 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((12 8) (22 10) (29 17) (31 31))
    NIL
    ((10.466665 1.13333320 0 0 -2.80000019 5.1999998 )
     (9.06666566 3.73333359 -2.80000019 5.1999998 -3.99999905 3.99999905 )
     (4.2666664 10.933332 -6.79999924 9.19999887 6.79999924 -9.19999887 ))
    NATURAL)
   (2
    ((31 31) (31 174))
    NIL
    ((0 143. 0 0 0 0 ))
    NATURAL)
   (4
    ((31 174) (29 188) (23 195) (12 197))
    NIL
    ((-1.26666665 15.5333328 0 0 -4.39999962 -9.19999887 )
     (-3.4666667 10.933332 -4.39999962 -9.19999887 -2. 3.99999905 )
     (-8.8666668 3.7333331 -6.3999996 -5.1999998 6.3999996 5.1999998 ))
    NATURAL)
   (2
    ((12 197) (12 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((12 205) (112 205))
    NIL
    ((100. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 163Q)
 (FACE M R R)
 (WIDTH 178 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 14:38:38)
 (MADE-FROM NIL 130 130 0 0)
 (SPLINES

  ((3
    ((135 148) (135 148) (150 148))
    NIL
    ((-3.75 0 0 0 22.5 0 )
     (7.5 0 22.5 0 -22.5 0 ))
    NATURAL)
   (2
    ((150 148) (150 206))
    NIL
    ((0 58. 0 0 0 0 ))
    NATURAL)
   (2
    ((150 206) (139 206))
    NIL
    ((-11. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((139 206) (133 198))
    NIL
    ((-6. -8. 0 0 0 0 ))
    NATURAL)
   (16
    ((133 198) (116 204) (91 208) (62 206) (39 196) (24 178)
     (15 151) (19 126) (34 101) (55 84) (76 66) (91 43)
     (82 22) (59 24) (45 37) (32 62))
    NIL
    ((-15.2221908 6.23116494 0 0 -10.666851 -1.38699484 )
     (-20.555614 5.53766823 -10.666851 -1.38699484 5.3342552 -5.06502533 )
     (-28.555339 1.61816025 -5.33259583 -6.45202065 13.329832 -2.35289955 )
     (-27.223018 -6.01031018 7.99723626 -8.8049202 1.34641075 2.47662639 )
     (-18.5525779 -13.576917 9.343647 -6.3282938 -6.71547127 -7.5536108 )
     (-12.5666656 -23.682014 2.62817573 -13.881904 13.51547 21.737819 )
     (-3.18075228 -26.69501 16.143646 7.855916 -5.3464241 -13.397676 )
     (10.289682 -25.537933 10.797222 -5.54176045 -4.12976265 19.852882 )
     (19.022022 -21.153247 6.66745949 14.3111248 -8.13452149 -18.013862 )
     (21.622219 -15.849058 -1.46706223 -3.70274019 0.667852164 -1.79742288 )
     (20.489082 -20.450508 -0.799210072 -5.50016308 -30.53688 1.20355701 )
     (4.42143154 -25.348892 -31.336093 -4.29660607 13.47969 38.983184 )
     (-20.174816 -10.1539 -17.856403 34.686584 36.618103 -31.13634 )
     (-19.72216 8.96451188 18.761703 3.55024195 -21.952129 13.5621948 )
     (-11.936523 19.295852 -3.19042635 17.112438 3.19042635 -17.112438 ))
    NATURAL)
   (2
    ((32 62) (19 62))
    NIL
    ((-13. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((19 62) (19 62) (19 -1))
    NIL
    ((0 15.75 0 0 0 -94.5 )
     (0 -31.5 0 -94.5 0 94.5 ))
    NATURAL)
   (2
    ((19 -1) (29 -1))
    NIL
    ((10. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((29 -1) (33 7))
    NIL
    ((4. 8. 0 0 0 0 ))
    NATURAL)
   (15
    ((33 7) (50 3) (76 -3) (106 -4) (138 7) (162 34)
     (166 68) (153 99) (127 124) (98 147) (85 166) (93 185)
     (114 184) (126 172) (135 148))
    NIL
    ((14.8183899 -3.26369524 0 0 13.089653 -4.4178276 )
     (21.363216 -5.47260952 13.089653 -4.4178276 -11.4482708 10.0891399 )
     (28.728733 -4.84586716 1.64138222 5.67131233 2.70343399 6.06126595 )
     (31.721836 3.8560791 4.3448162 11.732578 -11.365465 7.66579056 )
     (30.383918 19.42155 -7.02064896 19.398368 -17.241565 -12.72442 )
     (14.742483 32.45771 -24.262214 6.67394734 8.3317375 -10.768106 )
     (-5.35386276 33.747596 -15.930477 -4.09416008 1.91460991 -4.20314217 )
     (-20.327034 27.551868 -14.015867 -8.29730226 8.0098133 9.5806732 )
     (-30.337993 24.044906 -6.00605298 1.2833724 26.04613 -10.119556 )
     (-23.32098 20.268497 20.040081 -8.83618547 1.80563736 18.897556 )
     (-2.37807894 20.881092 21.845718 10.0613708 -3.26868057 -41.470665 )
     (17.833297 10.2071285 18.577037 -31.409294 -36.73091 26.985103 )
     (18.0448799 -7.7096119 -18.153877 -4.42418766 18.192344 -12.4697628 )
     (8.987175 -18.368682 0.0384698063 -16.893951 -0.0384698063 16.893951 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 164Q)
 (FACE M R R)
 (WIDTH 173 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 14:42:46)
 (MADE-FROM NIL 141 130 57 78)
 (SPLINES

  ((3
    ((121 205) (121 205) (155 205))
    NIL
    ((-8.5 0 0 0 51. 0 )
     (17. 0 51. 0 -51. 0 ))
    NATURAL)
   (2
    ((155 205) (155 181))
    NIL
    ((0 -24. 0 0 0 0 ))
    NATURAL)
   (3
    ((155 181) (121 181) (121 181))
    NIL
    ((-42.5 0 0 0 51. 0 )
     (-17. 0 51. 0 -51. 0 ))
    NATURAL)
   (2
    ((121 181) (121 51))
    NIL
    ((0 -130. 0 0 0 0 ))
    NATURAL)
   (5
    ((121 51) (122 36) (130 28) (145 30) (153 38))
    NIL
    ((-0.250000000 -16.267856 0 0 7.5 7.60714245 )
     (3.5 -12.4642849 7.5 7.60714245 4.4999981 3.96428585 )
     (13.25 -2.87499952 11.999998 11.571428 -25.499996 -5.46428585 )
     (12.499998 5.96428585 -13.499998 6.10714245 13.499998 -6.10714245 ))
    NATURAL)
   (2
    ((153 38) (162 25))
    NIL
    ((9. -13. 0 0 0 0 ))
    NATURAL)
   (7
    ((162 25) (147 10) (123 -2) (89 -5) (63 3) (44 24)
     (39 51))
    NIL
    ((-13.442306 -15.310255 0 0 -9.34615327 1.86153841 )
     (-18.115383 -14.379486 -9.34615327 1.86153841 -7.2692299 8.6923065 )
     (-31.096153 -8.17179299 -16.615383 10.553846 32.423072 -0.630771637 )
     (-31.499996 2.06666708 15.807689 9.9230747 -14.4230728 5.8307724 )
     (-22.903842 14.905126 1.38461566 15.753847 19.269226 -10.692308 )
     (-11.884613 25.31282 20.653842 5.06153775 -20.653842 -5.06153775 ))
    NATURAL)
   (2
    ((39 51) (39 181))
    NIL
    ((0 130. 0 0 0 0 ))
    NATURAL)
   (2
    ((39 181) (20 181))
    NIL
    ((-19. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((20 181) (20 196))
    NIL
    ((0 15. 0 0 0 0 ))
    NATURAL)
   (5
    ((20 196) (49 209) (71 227) (89 246) (106 272))
    NIL
    ((30.607139 11.607141 0 0 -9.6428566 8.3571415 )
     (25.785713 15.785713 -9.6428566 8.3571415 6.2142849 -11.785711 )
     (19.249996 18.25 -3.42857122 -3.42857075 2.78571415 14.785711 )
     (17.214283 22.214283 -0.642857075 11.357141 0.642857075 -11.357141 ))
    NATURAL)
   (2
    ((106 272) (121 272))
    NIL
    ((15. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((121 272) (121 205))
    NIL
    ((0 -67. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 165Q)
 (FACE M R R)
 (WIDTH 249 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 14:49:10)
 (MADE-FROM NIL 94 130 57 78)
 (SPLINES

  ((3
    ((124 205) (124 205) (222 205))
    NIL
    ((-24.5 0 0 0 147. 0 )
     (49. 0 147. 0 -147. 0 ))
    NATURAL)
   (2
    ((222 205) (222 35))
    NIL
    ((0 -170. 0 0 0 0 ))
    NATURAL)
   (5
    ((222 35) (222 27) (226 16) (232 11) (238 8))
    NIL
    ((-0.928571344 -6.80357075 0 0 5.5714283 -7.17857075 )
     (1.85714292 -10.3928566 5.5714283 -7.17857075 -3.85714245 17.892852 )
     (5.5 -8.6249981 1.71428561 10.7142849 -2.1428566 -10.3928547 )
     (6.1428566 -3.10714245 -0.428571403 0.321428537 0.428571403 -0.321428537 ))
    NATURAL)
   (2
    ((238 8) (238 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((238 0) (141 0))
    NIL
    ((-97. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((141 0) (141 22))
    NIL
    ((0 22. 0 0 0 0 ))
    NATURAL)
   (8
    ((141 22) (129 10) (110 -3) (84 -8) (60 -3) (46 7)
     (35 25) (30 47))
    NIL
    ((-10.615938 -11.333904 0 0 -8.30436326 -3.99656487 )
     (-14.7681198 -13.3321876 -8.30436326 -3.99656487 -0.478183746 13.982824 )
     (-23.311576 -10.337339 -8.782547 9.98625947 10.2171039 2.06526756 )
     (-26.985569 0.681553364 1.43455767 12.051527 13.609756 -10.2439 )
     (-18.746131 7.61112977 15.044315 1.80762577 -16.656131 8.91033937 )
     (-12.029886 13.873926 -1.61181712 10.717966 11.0147686 -7.3974571 )
     (-8.1343174 20.893161 9.4029522 3.32050848 -9.4029522 -3.32050848 ))
    NATURAL)
   (2
    ((30 47) (30 167))
    NIL
    ((0 120. 0 0 0 0 ))
    NATURAL)
   (5
    ((30 167) (28 180) (25 189) (20 194) (13 197))
    NIL
    ((-1.83928561 13.821428 0 0 -0.964285732 -4.92857075 )
     (-2.3214283 11.357141 -0.964285732 -4.92857075 -1.17857122 0.642856598 )
     (-3.875 6.74999905 -2.14285707 -4.28571415 -0.321428299 2.35714245 )
     (-6.17857075 3.64285708 -2.46428537 -1.92857146 2.46428537 1.92857146 ))
    NATURAL)
   (2
    ((13 197) (13 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((13 205) (109 205))
    NIL
    ((96. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((109 205) (109 47))
    NIL
    ((0 -158. 0 0 0 0 ))
    NATURAL)
   (7
    ((109 47) (110 38) (116 30) (126 29) (135 37) (140 51)
     (141 67))
    NIL
    ((-0.0487179756 -8.91025544 0 0 6.29230786 -0.538461209 )
     (3.09743595 -9.1794853 6.29230786 -0.538461209 -1.46153927 8.6923046 )
     (8.6589737 -5.37179375 4.83076859 8.15384484 -6.44615269 1.76923179 )
     (10.266666 3.6666665 -1.61538458 9.9230766 -2.75384569 -3.76923084 )
     (7.27435876 11.7051277 -4.36923027 6.15384579 -0.538461685 -4.69230747 )
     (2.63589716 15.512819 -4.90769196 1.46153831 4.90769196 -1.46153831 ))
    NATURAL)
   (2
    ((141 67) (141 167))
    NIL
    ((0 100. 0 0 0 0 ))
    NATURAL)
   (5
    ((141 167) (139 180) (136 189) (131 194) (124 197))
    NIL
    ((-1.83928561 13.821428 0 0 -0.964285732 -4.92857075 )
     (-2.3214283 11.357141 -0.964285732 -4.92857075 -1.17857122 0.642856598 )
     (-3.875 6.74999905 -2.14285707 -4.28571415 -0.321428299 2.35714245 )
     (-6.17857075 3.64285708 -2.46428537 -1.92857146 2.46428537 1.92857146 ))
    NATURAL)
   (2
    ((124 197) (124 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 166Q)
 (FACE M R R)
 (WIDTH 215 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 14:54:35)
 (MADE-FROM NIL 88 130 57 78)
 (SPLINES

  ((2
    ((138 205) (138 197))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (4
    ((138 197) (147 192) (154 182) (157 168))
    NIL
    ((9.2666664 -3.9333334 0 0 -1.60000014 -6.3999996 )
     (8.46666528 -7.1333332 -1.60000014 -6.3999996 -3.99999905 2. )
     (4.86666584 -12.5333328 -5.59999943 -4.39999962 5.59999943 4.39999962 ))
    NATURAL)
   (3
    ((157 168) (154 154) (139 96))
    NIL
    ((0 -3. 0 0 -18. -66. )
     (-9. -36. -18. -66. 18. 66. ))
    NATURAL)
   (5
    ((139 96) (118 163) (112 182) (115 192) (121 197))
    NIL
    ((-24.428569 79.303558 0 0 20.571426 -73.821426 )
     (-14.1428547 42.392852 20.571426 -73.821426 -12.857141 81.10713 )
     (3.18512320E-7 9.125 7.7142849 7.2857132 -5.1428566 -16.607139 )
     (5.1428566 8.1071415 2.5714283 -9.3214264 -2.5714283 9.3214264 ))
    NATURAL)
   (2
    ((121 197) (121 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((121 205) (11 205))
    NIL
    ((-110. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((11 205) (11 205) (11 197))
    NIL
    ((0 2. 0 0 0 -12. )
     (0 -4. 0 -12. 0 12. ))
    NATURAL)
   (4
    ((11 197) (19 192) (26 182) (32 167))
    NIL
    ((8.19999887 -4. 0 0 -1.20000004 -6. )
     (7.59999943 -7. -1.20000004 -6. 2.38418579E-7 0 )
     (6.3999996 -13. -1.19999981 -6. 1.19999981 6. ))
    NATURAL)
   (3
    ((32 167) (32 167) (93 0))
    NIL
    ((-15.25 41.75 0 0 91.5 -250.5 )
     (30.5 -83.5 91.5 -250.5 -91.5 250.5 ))
    NATURAL)
   (2
    ((93 0) (138 0))
    NIL
    ((45. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((138 0) (181 155))
    NIL
    ((43. 155. 0 0 0 0 ))
    NATURAL)
   (4
    ((181 155) (187 176) (195 189) (202 197))
    NIL
    ((5.3999996 22.799999 0 0 3.5999999 -10.799999 )
     (7.1999998 17.399997 3.5999999 -10.799999 -5.99999905 6. )
     (7.79999924 9.59999848 -2.39999962 -4.79999924 2.39999962 4.79999924 ))
    NATURAL)
   (2
    ((202 197) (202 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((202 205) (138 205))
    NIL
    ((-64. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 167Q)
 (FACE M R R)
 (WIDTH 335 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 15:00:50)
 (MADE-FROM NIL 88 130 57 78)
 (SPLINES

  ((2
    ((93 0) (137 0))
    NIL
    ((44. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((137 0) (170 113))
    NIL
    ((33. 113. 0 0 0 0 ))
    NATURAL)
   (2
    ((170 113) (213 2))
    NIL
    ((43. -111. 0 0 0 0 ))
    NATURAL)
   (2
    ((213 2) (255 2))
    NIL
    ((42. 0 0 0 0 0 ))
    NATURAL)
   (6
    ((255 2) (296 153) (299 167) (304 181) (310 190) (321 197))
    NIL
    ((51.330139 187.7942 0 0 -61.980857 -220.7655 )
     (20.33971 77.411468 -61.980857 -220.7655 81.904296 281.8276 )
     (-0.688994527 -2.44018984 19.923442 61.062194 -25.63636 -84.54544 )
     (6.4162674 16.349277 -5.71291828 -23.483249 14.641145 26.35406 )
     (8.02392388 6.0430622 8.92822839 2.87081289 -8.92822839 -2.87081289 ))
    NATURAL)
   (2
    ((321 197) (321 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((321 205) (249 205))
    NIL
    ((-72. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((249 205) (249 197))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (5
    ((249 197) (258 195) (266 187) (268 174) (267 166))
    NIL
    ((8.8928566 -0.839285613 0 0 0.642857075 -6.96428586 )
     (9.2142849 -4.3214283 0.642857075 -6.96428586 -9.2142849 -1.17857074 )
     (5.24999905 -11.875 -8.5714283 -8.1428566 6.21428586 17.678569 )
     (-0.214285850 -11.1785698 -2.35714245 9.5357132 2.35714245 -9.5357132 ))
    NATURAL)
   (2
    ((267 166) (252 109))
    NIL
    ((-15. -57. 0 0 0 0 ))
    NATURAL)
   (2
    ((252 109) (230 176))
    NIL
    ((-22. 67. 0 0 0 0 ))
    NATURAL)
   (4
    ((230 176) (228 186) (231 196) (238 197))
    NIL
    ((-3.0666666 9.3999996 0 0 6.3999996 3.5999999 )
     (0.133333504 11.1999988 6.3999996 3.5999999 -2. -17.999996 )
     (5.53333283 5.79999924 4.39999962 -14.399999 -4.39999962 14.399999 ))
    NATURAL)
   (2
    ((238 197) (238 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((238 205) (132 205))
    NIL
    ((-106. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((132 205) (132 197))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (4
    ((132 197) (140 194) (144 182) (153 150))
    NIL
    ((9.3999996 -1.93333316 0 0 -8.3999996 -6.40000058 )
     (5.1999998 -5.1333332 -8.3999996 -6.40000058 17.999996 -21.999996 )
     (5.80000019 -22.533332 9.59999848 -28.399997 -9.59999848 28.399997 ))
    NATURAL)
   (2
    ((153 150) (139 96))
    NIL
    ((-14. -54. 0 0 0 0 ))
    NATURAL)
   (5
    ((139 96) (118 163) (112 182) (115 192) (121 197))
    NIL
    ((-24.428569 79.303558 0 0 20.571426 -73.821426 )
     (-14.1428547 42.392852 20.571426 -73.821426 -12.857141 81.10713 )
     (3.18512320E-7 9.125 7.7142849 7.2857132 -5.1428566 -16.607139 )
     (5.1428566 8.1071415 2.5714283 -9.3214264 -2.5714283 9.3214264 ))
    NATURAL)
   (2
    ((121 197) (121 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((121 205) (11 205))
    NIL
    ((-110. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((11 205) (11 205) (11 197))
    NIL
    ((0 2. 0 0 0 -12. )
     (0 -4. 0 -12. 0 12. ))
    NATURAL)
   (4
    ((11 197) (19 192) (26 182) (32 167))
    NIL
    ((8.19999887 -4. 0 0 -1.20000004 -6. )
     (7.59999943 -7. -1.20000004 -6. 2.38418579E-7 0 )
     (6.3999996 -13. -1.19999981 -6. 1.19999981 6. ))
    NATURAL)
   (3
    ((32 167) (32 167) (93 0))
    NIL
    ((-15.25 41.75 0 0 91.5 -250.5 )
     (30.5 -83.5 91.5 -250.5 -91.5 250.5 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 170Q)
 (FACE M R R)
 (WIDTH 257 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 15:07:03)
 (MADE-FROM NIL 88 130 57 78)
 (SPLINES

  ((6
    ((11 197) (23 187) (35 170) (51 147) (71 119) (90 90))
    NIL
    ((12.2057399 -8.46411325 0 0 -1.23444962 -9.21531106 )
     (11.588516 -13.0717697 -1.23444962 -9.21531106 6.17224789 4.07655525 )
     (13.440191 -20.248802 4.9377985 -5.1387558 0.545454979 -1.09090805 )
     (18.650714 -25.933013 5.48325348 -6.22966386 -8.35406686 6.2870798 )
     (19.956935 -29.019138 -2.87081337 0.0574161485 2.87081337 -0.0574161485 ))
    NATURAL)
   (3
    ((90 90) (90 90) (48 31))
    NIL
    ((10.5 14.75 0 0 -63. -88.5 )
     (-21. -29.5 -63. -88.5 63. 88.5 ))
    NATURAL)
   (4
    ((48 31) (39 23) (29 14) (16 8))
    NIL
    ((-8.93333245 -7.5333328 0 0 -0.400000095 -2.79999971 )
     (-9.1333332 -8.93333245 -0.400000095 -2.79999971 -3.99999952 7.99999905 )
     (-11.5333328 -7.73333264 -4.39999962 5.1999998 4.39999962 -5.1999998 ))
    NATURAL)
   (2
    ((16 8) (16 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((16 0) (98 0))
    NIL
    ((82. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((98 0) (98 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (5
    ((98 8) (90 15) (87 25) (93 43) (106 67))
    NIL
    ((-8.8214283 6.66071416 0 0 4.9285717 2.03571463 )
     (-6.35714245 7.67857075 4.9285717 2.03571463 5.3571415 7.8214264 )
     (1.25000047 13.625 10.285713 9.8571415 -2.35714245 -3.3214283 )
     (10.357141 21.821426 7.92857075 6.5357132 -7.92857075 -6.5357132 ))
    NATURAL)
   (2
    ((106 67) (128 37))
    NIL
    ((22. -30. 0 0 0 0 ))
    NATURAL)
   (4
    ((128 37) (136 26) (133 14) (121 8))
    NIL
    ((10.333332 -10.333332 0 0 -14. -4. )
     (3.33333302 -12.333332 -14. -4. 4. 14. )
     (-8.66666604 -9.33333207 -10. 10. 10. -10. ))
    NATURAL)
   (2
    ((121 8) (121 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((121 0) (244 0))
    NIL
    ((123. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((244 0) (244 8))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (4
    ((244 8) (230 23) (209 50) (159 122))
    NIL
    ((-14.066665 14.799999 0 0 0.399999619 1.20000076 )
     (-13.8666668 15.399999 0.399999619 1.20000076 -43.999992 65.999984 )
     (-35.466667 49.599998 -43.599998 67.199997 43.599998 -67.199997 ))
    NATURAL)
   (5
    ((159 122) (184 156) (201 178) (214 190) (229 197))
    NIL
    ((26.821426 36.589279 0 0 -10.9285698 -15.535713 )
     (21.357139 28.821426 -10.9285698 -15.535713 6.64285565 5.6785717 )
     (13.75 16.124996 -4.28571415 -9.8571415 8.3571415 4.82142735 )
     (13.642856 8.6785698 4.0714283 -5.03571415 -4.0714283 5.03571415 ))
    NATURAL)
   (2
    ((229 197) (229 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((229 205) (145 205))
    NIL
    ((-84. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((145 205) (145 197))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (4
    ((145 197) (155 194) (163 184) (160 172))
    NIL
    ((9.79999925 -1.26666665 0 0 1.19999981 -10.3999996 )
     (10.3999996 -6.46666623 1.19999981 -10.3999996 -17.999996 9.9999981 )
     (2.59999943 -11.8666649 -16.799999 -0.399999976 16.799999 0.399999976 ))
    NATURAL)
   (3
    ((160 172) (144 144) (144 144))
    NIL
    ((-20. -35. 0 0 24. 42. )
     (-8. -14. 24. 42. -24. -42. ))
    NATURAL)
   (5
    ((144 144) (126 170) (118 182) (119 192) (127 197))
    NIL
    ((-20.160713 29.696426 0 0 12.9642849 -22.178569 )
     (-13.6785698 18.607139 12.9642849 -22.178569 -4.8214283 26.892852 )
     (-3.12499952 9.875 8.1428566 4.7142849 0.321428299 -13.3928547 )
     (5.1785717 7.8928566 8.4642849 -8.6785698 -8.4642849 8.6785698 ))
    NATURAL)
   (2
    ((127 197) (127 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL)
   (2
    ((127 205) (11 205))
    NIL
    ((-116. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((11 205) (11 205) (11 197))
    NIL
    ((0 2. 0 0 0 -12. )
     (0 -4. 0 -12. 0 12. ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 171Q)
 (FACE M R R)
 (WIDTH 242 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 15:27:56)
 (MADE-FROM NIL 106 130 52 37)
 (SPLINES

  ((2
    ((10 205) (130 205))
    NIL
    ((120. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((130 205) (130 197))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (5
    ((130 197) (123 192) (120 180) (130 153) (148 97))
    NIL
    ((-7.28571416 -3.67857122 0 0 1.71428585 -7.92857075 )
     (-6.42857075 -7.6428566 1.71428585 -7.92857075 15.4285698 -2.35714435 )
     (3. -16.75 17.142856 -10.285715 -9.4285698 -30.642849 )
     (15.4285698 -42.357139 7.71428586 -40.928566 -7.71428586 40.928566 ))
    NATURAL)
   (2
    ((148 97) (168 159))
    NIL
    ((20. 62. 0 0 0 0 ))
    NATURAL)
   (5
    ((168 159) (169 171) (166 183) (159 192) (147 197))
    NIL
    ((1.875 11.857141 0 0 -5.25 0.857142807 )
     (-0.750000001 12.285713 -5.25 0.857142807 2.25 -4.2857132 )
     (-4.875 10.999998 -3. -3.42857122 -3.74999905 -1.71428537 )
     (-9.75 6.7142849 -6.74999905 -5.1428566 6.74999905 5.1428566 ))
    NATURAL)
   (3
    ((147 197) (147 205) (147 205))
    NIL
    ((0 10. 0 0 0 -12. )
     (0 4. 0 -12. 0 12. ))
    NATURAL)
   (2
    ((147 205) (230 205))
    NIL
    ((83. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((230 205) (230 197))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (6
    ((230 197) (216 187) (203 163) (182 108) (155 34) (129 -33))
    NIL
    ((-14.722486 -8.07655335 0 0 4.33492756 -11.54067 )
     (-12.555023 -13.846889 4.33492756 -11.54067 -15.674638 -26.296646 )
     (-16.057415 -38.53588 -11.339712 -37.837318 4.36363602 14.727272 )
     (-25.215309 -69.009567 -6.97607613 -23.110046 10.2200946 39.387558 )
     (-27.081337 -72.425827 3.24401903 16.277511 -3.24401903 -16.277511 ))
    NATURAL)
   (18
    ((129 -33) (106 -65) (71 -78) (36 -70) (18 -52) (19 -28)
     (35 -12) (60 -11) (77 -29) (74 -50) (84 -54) (97 -42)
     (105 -12) (98 18) (71 88) (44 151) (27 185) (10 197))
    NIL
    ((-20.030921 -35.737548 0 0 -17.814453 22.425304 )
     (-28.938152 -24.524894 -17.814453 22.425304 17.072273 1.87346649 )
     (-38.216468 -1.16285705 -0.742179275 24.29877 21.525348 -17.919166 )
     (-28.195968 14.176328 20.783172 6.37960148 -1.17368698 3.80321789 )
     (-7.99964047 22.457538 19.609485 10.182819 -4.83061028 -21.293701 )
     (9.19454 21.993507 14.778875 -11.1108818 -3.5038681 -2.62841225 )
     (22.221481 9.5684204 11.275007 -13.739294 -17.153915 -10.192644 )
     (24.919528 -9.26719476 -5.87891007 -23.931938 -29.88045 19.39899 )
     (4.1003933 -23.499637 -35.75936 -4.53294659 64.67572 28.596672 )
     (0.678891659 -13.734245 28.916358 24.063728 -30.822425 -13.785705 )
     (14.184036 3.43663216 -1.90606785 10.2780227 -1.38602018 20.546138 )
     (11.584959 23.987724 -3.29208803 30.824161 -11.6334896 -56.398834 )
     (2.47612381 26.612464 -14.925579 -25.574676 -12.0800056 97.049225 )
     (-18.489456 49.5624 -27.005584 71.474548 29.953506 -91.79808 )
     (-30.518287 75.137909 2.94792461 -20.323539 12.2659607 -11.8568496 )
     (-21.437381 48.88594 15.213886 -32.180389 -19.017356 7.22549058 )
     (-15.7321758 20.318298 -3.80347204 -24.954898 3.80347204 24.954898 ))
    NATURAL)
   (2
    ((10 197) (10 205))
    NIL
    ((0 8. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 172Q)
 (FACE M R R)
 (WIDTH 216 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 15:28:40)
 (MADE-FROM NIL 106 130 70 46)
 (SPLINES

  ((3
    ((34 205) (34 205) (204 205))
    NIL
    ((-42.5 0 0 0 255. 0 )
     (85. 0 255. 0 -255. 0 ))
    NATURAL)
   (2
    ((204 205) (204 195))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (2
    ((204 195) (114 17))
    NIL
    ((-90. -178. 0 0 0 0 ))
    NATURAL)
   (5
    ((114 17) (138 19) (161 30) (173 45) (180 60))
    NIL
    ((23.571426 -0.125000000 0 0 2.5714283 12.75 )
     (24.857139 6.25 2.5714283 12.75 -18.857139 -9.75 )
     (17.999996 14.125 -16.285713 2.99999952 12.857141 -3.74999905 )
     (8.1428566 15.249998 -3.42857122 -0.749999881 3.42857122 0.749999881 ))
    NATURAL)
   (2
    ((180 60) (198 60))
    NIL
    ((18. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((198 60) (191 0))
    NIL
    ((-7. -60. 0 0 0 0 ))
    NATURAL)
   (2
    ((191 0) (9 0))
    NIL
    ((-182. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((9 0) (107 189) (107 189))
    NIL
    ((122.5 236.25 0 0 -147. -283.5 )
     (49. 94.5 -147. -283.5 147. 283.5 ))
    NATURAL)
   (5
    ((107 189) (88 188) (72 183) (59 171) (50 154))
    NIL
    ((-19.660713 -0.339285672 0 0 3.96428537 -3.96428585 )
     (-17.678569 -2.3214283 3.96428537 -3.96428585 -1.8214283 -4.17857075 )
     (-14.624998 -8.375 2.14285707 -8.1428566 3.32142782 2.6785717 )
     (-10.821428 -15.178571 5.4642849 -5.4642849 -5.4642849 5.4642849 ))
    NATURAL)
   (2
    ((50 154) (30 154))
    NIL
    ((-20. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((30 154) (34 205) (34 205))
    NIL
    ((5. 63.75 0 0 -6. -76.5 )
     (2. 25.5 -6. -76.5 6. 76.5 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.NUM-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.NUM-SF
deleted file mode 100644
index c1ab00ca..00000000
--- a/obsolete/lispusers/splinefonts/TIMESROMAN.NUM-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY TIMESROMAND)
 (CHARACTER 61Q)
 (FACE M R R)
 (WIDTH 248 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:40:26)
 (MADE-FROM NIL 118 130 43 65)
 (SPLINES

  ((2
    ((49 0) (212 0))
    NIL
    ((163. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((212 0) (212 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((212 10) (198 11) (185 15) (175 27) (173 52))
    NIL
    ((-14.196428 0.535714269 0 0 1.17857146 2.78571415 )
     (-13.607141 1.92857146 1.17857146 2.78571415 0.107142686 4.0714283 )
     (-12.375 6.75 1.28571415 6.85714245 10.3928566 10.9285698 )
     (-5.8928566 19.071426 11.6785717 17.785713 -11.6785717 -17.785713 ))
    NATURAL)
   (2
    ((173 52) (173 294))
    NIL
    ((0 242. 0 0 0 0 ))
    NATURAL)
   (2
    ((173 294) (153 294))
    NIL
    ((-20. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((153 294) (39 255))
    NIL
    ((-114. -39. 0 0 0 0 ))
    NATURAL)
   (2
    ((39 255) (39 245))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (6
    ((39 245) (51 248) (65 250) (79 245) (84 233) (84 212))
    NIL
    ((11.61244 2.85645914 0 0 2.32535887 0.861243725 )
     (12.7751178 3.28708124 2.32535887 0.861243725 0.373205185 -10.306217 )
     (15.2870807 -1.00478506 2.69856405 -9.4449749 -15.818178 4.36363602 )
     (10.076553 -8.26794244 -13.119615 -5.08133888 8.89951898 -7.14832497 )
     (1.40669846 -16.9234428 -4.22009564 -12.2296638 4.22009564 12.2296638 ))
    NATURAL)
   (2
    ((84 212) (84 52))
    NIL
    ((0 -160. 0 0 0 0 ))
    NATURAL)
   (5
    ((84 52) (82 27) (72 15) (59 11) (49 10))
    NIL
    ((-0.125000000 -27.964283 0 0 -11.25 17.785713 )
     (-5.75 -19.071426 -11.25 17.785713 8.25 -10.9285698 )
     (-12.875 -6.74999905 -2.99999952 6.85714245 8.2499981 -4.0714283 )
     (-11.749998 -1.92857122 5.24999905 2.78571415 -5.24999905 -2.78571415 ))
    NATURAL)
   (2
    ((49 10) (49 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 62Q)
 (FACE M R R)
 (WIDTH 248 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:41:31)
 (MADE-FROM NIL 137 130 43 65)
 (SPLINES

  ((3
    ((18 0) (18 0) (208 0))
    NIL
    ((-47.5 0 0 0 285. 0 )
     (95. 0 285. 0 -285. 0 ))
    NATURAL)
   (2
    ((208 0) (235 85))
    NIL
    ((27. 85. 0 0 0 0 ))
    NATURAL)
   (2
    ((235 85) (223 88))
    NIL
    ((-12. 3. 0 0 0 0 ))
    NATURAL)
   (4
    ((223 88) (217 79) (207 74) (191 72))
    NIL
    ((-5.333333 -9.8666649 0 0 -4. 5.1999998 )
     (-7.333333 -7.2666664 -4. 5.1999998 -4. -2. )
     (-13.333332 -3.0666666 -8. 3.1999998 8. -3.1999998 ))
    NATURAL)
   (2
    ((191 72) (99 72))
    NIL
    ((-92. 0 0 0 0 0 ))
    NATURAL)
   (13
    ((99 72) (133 104) (159 131) (187 161) (207 195) (212 236)
     (195 269) (167 288) (134 296) (95 293) (64 278) (41 254)
     (26 224))
    NIL
    ((36.390373 33.521003 0 0 -14.3422489 -9.1260376 )
     (29.219245 28.957984 -14.3422489 -9.1260376 23.71125 15.630188 )
     (26.732624 27.64704 9.3690014 6.5041504 -20.502761 -5.39471627 )
     (25.850242 31.453834 -11.13376 1.10943412 -1.70019531 11.948675 )
     (13.866386 38.537605 -12.8339557 13.058109 -14.696451 -24.399986 )
     (-6.3157959 39.39572 -27.530406 -11.3418769 18.485996 -4.34872246 )
     (-24.603202 25.879486 -9.0444107 -15.690599 6.75246525 5.7948761 )
     (-30.27138 13.0863247 -2.29194546 -9.89572335 -9.49585725 -0.830780030 )
     (-37.311256 2.77521038 -11.7878036 -10.726503 25.230964 -2.47175407 )
     (-36.483573 -9.18717 13.443161 -13.198257 -7.4280052 4.71779442 )
     (-26.754417 -20.026531 6.0151558 -8.48046304 4.4810543 1.60057926 )
     (-18.498733 -27.706703 10.49621 -6.87988377 -10.49621 6.87988377 ))
    NATURAL)
   (2
    ((26 224) (36 219))
    NIL
    ((10. -5. 0 0 0 0 ))
    NATURAL)
   (11
    ((36 219) (51 235) (73 245) (104 242) (124 216) (125 178)
     (114 142) (94 105) (70 68) (43 35) (18 10))
    NIL
    ((13.8977489 17.051868 0 0 6.61349774 -6.3112297 )
     (17.204498 13.896255 6.61349774 -6.3112297 8.93251039 -4.44385147 )
     (28.284252 5.36310005 15.546009 -10.755081 -30.343544 -17.91336 )
     (28.658485 -14.348661 -14.7975349 -28.668441 -7.5583267 16.0972938 )
     (10.081787 -34.968452 -22.355861 -12.5711479 12.5768566 19.524185 )
     (-5.98564625 -37.777504 -9.77900506 6.95303727 -0.749107361 -10.194042 )
     (-16.139202 -35.921493 -10.528112 -3.24100542 8.4195709 3.25198889 )
     (-22.45753 -37.536499 -2.10854101 0.0109835881 -2.92918157 3.18608713 )
     (-26.030662 -35.932472 -5.03772259 3.19707108 9.29715158 8.0036602 )
     (-26.419807 -28.733573 4.25942993 11.200731 -4.25942993 -11.200731 ))
    NATURAL)
   (2
    ((18 10) (18 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 63Q)
 (FACE M R R)
 (WIDTH 248 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:42:55)
 (MADE-FROM NIL 136 130 43 65)
 (SPLINES

  ((11
    ((31 236) (47 258) (70 280) (99 294) (137 299) (174 293)
     (200 275) (212 244) (204 214) (181 192) (151 178))
    NIL
    ((14.3884849 21.553886 0 0 9.66908837 2.67667627 )
     (19.22303 22.892223 9.66908837 2.67667627 -6.34544755 -13.3833809 )
     (25.719394 18.877208 3.32364082 -10.706705 9.7127056 2.85685539 )
     (33.899383 9.59893037 13.036346 -7.8498497 -14.5053768 -4.04404068 )
     (39.683044 -0.272939324 -1.46903157 -11.89389 -11.6911888 1.31930732 )
     (32.368415 -11.507177 -13.160221 -10.574583 1.27013778 -7.2331829 )
     (19.843265 -25.698352 -11.890083 -17.8077659 -11.389358 21.613414 )
     (2.25850487 -32.699409 -23.279441 3.80565167 8.2872944 4.77950764 )
     (-16.8772888 -26.504001 -14.992147 8.5851593 8.24018479 1.26855087 )
     (-27.749343 -17.284568 -6.75196267 9.85371018 6.75196267 -9.85371018 ))
    NATURAL)
   (22
    ((151 178) (181 171) (209 154) (229 119) (228 72) (208 38)
     (174 12) (127 -2) (78 -4) (40 4) (18 19) (18 44)
     (44 54) (77 43) (105 24) (136 20) (154 41) (157 76)
     (145 105) (126 126) (100 141) (75 149))
    NIL
    ((30.282508 -5.32254124 0 0 -1.69506907 -10.0647506 )
     (29.434974 -10.3549156 -1.69506907 -10.0647506 -3.52465439 -9.67624665 )
     (25.977577 -25.257789 -5.2197237 -19.740997 -20.206306 0.769748688 )
     (10.654701 -44.613914 -25.426033 -18.971248 6.34989167 42.597244 )
     (-11.5963859 -42.286537 -19.076141 23.625999 6.80674554 -21.158752 )
     (-27.269153 -29.239913 -12.2693958 2.4672451 -3.57687187 12.037767 )
     (-41.326988 -20.753784 -15.846267 14.505012 13.50074 -2.99231338 )
     (-50.42288 -7.74493027 -2.34552717 11.512699 15.573904 -0.0685119629 )
     (-44.981452 3.7335124 13.228378 11.444187 2.20362282 -8.73363687 )
     (-30.651268 10.8108806 15.432001 2.71054888 5.61161614 17.003063 )
     (-12.4134578 22.02296 21.043617 19.713615 11.349899 -41.278625 )
     (14.3051128 21.097263 32.393516 -21.56501 -27.011226 -1.88856125 )
     (33.193016 -1.41202593 5.38228989 -23.453571 -17.304973 12.83287 )
     (29.922817 -18.449161 -11.9226837 -10.6207008 24.231128 28.557079 )
     (30.115699 -14.7913208 12.3084449 17.936378 -31.619537 10.938793 )
     (26.614376 8.61445428 -19.311092 28.875171 6.2470169 -12.3122406 )
     (10.42679 31.333507 -13.064075 16.562931 -5.368515 -27.689838 )
     (-5.3215437 34.051513 -18.43259 -11.126909 15.227033 3.07161903 )
     (-16.140617 24.460414 -3.20555592 -8.0552902 -7.53962804 3.40336895 )
     (-23.115985 18.106807 -10.7451839 -4.65192127 14.931478 -4.6850977 )
     (-26.395431 11.112339 4.1862955 -9.33701898 -4.1862955 9.33701898 ))
    NATURAL)
   (2
    ((75 149) (75 158))
    NIL
    ((0 9. 0 0 0 0 ))
    NATURAL)
   (9
    ((75 158) (106 169) (126 188) (132 214) (125 241) (107 256)
     (79 257) (56 244) (41 229))
    NIL
    ((33.150589 9.29224969 0 0 -12.9035339 10.2465019 )
     (26.698818 14.4155 -12.9035339 10.2465019 -1.48232650 -3.23251152 )
     (13.0541229 23.045745 -14.38586 7.0139904 0.832839966 -3.31645727 )
     (-0.915316582 28.401508 -13.55302 3.69753313 4.15096092 -19.501655 )
     (-12.392856 22.348213 -9.40205956 -15.8041229 -5.4366741 3.32308579 )
     (-24.513252 8.20563127 -14.838733 -12.481037 23.595726 -5.79068375 )
     (-27.554122 -7.17074776 8.75699426 -18.27172 1.05375671 19.839649 )
     (-18.270248 -15.522642 9.81075097 1.56793022 -9.81075097 -1.56793022 ))
    NATURAL)
   (2
    ((41 229) (31 236))
    NIL
    ((-10. 7. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 64Q)
 (FACE M R R)
 (WIDTH 248 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:43:50)
 (MADE-FROM NIL 106 130 43 65)
 (SPLINES

  ((3
    ((117 0) (117 0) (210 0))
    NIL
    ((-23.25 0 0 0 139.5 0 )
     (46.5 0 139.5 0 -139.5 0 ))
    NATURAL)
   (2
    ((210 0) (210 57))
    NIL
    ((0 57. 0 0 0 0 ))
    NATURAL)
   (2
    ((210 57) (232 57))
    NIL
    ((22. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((232 57) (232 105))
    NIL
    ((0 48. 0 0 0 0 ))
    NATURAL)
   (2
    ((232 105) (210 105))
    NIL
    ((-22. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((210 105) (210 294))
    NIL
    ((0 189. 0 0 0 0 ))
    NATURAL)
   (2
    ((210 294) (166 294))
    NIL
    ((-44. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((166 294) (13 98))
    NIL
    ((-153. -196. 0 0 0 0 ))
    NATURAL)
   (2
    ((13 98) (13 57))
    NIL
    ((0 -41. 0 0 0 0 ))
    NATURAL)
   (2
    ((13 57) (117 57))
    NIL
    ((104. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((117 57) (117 0))
    NIL
    ((0 -57. 0 0 0 0 ))
    NATURAL))

  ((2
    ((117 105) (57 105))
    NIL
    ((-60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((57 105) (117 182))
    NIL
    ((60. 77. 0 0 0 0 ))
    NATURAL)
   (2
    ((117 182) (117 105))
    NIL
    ((0 -77. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 65Q)
 (FACE M R R)
 (WIDTH 248 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:44:39)
 (MADE-FROM NIL 140 130 43 65)
 (SPLINES

  ((2
    ((229 294) (81 294))
    NIL
    ((-148. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((81 294) (27 138))
    NIL
    ((-54. -156. 0 0 0 0 ))
    NATURAL)
   (22
    ((27 138) (57 136) (92 131) (134 114) (159 75) (149 35)
     (115 22) (83 37) (55 51) (25 47) (15 23) (40 1)
     (88 -4) (144 5) (188 29) (218 63) (228 107) (214 149)
     (190 176) (158 193) (119 203) (78 207))
    NIL
    ((29.342811 -1.66680526 0 0 3.9431281 -1.99916839 )
     (31.314373 -2.66638946 3.9431281 -1.99916839 10.2843589 -8.004158 )
     (40.39968 -8.66763688 14.227487 -10.003326 -33.080566 -19.984199 )
     (38.086883 -28.663059 -18.85308 -29.987525 -21.962081 27.940948 )
     (8.25275994 -44.680107 -40.815162 -2.04657411 12.9289207 34.22039 )
     (-26.097942 -29.616481 -27.886241 32.17382 36.24639 3.1774292 )
     (-35.860984 4.14605809 8.3601551 35.351249 -1.91453647 -40.930099 )
     (-28.458099 19.032257 6.44561864 -5.57885075 -16.588245 -13.457002 )
     (-30.306606 6.724905 -10.1426296 -19.035854 32.267524 -7.24187089 )
     (-24.315467 -15.931886 22.1249 -26.277725 19.518119 30.424495 )
     (7.5684929 -26.99736 41.64302 4.14677334 -20.340023 17.543861 )
     (39.041503 -14.078657 21.302997 21.690635 -10.158018 -10.599956 )
     (55.265487 2.31199884 11.144979 11.090679 -29.027896 6.85596848 )
     (51.896514 16.830661 -17.882919 17.946647 6.2696266 -10.823919 )
     (37.148414 29.365348 -11.6132927 7.1227274 -8.0506096 6.43971539 )
     (21.509811 39.70793 -19.663902 13.5624428 -10.0671806 -14.934944 )
     (-3.18767786 45.8029 -29.731082 -1.37250161 24.319316 -18.699932 )
     (-20.759101 35.080429 -5.41176605 -20.072437 -3.210083 11.734699 )
     (-27.775909 20.875343 -8.62184907 -8.33773805 0.521009445 1.7611351 )
     (-36.137252 13.4181747 -8.1008396 -6.57660294 7.12604905 -0.779245377 )
     (-40.675064 6.4519491 -0.974789858 -7.3558483 0.974789858 7.3558483 ))
    NATURAL)
   (2
    ((78 207) (81 219))
    NIL
    ((3. 12. 0 0 0 0 ))
    NATURAL)
   (2
    ((81 219) (194 219))
    NIL
    ((113. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((194 219) (229 294))
    NIL
    ((35. 75. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 66Q)
 (FACE M R R)
 (WIDTH 248 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:45:32)
 (MADE-FROM NIL 98 130 43 65)
 (SPLINES

  ((3
    ((229 298) (229 298) (229 288))
    NIL
    ((0 2.5 0 0 0 -15. )
     (0 -5. 0 -15. 0 15. ))
    NATURAL)
   (7
    ((229 288) (195 281) (165 267) (141 248) (124 227) (112 203)
     (106 181))
    NIL
    ((-34.75769 -5.46282006 0 0 4.54615307 -9.22307588 )
     (-32.48461 -10.074358 4.54615307 -9.22307588 1.26923179 4.1153841 )
     (-27.303844 -17.239742 5.81538487 -5.10769177 2.37692165 4.76153755 )
     (-20.299999 -19.966663 8.1923065 -0.346153617 -4.77692127 -5.16153813 )
     (-14.4961528 -22.893589 3.41538477 -5.50769234 4.73076725 9.88461495 )
     (-8.71538354 -23.458972 8.1461525 4.3769226 -8.1461525 -4.3769226 ))
    NATURAL)
   (24
    ((106 181) (133 186) (161 186) (193 177) (222 151) (236 111)
     (234 68) (218 34) (189 9) (147 -4) (110 -3) (74 8)
     (44 29) (24 60) (13 100) (14 144) (24 187) (40 218)
     (60 243) (85 264) (120 281) (152 291) (191 297) (229 298))
    NIL
    ((27.017456 5.9552679 0 0 -0.104736805 -5.7316103 )
     (26.965084 3.08946276 -0.104736805 -5.7316103 6.52368355 -1.3419466 )
     (30.122192 -3.31312084 6.4189472 -7.0735569 -7.99000168 -12.900602 )
     (32.546135 -16.8369789 -1.57105517 -19.974159 -16.563671 4.94436646 )
     (22.693244 -34.33895 -18.134727 -15.0297928 2.24469948 11.123121 )
     (5.68086815 -43.807182 -15.890028 -3.90667152 1.58487129 16.563148 )
     (-9.41672326 -39.43228 -14.3051567 12.6564789 3.41581917 -5.37572384 )
     (-22.013973 -29.463665 -10.8893375 7.28075505 -9.24814797 4.9397459 )
     (-37.527381 -19.713039 -20.137485 12.2205009 33.576767 3.61674309 )
     (-40.87648 -5.6841688 13.439281 15.837244 -17.058918 -7.4067192 )
     (-35.966659 6.44971657 -3.61963892 8.4305248 10.6589126 2.01012611 )
     (-34.256843 15.885305 7.0392742 10.4406509 4.42326546 -0.633787155 )
     (-25.005939 26.009063 11.4625396 9.80686379 -4.35197258 0.525022507 )
     (-15.719387 36.078437 7.1105671 10.331886 6.98462487 -7.46629525 )
     (-5.11650753 42.677177 14.0951919 2.86559057 -5.58652687 -0.659839154 )
     (6.18542004 45.212844 8.50866509 2.20575142 -2.63851929 -19.894344 )
     (13.374826 37.47142 5.8701458 -17.688594 -1.85939884 14.2372398 )
     (18.315273 26.901447 4.01074696 -3.45135403 -1.92388344 -1.05462932 )
     (21.364078 22.922779 2.08686352 -4.50598336 15.554931 1.98127079 )
     (31.228408 19.407428 17.641796 -2.52471256 -30.295848 -6.87045193 )
     (33.722274 13.4474907 -12.6540527 -9.3951645 27.628467 7.50054169 )
     (34.88246 7.802598 14.9744148 -1.89462209 -20.218017 -5.1317215 )
     (39.747863 3.34211445 -5.24360276 -7.0263443 5.24360276 7.0263443 ))
    NATURAL))

  ((12
    ((97 136) (105 160) (127 165) (146 144) (150 106) (151 61)
     (143 27) (121 14) (102 32) (96 66) (94 100) (97 136))
    NIL
    ((4.31370259 27.50521 0 0 22.117782 -21.031272 )
     (15.3725929 16.989574 22.117782 -21.031272 -26.588913 -8.84362794 )
     (24.195919 -8.46351434 -4.47113037 -29.8749 -17.76213 14.40579 )
     (10.843723 -31.135517 -22.233261 -15.46911 25.637439 5.22045326 )
     (1.42918324 -43.9944 3.40418053 -10.248657 -12.787641 24.712398 )
     (-1.56045842 -41.886856 -9.383461 14.463741 -10.486866 3.9299469 )
     (-16.187351 -25.458145 -19.870327 18.393688 24.735099 19.567806 )
     (-23.690128 2.71944952 4.86477566 37.961494 13.5464439 -22.201179 )
     (-12.0521297 29.580352 18.41122 15.760313 -18.920879 -20.763061 )
     (-3.10134888 34.959129 -0.509659410 -5.0027504 8.1370735 9.25343705 )
     (0.457528412 34.583099 7.6274147 4.2506876 -7.6274147 -4.2506876 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 67Q)
 (FACE M R R)
 (WIDTH 248 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:46:19)
 (MADE-FROM NIL 110 130 43 65)
 (SPLINES

  ((3
    ((45 294) (45 294) (230 294))
    NIL
    ((-46.25 0 0 0 277.5 0 )
     (92.5 0 277.5 0 -277.5 0 ))
    NATURAL)
   (2
    ((230 294) (119 0))
    NIL
    ((-111. -294. 0 0 0 0 ))
    NATURAL)
   (2
    ((119 0) (83 0))
    NIL
    ((-36. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((83 0) (150 208))
    NIL
    ((67. 208. 0 0 0 0 ))
    NATURAL)
   (2
    ((150 208) (70 208))
    NIL
    ((-80. 0 0 0 0 0 ))
    NATURAL)
   (4
    ((70 208) (55 207) (41 202) (34 194))
    NIL
    ((-14.799999 -0.133333355 0 0 -1.19999981 -5.1999998 )
     (-15.399999 -2.73333311 -1.19999981 -5.1999998 11.999998 2. )
     (-10.599998 -6.9333334 10.799999 -3.1999998 -10.799999 3.1999998 ))
    NATURAL)
   (2
    ((34 194) (24 197))
    NIL
    ((-10. 3. 0 0 0 0 ))
    NATURAL)
   (2
    ((24 197) (45 294))
    NIL
    ((21. 97. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 70Q)
 (FACE M R R)
 (WIDTH 248 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:47:01)
 (MADE-FROM NIL 110 130 43 65)
 (SPLINES

  ((11
    ((143 187) (124 200) (109 218) (99 241) (100 264) (114 279)
     (135 278) (147 262) (152 235) (150 209) (143 187))
    NIL
    ((-19.869873 11.9956379 0 0 5.21924973 6.02616978 )
     (-17.26025 15.008722 5.21924973 6.02616978 -2.09624863 -0.130851745 )
     (-13.0891247 20.969467 3.1230011 5.89531803 9.16574479 -5.50276184 )
     (-5.38325024 24.113403 12.2887459 0.392555833 1.43326759 -7.85809708 )
     (7.62212754 20.576908 13.722013 -7.46554185 -2.89880943 -11.064842 )
     (19.894733 7.5789461 10.823204 -18.530384 -25.838031 4.1174755 )
     (17.798923 -8.8927021 -15.014829 -14.412908 10.250944 0.594938278 )
     (7.9095659 -23.00814 -4.76388455 -13.81797 -3.16574574 17.502761 )
     (1.56280875 -28.074729 -7.92963029 3.68479157 2.41203785 1.39401054 )
     (-5.16080189 -23.692932 -5.51759243 5.0788021 5.51759243 -5.0788021 ))
    NATURAL))

  ((11
    ((106 126) (98 109) (94 84) (93 54) (103 24) (129 12)
     (148 26) (153 57) (143 89) (126 112) (106 126))
    NIL
    ((-8.9797363 -15.152502 0 0 5.8784256 -11.0849876 )
     (-6.04052354 -20.694995 5.8784256 -11.0849876 -5.39213085 7.4249382 )
     (-2.85816383 -28.067512 0.486294031 -3.66004896 9.6901016 -0.614766598 )
     (2.47318268 -32.034942 10.176397 -4.27481556 14.6317119 25.034126 )
     (19.965435 -23.792697 24.808109 20.759311 -38.216949 8.4782562 )
     (25.665069 1.20574236 -13.40884 29.237567 0.236091614 -10.9471588 )
     (12.374275 24.96973 -13.172748 18.290409 -4.72740555 -18.689624 )
     (-3.16217756 33.915329 -17.900154 -0.399217188 12.6735286 -10.2943229 )
     (-14.7255668 28.368946 -5.22662449 -10.6935405 2.03328085 -0.133073806 )
     (-18.93555 17.608871 -3.19334364 -10.826614 3.19334364 10.826614 ))
    NATURAL))

  ((16
    ((161 178) (191 188) (216 206) (225 234) (214 267) (191 285)
     (159 295) (117 297) (83 292) (53 279) (31 254) (23 224)
     (32 192) (51 168) (70 150) (92 135))
    NIL
    ((30.5219 8.40951158 0 0 -3.13142109 9.5429306 )
     (28.956192 13.1809768 -3.13142109 9.5429306 -14.342893 0.285345077 )
     (18.65332 22.866577 -17.474315 9.82827569 -5.496994 1.31568908 )
     (-1.56949138 33.352699 -22.971309 11.1439647 12.330877 -35.548103 )
     (-18.375362 26.72261 -10.640432 -24.40414 4.17348099 20.876743 )
     (-26.929054 12.756843 -6.46695138 -3.5273943 -11.0248088 -5.95888233 )
     (-38.908409 6.25000668 -17.49176 -9.4862766 33.925758 2.95878696 )
     (-39.437286 -1.75687647 16.433998 -6.52748967 -16.67823 0.123727798 )
     (-31.34241 -8.22250176 -0.244234919 -6.40376187 8.7871742 -9.4536953 )
     (-27.193054 -19.353111 8.54294015 -15.857458 5.52952576 13.691059 )
     (-15.885351 -28.365039 14.0724659 -2.16639852 5.09471703 -3.31054735 )
     (0.734474182 -32.186714 19.167182 -5.47694588 -7.90839387 17.551128 )
     (15.94746 -28.888095 11.258789 12.074182 -15.461132 -6.89396477 )
     (19.475681 -20.260894 -4.20234394 5.18021775 9.7529297 -1.97527265 )
     (20.149803 -16.068313 5.55058575 3.20494509 -5.55058575 -3.20494509 ))
    NATURAL)
   (18
    ((92 135) (66 126) (40 113) (22 90) (18 58) (31 30)
     (53 11) (81 0) (112 -4) (151 -3) (187 6) (214 24)
     (231 50) (236 85) (223 121) (200 147) (180 164) (161 178))
    NIL
    ((-25.61761 -8.46248437 0 0 -2.29432678 -3.22508955 )
     (-26.764774 -10.075029 -2.29432678 -3.22508955 11.4716339 -7.87455178 )
     (-23.323284 -17.237396 9.1773071 -11.0996418 4.40778733 -1.27669716 )
     (-11.942083 -28.975387 13.585094 -12.3763389 6.8972168 18.981342 )
     (5.0916214 -31.861053 20.482311 6.60500336 -13.996664 3.35132027 )
     (18.575599 -23.58039 6.48564625 9.9563236 1.08945465 -2.38662529 )
     (25.605972 -14.817379 7.5751009 7.56969834 -8.36115075 0.195180893 )
     (29.000499 -7.15008927 -0.786051036 7.7648792 14.355152 -4.39409924 )
     (35.39202 -1.58225989 13.569101 3.37077951 -19.059459 5.3812208 )
     (39.431388 4.47912979 -5.4903612 8.7520008 -4.11729336 0.869216920 )
     (31.882385 13.665739 -9.60765458 9.6212177 -0.471364975 -2.85809517 )
     (22.039047 21.85791 -10.0790195 6.76312256 0.00275802612 4.56316757 )
     (11.9614086 30.902614 -10.0762615 11.32629 -11.539667 -9.39457894 )
     (-3.88468742 37.531616 -21.615928 1.93171096 10.15591 -14.984844 )
     (-20.42266 31.970905 -11.460018 -13.0531349 18.916019 3.33397102 )
     (-22.424667 20.584754 7.45600415 -9.7191639 -7.82000447 7.64895535 )
     (-18.8786659 14.690069 -0.364001214 -2.07020855 0.364001214 2.07020855 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 71Q)
 (FACE M R R)
 (WIDTH 248 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:48:02)
 (MADE-FROM NIL 122 130 43 65)
 (SPLINES

  ((7
    ((140 116) (133 90) (113 55) (89 31) (63 17) (36 8)
     (13 5))
    NIL
    ((-3.77564097 -22.973075 0 0 -19.346153 -18.161537 )
     (-13.448717 -32.05384 -19.346153 -18.161537 18.730766 36.807685 )
     (-23.429485 -31.811534 -0.615384579 18.646152 -1.57692289 -9.06923104 )
     (-24.833332 -17.6999969 -2.19230747 9.57692147 -0.423077107 -6.53076649 )
     (-27.237178 -11.38846 -2.61538458 3.0461545 9.2692299 5.19230557 )
     (-25.217945 -5.74615288 6.65384579 8.23846055 -6.65384579 -8.23846055 ))
    NATURAL)
   (2
    ((13 5) (13 -5))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (24
    ((13 -5) (42 -6) (85 0) (129 13) (167 33) (198 61)
     (221 96) (235 133) (238 179) (231 223) (212 258) (180 283)
     (148 293) (114 296) (77 291) (48 276) (29 258) (13 224)
     (11 183) (21 149) (43 121) (74 108) (109 106) (140 116))
    NIL
    ((25.408454 -2.4763155 0 0 21.549259 8.8578949 )
     (36.183082 1.95263242 21.549259 8.8578949 -23.746303 -2.28948021 )
     (45.85919 9.66578675 -2.19704437 6.56841469 -4.56403923 0.300027847 )
     (41.380126 16.384216 -6.7610836 6.86844254 0.00246334076 1.08936882 )
     (34.620277 23.797344 -6.75862027 7.95781136 -1.44581127 1.34249305 )
     (27.138748 32.426399 -8.20443154 9.3003044 -0.219215393 -12.459333 )
     (18.82471 35.497039 -8.4236469 -3.15902996 -3.67733002 18.494842 )
     (8.5623989 41.585426 -12.1009769 15.335813 2.92853546 -19.520042 )
     (-2.07431078 47.161224 -9.17244149 -4.18422985 -2.03680992 -6.41466618 )
     (-12.2651577 39.76966 -11.209251 -10.598896 -6.7812996 3.17871285 )
     (-26.865058 30.76012 -17.990551 -7.42018319 23.162006 -12.30018 )
     (-33.274604 17.189842 5.17145634 -19.720363 -7.86673165 16.022014 )
     (-32.036514 5.48048878 -2.6952753 -3.69834662 -3.69507694 -3.78789759 )
     (-36.579322 -0.111806541 -6.39035226 -7.4862442 16.647037 -6.87042809 )
     (-34.646156 -11.033264 10.256685 -14.356672 3.10692024 19.269603 )
     (-22.836017 -15.755134 13.363605 4.91293335 -17.0747108 -28.207992 )
     (-18.009765 -24.946197 -3.71110535 -23.295059 23.191921 15.562372 )
     (-10.12491 -40.460067 19.480815 -7.732687 -9.6929836 19.958496 )
     (4.50941372 -38.213508 9.78783227 12.225809 3.5800209 -11.39636 )
     (16.087253 -31.685878 13.367853 0.829447270 -4.6271019 19.626949 )
     (27.141559 -21.042957 8.74075128 20.456398 -3.07161903 -13.1114368 )
     (34.346496 -7.14227963 5.66913224 7.34496117 -13.086414 8.81879617 )
     (33.472427 4.61208058 -7.41728306 16.163757 7.41728306 -16.163757 ))
    NATURAL))

  ((14
    ((119 277) (102 266) (96 243) (94 215) (94 186) (99 153)
     (110 133) (128 128) (143 144) (147 175) (146 209) (143 240)
     (135 267) (119 277))
    NIL
    ((-18.843631 -1.24039459 -2.892457 -23.967063 19.73917 13.343559 )
     (-11.8665027 -18.535678 16.846714 -10.6235046 -15.3411178 5.08459187 )
     (-2.69034862 -26.616886 1.50559568 -5.53891278 -0.374693632 8.31806947 )
     (-1.37209987 -27.996765 1.13090205 2.77915716 4.83989334 -14.35687 )
     (2.17874861 -32.396041 5.97079563 -11.5777149 -0.984880448 31.109413 )
     (7.6571045 -28.419052 4.98591519 19.5317 5.0996275 -8.08078385 )
     (15.1928329 -12.927742 10.0855426 11.450916 -13.413631 13.2137069 )
     (18.5715599 5.13002777 -3.32808876 24.664623 -11.4450988 -8.7740402 )
     (9.5209198 25.407627 -14.773187 15.890583 11.1940345 -14.1175327 )
     (0.344750881 34.23944 -3.5791521 1.77304864 2.66895056 -6.755826 )
     (-1.89992594 32.634574 -0.910201312 -4.9827776 -3.86983919 5.14084149 )
     (-4.74504757 30.22222 -4.78004074 0.158064514 -5.18959046 -19.80754 )
     (-12.119884 20.476512 -9.9696312 -19.649478 6.62820054 -3.91065979 ))
    PSEUDOCYCLIC))))

((FAMILY TIMESROMAND)
 (CHARACTER 60Q)
 (FACE M R R)
 (WIDTH 248 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:49:21)
 (MADE-FROM NIL 112 130 43 65)
 (SPLINES

  ((29
    ((125 302) (162 297) (194 281) (218 251) (229 228) (236 199)
     (240 165) (240 147) (240 129) (236 95) (229 66) (218 43)
     (194 13) (162 -3) (125 -8) (88 -3) (56 13) (32 43)
     (21 66) (14 95) (10 129) (10 147) (10 165) (14 199)
     (21 228) (32 251) (56 281) (88 297) (125 302))
    NIL
    ((38.123054 -0.494537652 -0.435223341 -9.4098396 -5.4326887 1.19674492 )
     (34.971489 -9.30600549 -5.86791229 -8.2130947 -0.225214004 -15.524675 )
     (28.99097 -25.28144 -6.0931263 -23.73777 -11.6664486 42.901954 )
     (17.064617 -27.568229 -17.7595749 19.164184 16.891006 -30.08316 )
     (7.75054837 -23.445625 -0.868566871 -10.9189758 -1.89759016 -0.569307328 )
     (5.93318558 -34.649253 -2.76615715 -11.488283 -3.30064392 38.360389 )
     (1.51670646 -26.95734 -6.06680108 26.872112 9.1001644 -26.87228 )
     (-1.25567112E-5 -13.5213699 3.03336334 -1.70698214E-4 -9.10001374 -26.871257 )
     (-1.51665687 -26.957172 -6.06665135 -26.871429 3.29989529 38.35733 )
     (-5.9333601 -34.649932 -2.76675606 11.4859066 1.90043187 -0.558097840 )
     (-7.7499008 -23.443077 -0.866324187 10.9278087 -16.9016189 -30.12495 )
     (-17.067035 -27.577743 -17.767944 -19.197143 11.706064 43.057907 )
     (-28.981948 -25.245929 -6.0618801 23.860767 0.0773506165 -16.1067009 )
     (-35.005149 -9.4385147 -5.9845295 7.7540655 5.9845295 3.36890125 )
     (-37.99742 1.60187482E-7 0 11.1229667 5.9845295 -3.36890125 )
     (-35.005149 9.4385166 5.9845295 7.7540655 0.0773506165 16.1067009 )
     (-28.981948 25.245933 6.0618801 23.860767 11.706064 -43.057907 )
     (-17.0670318 27.577743 17.767944 -19.197143 -16.9016189 30.12495 )
     (-7.74989987 23.443077 0.866324187 10.9278087 1.90043092 0.558095932 )
     (-5.9333601 34.649932 2.7667551 11.4859047 3.29989624 -38.357338 )
     (-1.5166564 26.957172 6.06665135 -26.871433 -9.10001374 26.871261 )
     (-1.23977661E-5 13.5213699 -3.03336334 -1.69676088E-4 9.1001644 26.87228 )
     (1.51670670 26.95734 6.06680108 26.872112 -3.30064344 -38.360389 )
     (5.93318558 34.649253 2.76615763 -11.488283 -1.89759087 0.569309235 )
     (7.75054837 23.445625 0.868566752 -10.9189739 16.891006 30.083156 )
     (17.064617 27.568233 17.7595749 19.164184 -11.6664467 -42.901954 )
     (28.99097 25.281436 6.09312726 -23.73777 -0.225214958 15.524673 )
     (34.971489 9.30600549 5.86791229 -8.2130966 -5.4326887 -1.19674301 ))
    PSEUDOCYCLIC))

  ((25
    ((125 10) (140 16) (149 39) (152 63) (153 89) (154 119)
     (155 147) (154 175) (153 205) (152 231) (149 255) (140 278)
     (125 284) (110 278) (101 255) (98 231) (97 205) (96 175)
     (95 147) (96 119) (97 89) (98 63) (101 39) (110 16)
     (125 10))
    NIL
    ((16.35659 -0.115979194 -0.491682887 5.6023569 -6.66450596 19.888801 )
     (12.5326557 15.43078 -7.15618897 25.491161 0.272627830 -31.058166 )
     (5.51278019 25.392856 -6.88356114 -5.567008 5.57399655 8.3438816 )
     (1.41621828 23.997787 -1.30956387 2.77687406 1.43138146 3.68263578 )
     (0.822345257 28.615982 0.121817797 6.45950986 0.700474859 -11.0744228 )
     (1.29440045 29.538276 0.822292686 -4.61491394 -4.23328018 4.61506176 )
     (5.23924827E-5 27.230896 -3.41098833 1.48722116E-4 4.2326498 4.61417103 )
     (-1.2946105 29.538127 0.821662307 4.6143198 -0.697323084 -11.0717468 )
     (-0.821609855 28.616573 0.124339193 -6.45742798 -1.44335818 3.67282152 )
     (-1.41894984 23.995555 -1.31901908 -2.78460646 -5.5292425 8.38046075 )
     (-5.50259018 25.401184 -6.84826184 5.5958557 -0.439672470 -31.194671 )
     (-12.570688 15.399702 -7.2879343 -25.598815 7.28793336 20.398223 )
     (-16.214653 -9.53674316E-7 -2.55536235E-7 -5.20059109 7.28793526 -20.39822 )
     (-12.570688 -15.3997039 7.28793526 -25.598812 -0.439674378 31.194664 )
     (-5.50259018 -25.40118 6.84826089 5.59585476 -5.5292406 -8.38046075 )
     (-1.41894984 -23.995559 1.31901955 -2.78460646 -1.44335866 -3.67282152 )
     (-0.821609736 -28.616577 -0.124339282 -6.45742798 -0.697323084 11.0717468 )
     (-1.2946105 -29.538127 -0.821662427 4.6143198 4.23265076 -4.61417008 )
     (5.25317154E-5 -27.230896 3.4109888 1.48977647E-4 -4.23328114 -4.61506367 )
     (1.29440045 -29.538276 -0.822292805 -4.6149149 0.700474978 11.0744247 )
     (0.822345257 -28.615982 -0.121817782 6.45950986 1.43138146 -3.6826353 )
     (1.41621852 -23.997787 1.30956387 2.77687454 5.57399655 -8.3438835 )
     (5.51278115 -25.392856 6.88356114 -5.56700897 0.272626877 31.05817 )
     (12.5326557 -15.430778 7.156188 25.491161 -6.66450406 -19.888805 ))
    PSEUDOCYCLIC))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.S1-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.S1-SF
deleted file mode 100644
index 46103ff2..00000000
--- a/obsolete/lispusers/splinefonts/TIMESROMAN.S1-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY TIMESROMAND)
 (CHARACTER 41Q)
 (FACE M R R)
 (WIDTH 159 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 13:54:31)
 (MADE-FROM NIL 117 130 35 72)
 (SPLINES

  ((9
    ((80 299) (58 296) (41 286) (34 268) (37 240) (44 209)
     (52 176) (61 139) (66 97))
    NIL
    ((-22.794181 -1.52006626 0 0 4.7650957 -8.87960244 )
     (-20.411632 -5.95986748 4.7650957 -8.87960244 6.17451955 2.39801216 )
     (-12.559276 -13.6404628 10.939615 -6.48159028 0.536821366 -6.7124443 )
     (-1.35125184 -23.478275 11.4764366 -13.194034 -8.3217964 12.451765 )
     (5.9642849 -30.446426 3.15463877 -0.742267847 -3.24963093 -1.09462428 )
     (7.4941082 -31.736007 -0.0949926228 -1.83689213 3.32032347 -2.07326984 )
     (9.05927659 -34.609535 3.2253313 -3.91016197 -10.0316639 -2.61229706 )
     (7.2687769 -39.825843 -6.80633259 -6.52245904 6.80633259 6.52245904 ))
    NATURAL)
   (2
    ((66 97) (94 97))
    NIL
    ((28. 0 0 0 0 0 ))
    NATURAL)
   (9
    ((94 97) (99 139) (108 176) (116 209) (123 240) (126 268)
     (119 286) (102 296) (80 299))
    NIL
    ((3.86561108 43.087074 0 0 6.80633259 -6.52245904 )
     (7.2687769 39.825843 6.80633259 -6.52245904 -10.0316639 2.61229706 )
     (9.05927659 34.609535 -3.2253313 -3.91016197 3.32032394 2.07326984 )
     (7.4941082 31.736007 0.0949927271 -1.83689213 -3.24963188 1.09462356 )
     (5.96428585 30.446426 -3.15463924 -0.742268563 -8.3217964 -12.451763 )
     (-1.35125184 23.478275 -11.4764366 -13.1940326 0.536821366 6.71244145 )
     (-12.559278 13.6404628 -10.939615 -6.48159123 6.1745205 -2.3980093 )
     (-20.411632 5.95986653 -4.76509476 -8.8796005 4.76509476 8.8796005 ))
    NATURAL))

  ((17
    ((80 -6) (99 -3) (114 4) (122 13) (125 27) (122 41)
     (114 50) (99 57) (80 60) (61 57) (46 50) (38 41)
     (35 27) (38 13) (46 4) (61 -3) (80 -6))
    NIL
    ((19.639171 1.98203754 0 0 -3.83505154 6.10777474 )
     (17.721649 5.0359249 -3.83505154 6.10777474 -4.82474232 -6.53887368 )
     (11.474226 7.87426186 -8.65979386 -0.431099415 5.1340208 8.04772187 )
     (5.38144303 11.4670238 -3.52577257 7.6166229 -3.71134043 -7.65201569 )
     (-8.00937414E-8 15.2576389 -7.237113 -0.0353937074 3.71133947 -7.43965436 )
     (-5.38144303 11.5024166 -3.52577353 -7.47504807 -5.13401795 7.41063786 )
     (-11.474226 7.73268796 -8.65979196 -0.0644102097 4.8247404 -4.20289994 )
     (-17.721649 5.5668268 -3.83505154 -4.26731014 3.83505106 -2.59903431 )
     (-19.639171 0 -1.27768117E-7 -6.86634446 3.835052 2.59903335 )
     (-17.721649 -5.56682778 3.835052 -4.2673111 4.82473946 4.20290089 )
     (-11.474226 -7.73268796 8.65979196 -0.0644097030 -5.1340189 -7.4106388 )
     (-5.38144303 -11.5024166 3.52577305 -7.475049 3.71133995 7.4396553 )
     (1.59256160E-7 -15.2576389 7.237113 -0.0353935584 -3.71133995 7.65201569 )
     (5.38144303 -11.4670238 3.52577305 7.6166229 5.1340208 -8.04772187 )
     (11.474226 -7.87426186 8.65979386 -0.431099653 -4.82474232 6.53887368 )
     (17.721649 -5.0359249 3.83505154 6.10777474 -3.83505154 -6.10777474 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 43Q)
 (FACE M R R)
 (WIDTH 378 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 13:59:09)
 (MADE-FROM NIL 88 130 95 75)
 (SPLINES

  ((2
    ((73 221) (59 187))
    NIL
    ((-14. -34. 0 0 0 0 ))
    NATURAL)
   (2
    ((59 187) (109 187))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((109 187) (77 107))
    NIL
    ((-32. -80. 0 0 0 0 ))
    NATURAL)
   (2
    ((77 107) (27 107))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((27 107) (13 73))
    NIL
    ((-14. -34. 0 0 0 0 ))
    NATURAL)
   (2
    ((13 73) (63 73))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((63 73) (34 0))
    NIL
    ((-29. -73. 0 0 0 0 ))
    NATURAL)
   (2
    ((34 0) (94 0))
    NIL
    ((60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((94 0) (123 73))
    NIL
    ((29. 73. 0 0 0 0 ))
    NATURAL)
   (2
    ((123 73) (193 73))
    NIL
    ((70. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((193 73) (164 0))
    NIL
    ((-29. -73. 0 0 0 0 ))
    NATURAL)
   (2
    ((164 0) (224 0))
    NIL
    ((60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((224 0) (253 73))
    NIL
    ((29. 73. 0 0 0 0 ))
    NATURAL)
   (2
    ((253 73) (303 73))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((303 73) (317 107))
    NIL
    ((14. 34. 0 0 0 0 ))
    NATURAL)
   (2
    ((317 107) (267 107))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((267 107) (299 187))
    NIL
    ((32. 80. 0 0 0 0 ))
    NATURAL)
   (2
    ((299 187) (349 187))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((349 187) (363 221))
    NIL
    ((14. 34. 0 0 0 0 ))
    NATURAL)
   (2
    ((363 221) (313 221))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((313 221) (343 294))
    NIL
    ((30. 73. 0 0 0 0 ))
    NATURAL)
   (2
    ((343 294) (283 294))
    NIL
    ((-60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((283 294) (253 221))
    NIL
    ((-30. -73. 0 0 0 0 ))
    NATURAL)
   (2
    ((253 221) (183 221))
    NIL
    ((-70. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((183 221) (213 294))
    NIL
    ((30. 73. 0 0 0 0 ))
    NATURAL)
   (2
    ((213 294) (153 294))
    NIL
    ((-60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((153 294) (123 221))
    NIL
    ((-30. -73. 0 0 0 0 ))
    NATURAL)
   (2
    ((123 221) (73 221))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((137 107) (169 187))
    NIL
    ((32. 80. 0 0 0 0 ))
    NATURAL)
   (2
    ((169 187) (239 187))
    NIL
    ((70. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((239 187) (207 107))
    NIL
    ((-32. -80. 0 0 0 0 ))
    NATURAL)
   (2
    ((207 107) (137 107))
    NIL
    ((-70. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 44Q)
 (FACE M R R)
 (WIDTH 295 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 14:21:22)
 (MADE-FROM NIL 111 130 82 78)
 (SPLINES

  ((3
    ((256 294) (256 294) (256 204))
    NIL
    ((0 22.5 0 0 0 -135. )
     (0 -45. 0 -135. 0 135. ))
    NATURAL)
   (2
    ((256 204) (246 204))
    NIL
    ((-10. 0 0 0 0 0 ))
    NATURAL)
   (5
    ((246 204) (223 240) (201 260) (173 274) (161 276))
    NIL
    ((-23.982139 40.071426 0 0 5.8928566 -24.428569 )
     (-21.035713 27.857139 5.8928566 -24.428569 -23.464283 26.142852 )
     (-26.875 16.499996 -17.571426 1.71428418 45.964279 -20.142848 )
     (-21.464283 8.1428547 28.392856 -18.428566 -28.392856 18.428566 ))
    NATURAL)
   (2
    ((161 276) (161 191))
    NIL
    ((0 -85. 0 0 0 0 ))
    NATURAL)
   (10
    ((161 191) (179 183) (215 165) (253 139) (277 101) (276 56)
     (259 26) (219 1) (178 -7) (161 -8))
    NIL
    ((13.47525 -5.72048283 0 0 27.148498 -13.677099 )
     (27.049499 -12.559032 27.148498 -13.677099 -27.742504 8.38549806 )
     (40.326744 -22.04338 -0.594006300 -5.29160118 -12.1784687 -7.86489106 )
     (33.6435 -31.267429 -12.772476 -13.156492 -19.543609 -0.925933839 )
     (11.09922 -44.886886 -32.316085 -14.082426 24.352932 41.568618 )
     (-9.04039956 -38.184997 -7.96315194 27.486198 -23.868145 -33.348571 )
     (-28.937622 -27.373088 -31.831298 -5.86237526 29.119644 31.825672 )
     (-46.209098 -17.322628 -2.71165275 25.963298 39.389556 -21.954124 )
     (-29.225967 -2.33639145 36.677909 4.00917435 -36.677909 -4.00917435 ))
    NATURAL)
   (2
    ((161 -8) (161 -28))
    NIL
    ((0 -20. 0 0 0 0 ))
    NATURAL)
   (2
    ((161 -28) (131 -28))
    NIL
    ((-30. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((131 -28) (131 -7))
    NIL
    ((0 21. 0 0 0 0 ))
    NATURAL)
   (7
    ((131 -7) (114 -5) (84 1) (62 10) (48 13) (39 9)
     (32 0))
    NIL
    ((-13.073076 1.22948718 0 0 -23.561534 4.62307644 )
     (-24.853843 3.54102564 -23.561534 4.62307644 39.807685 0.884614945 )
     (-28.511535 8.60640908 16.2461509 5.50769139 -9.6692276 -14.161535 )
     (-17.099998 7.03333283 6.57692338 -8.65384484 -1.13076973 1.7615366 )
     (-11.0884609 -0.739743471 5.44615364 -6.89230824 -3.80769205 1.11538601 )
     (-7.54615307 -7.07435895 1.63846135 -5.77692223 -1.63846135 5.77692223 ))
    NATURAL)
   (2
    ((32 0) (22 0))
    NIL
    ((-10. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((22 0) (22 100))
    NIL
    ((0 100. 0 0 0 0 ))
    NATURAL)
   (2
    ((22 100) (34 100))
    NIL
    ((12. 0 0 0 0 0 ))
    NATURAL)
   (4
    ((34 100) (50 63) (73 36) (108 17))
    NIL
    ((14.933332 -39.13333 0 0 6.40000058 12.799999 )
     (18.133331 -32.733329 6.40000058 12.799999 9.9999962 -4. )
     (29.533332 -21.93333 16.399997 8.79999925 -16.399997 -8.79999925 ))
    NATURAL)
   (2
    ((108 17) (131 12))
    NIL
    ((23. -5. 0 0 0 0 ))
    NATURAL)
   (2
    ((131 12) (131 100))
    NIL
    ((0 88. 0 0 0 0 ))
    NATURAL)
   (11
    ((131 100) (112 110) (74 132) (42 154) (20 185) (15 220)
     (23 250) (41 273) (67 288) (97 296) (131 300))
    NIL
    ((-13.5979 6.63703728 0 0 -32.41259 20.177772 )
     (-29.804195 16.725921 -32.41259 20.177772 48.062957 -28.888866 )
     (-38.185302 22.459262 15.650373 -8.7110939 -9.83927728 23.377697 )
     (-27.45457 25.437019 5.81109619 14.666603 15.2941398 -10.621927 )
     (-13.9964027 34.792656 21.105236 4.04467488 -9.33728219 -10.889978 )
     (2.44019174 33.39234 11.7679538 -6.8453045 -1.94501304 0.181846618 )
     (13.2356376 26.637962 9.8229408 -6.66345788 -0.882658005 -1.83740043 )
     (22.617248 19.055801 8.9402828 -8.5008583 -6.52435876 1.16775417 )
     (28.295352 11.1388206 2.41592407 -7.33310414 2.98009395 3.16638088 )
     (32.201324 5.38890744 5.39601803 -4.16672325 -5.39601803 4.16672325 ))
    NATURAL)
   (2
    ((131 300) (131 316))
    NIL
    ((0 16. 0 0 0 0 ))
    NATURAL)
   (2
    ((131 316) (161 316))
    NIL
    ((30. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((161 316) (161 298))
    NIL
    ((0 -18. 0 0 0 0 ))
    NATURAL)
   (6
    ((161 298) (173 296) (201 289) (223 282) (239 284) (244 294))
    NIL
    ((7.34449769 -0.794258357 0 0 27.933013 -7.23444939 )
     (21.311004 -4.4114828 27.933013 -7.23444939 -43.665069 6.17224789 )
     (27.411479 -8.5598068 -15.732055 -1.06220078 14.72727 12.545454 )
     (19.04306 -3.34928227 -1.00478506 11.483253 -15.244016 -2.35406685 )
     (10.416267 6.9569378 -16.248802 9.1291866 16.248802 -9.1291866 ))
    NATURAL)
   (2
    ((244 294) (256 294))
    NIL
    ((12. 0 0 0 0 0 ))
    NATURAL))

  ((6
    ((161 14) (183 19) (201 34) (204 62) (187 79) (161 92))
    NIL
    ((22.334926 3.44497585 0 0 -2.00956964 9.33014298 )
     (21.330142 8.1100483 -2.00956964 9.33014298 -13.95215 13.349281 )
     (12.3444957 24.11483 -15.961721 22.679424 -8.181818 -44.727264 )
     (-7.7081337 24.430618 -24.143539 -22.047843 16.679424 21.559803 )
     (-23.511959 13.1626777 -7.46411515 -0.488038778 7.46411515 0.488038778 ))
    NATURAL)
   (2
    ((161 92) (161 14))
    NIL
    ((0 -78. 0 0 0 0 ))
    NATURAL))

  ((7
    ((131 278) (111 274) (96 264) (88 248) (91 227) (111 210)
     (131 199))
    NIL
    ((-20.961536 -2.71410227 0 0 5.76923085 -7.71538449 )
     (-18.076919 -6.5717945 5.76923085 -7.71538449 1.15384578 2.57692337 )
     (-11.730768 -12.998716 6.92307664 -5.1384611 1.61538315 -2.59230804 )
     (-3.99999905 -19.43333 8.53845979 -7.73076916 16.3846168 13.7923069 )
     (12.730768 -20.267948 24.923076 6.06153775 -31.153842 1.42307758 )
     (22.076919 -13.494871 -6.2307682 7.4846153 6.2307682 -7.4846153 ))
    NATURAL)
   (2
    ((131 199) (131 278))
    NIL
    ((0 79. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 45Q)
 (FACE M R R)
 (WIDTH 334 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 14:31:37)
 (MADE-FROM NIL 40 130 25 71)
 (SPLINES

  ((3
    ((271 294) (271 294) (94 0))
    NIL
    ((44.25 73.5 0 0 -265.5 -441. )
     (-88.5 -147. -265.5 -441. 265.5 441. ))
    NATURAL)
   (2
    ((94 0) (62 0))
    NIL
    ((-32. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((62 0) (239 294) (239 294))
    NIL
    ((221.25 367.5 0 0 -265.5 -441. )
     (88.5 147. -265.5 -441. 265.5 441. ))
    NATURAL)
   (2
    ((239 294) (271 294))
    NIL
    ((32. 0 0 0 0 0 ))
    NATURAL))

  ((21
    ((79 127) (105 133) (124 146) (136 164) (141 184) (144 214)
     (141 244) (136 264) (124 282) (105 295) (79 301) (53 295)
     (34 282) (22 264) (17 244) (14 214) (17 184) (22 164)
     (34 146) (53 133) (79 127))
    NIL
    ((27.505523 4.49280548 0 0 -9.0331478 9.0431652 )
     (22.988948 9.01438714 -9.0331478 9.0431652 3.16574478 -3.21582604 )
     (15.538673 16.449638 -5.86740303 5.82733917 -3.62983322 -8.17986299 )
     (7.8563528 18.187046 -9.49723626 -2.35252428 11.353588 17.935279 )
     (4.0359106 24.802162 1.85635328 15.582756 -11.7845268 -15.561258 )
     (-5.56930899E-7 32.604286 -9.92817498 0.0214966945 11.7845268 -15.6902389 )
     (-4.03591156 24.780666 1.85635328 -15.668743 -11.353588 18.322219 )
     (-7.85635377 18.273033 -9.49723626 2.65347767 3.62983227 -9.59864427 )
     (-15.538673 16.127189 -5.86740399 -6.94516659 -3.16574383 2.07235908 )
     (-22.988948 10.2182006 -9.0331478 -4.8728075 9.0331459 -10.690786 )
     (-27.505523 -1.60187482E-7 -5.11072471E-7 -15.5635948 9.0331497 10.690784 )
     (-22.988948 -10.2182006 9.0331497 -4.8728094 -3.16574574 -2.07235718 )
     (-15.538673 -16.127189 5.86740399 -6.94516659 3.62983227 9.59864427 )
     (-7.8563528 -18.273033 9.49723626 2.65347767 -11.353588 -18.322219 )
     (-4.03591156 -24.780666 -1.85635352 -15.668743 11.7845287 15.6902389 )
     (-3.91155481E-8 -32.604286 9.92817689 0.0214962214 -11.7845287 15.56126 )
     (4.03591156 -24.802162 -1.85635352 15.5827579 11.353588 -17.935279 )
     (7.85635377 -18.187046 9.49723626 -2.35252428 -3.62983227 8.17986299 )
     (15.538673 -16.449638 5.86740399 5.82733917 3.16574383 3.21582604 )
     (22.988948 -9.01438714 9.0331478 9.0431652 -9.0331478 -9.0431652 ))
    NATURAL))

  ((17
    ((79 141) (93 151) (96 172) (97 190) (96 214) (97 238)
     (96 256) (93 277) (79 287) (65 277) (62 256) (61 238)
     (62 214) (61 190) (62 172) (65 151) (79 141))
    NIL
    ((16.803104 -0.223070144 0.182082086 24.092327 -17.364887 -10.93856 )
     (8.302742 18.399978 -17.1828079 13.153766 19.73196 -23.861171 )
     (0.985916854 19.623157 2.54915523 -10.707405 -7.5629673 22.383258 )
     (-0.246411472 20.107383 -5.01381207 11.6758537 10.519905 -11.671869 )
     (-2.70843506E-4 25.947299 5.50609303 0.00398380961 -10.516653 -11.695772 )
     (0.247495413 20.103397 -5.01056099 -11.6917896 7.54671 22.454963 )
     (-0.989710332 19.639091 2.5361495 10.763174 -19.670185 -24.12408 )
     (-8.28865434 18.340225 -17.134037 -13.360906 17.134037 -9.9586353 )
     (-16.8556709 -1.90734863E-6 0 -23.319541 17.134037 9.95863725 )
     (-8.2886524 -18.340225 17.134037 -13.3609047 -19.670185 24.124076 )
     (-0.989710093 -19.639091 -2.5361495 10.763174 7.54670907 -22.454959 )
     (0.247495472 -20.103401 5.01056004 -11.6917877 -10.516653 11.69577 )
     (-2.70843506E-4 -25.947299 -5.50609303 0.00398329925 10.519903 11.671871 )
     (-0.246411145 -20.107383 5.0138111 11.6758556 -7.56296635 -22.383258 )
     (0.985917092 -19.623157 -2.54915523 -10.707405 19.73196 23.861171 )
     (8.3027439 -18.399974 17.1828079 13.153768 -17.364887 10.9385585 ))
    PSEUDOCYCLIC))

  ((21
    ((257 167) (283 161) (302 148) (314 130) (319 110) (322 80)
     (319 50) (314 30) (302 12) (283 -1) (257 -7) (231 -1)
     (212 12) (200 30) (195 50) (192 80) (195 110) (200 130)
     (212 148) (231 161) (257 167))
    NIL
    ((27.627128 -0.143936932 -0.421261072 -15.064924 -8.49900819 10.058393 )
     (22.956363 -10.1796646 -8.9202709 -5.0065298 3.0226221 -1.9024229 )
     (15.547403 -16.137405 -5.8976488 -6.9089527 -3.59148312 9.5512943 )
     (7.85401345 -18.27071 -9.4891319 2.64234209 11.343313 -18.302753 )
     (4.03653813 -24.779747 1.85418176 -15.660413 -11.781774 15.659725 )
     (-1.68442726E-4 -32.610298 -9.9275932 -6.87903608E-4 11.7837886 15.663852 )
     (-4.03586579 -24.779056 1.85619712 15.663166 -11.3533897 -18.315147 )
     (-7.85636616 -18.273464 -9.4971943 -2.65198326 3.62977982 9.59674836 )
     (-15.538669 -16.127075 -5.86741448 6.9447651 -3.16573143 -2.07184219 )
     (-22.988948 -10.218229 -9.0331459 4.8729229 9.0331459 10.6906147 )
     (-27.505523 1.60187482E-7 0 15.563537 9.0331459 -10.6906128 )
     (-22.988948 10.218231 9.0331459 4.87292385 -3.16573143 2.07184028 )
     (-15.538669 16.127075 5.86741448 6.94476414 3.62977982 -9.59674645 )
     (-7.85636426 18.273464 9.4971943 -2.65198326 -11.3533916 18.315151 )
     (-4.03586579 24.779056 -1.85619783 15.6631679 11.783792 -15.663854 )
     (-1.68045051E-4 32.610298 9.92759515 -6.88414671E-4 -11.781776 -15.659725 )
     (4.03653813 24.779747 -1.854182 -15.660413 11.343313 18.302753 )
     (7.8540144 18.27071 9.4891319 2.64234161 -3.59148312 -9.5512943 )
     (15.547405 16.137405 5.8976488 -6.9089527 3.0226221 1.9024229 )
     (22.956363 10.1796627 8.9202709 -5.0065298 -8.4990101 -10.058395 ))
    PSEUDOCYCLIC))

  ((17
    ((257 5) (271 15) (274 36) (275 54) (274 78) (275 102)
     (274 120) (271 141) (257 151) (243 141) (240 120) (239 102)
     (240 78) (239 54) (240 36) (243 15) (257 5))
    NIL
    ((16.803104 -0.223070144 0.182082086 24.092327 -17.364887 -10.93856 )
     (8.302742 18.399978 -17.1828079 13.153766 19.73196 -23.861171 )
     (0.985916854 19.623157 2.54915523 -10.707405 -7.5629673 22.383258 )
     (-0.246411472 20.107383 -5.01381207 11.6758537 10.519905 -11.671869 )
     (-2.70843506E-4 25.947299 5.50609303 0.00398380961 -10.516653 -11.695772 )
     (0.247495413 20.103397 -5.01056099 -11.6917896 7.54671 22.454963 )
     (-0.989710332 19.639091 2.5361495 10.763174 -19.670185 -24.12408 )
     (-8.28865434 18.340225 -17.134037 -13.360906 17.134037 -9.9586353 )
     (-16.8556709 -1.90734863E-6 0 -23.319541 17.134037 9.95863725 )
     (-8.2886524 -18.340225 17.134037 -13.3609047 -19.670185 24.124076 )
     (-0.989710093 -19.639091 -2.5361495 10.763174 7.54670907 -22.454959 )
     (0.247495472 -20.103401 5.01056004 -11.6917877 -10.516653 11.69577 )
     (-2.70843506E-4 -25.947299 -5.50609303 0.00398329925 10.519903 11.671871 )
     (-0.246411145 -20.107383 5.0138111 11.6758556 -7.56296635 -22.383258 )
     (0.985917092 -19.623157 -2.54915523 -10.707405 19.73196 23.861171 )
     (8.3027439 -18.399974 17.1828079 13.153768 -17.364887 10.9385585 ))
    PSEUDOCYCLIC))))

((FAMILY TIMESROMAND)
 (CHARACTER 46Q)
 (FACE M R R)
 (WIDTH 350 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 14:43:50)
 (MADE-FROM NIL 66 130 35 72)
 (SPLINES

  ((3
    ((218 174) (218 174) (326 174))
    NIL
    ((-27. 0 0 0 162. 0 )
     (54. 0 162. 0 -162. 0 ))
    NATURAL)
   (2
    ((326 174) (326 164))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (5
    ((326 164) (307 154) (289 132) (271 108) (252 83))
    NIL
    ((-19.25 -6.91071416 0 0 1.5 -18.535713 )
     (-18.499996 -16.1785698 1.5 -18.535713 -1.5 20.678569 )
     (-17.75 -24.375 -6.35782838E-8 2.14285707 -1.49999952 -4.17857075 )
     (-18.5 -24.321426 -1.49999976 -2.03571415 1.49999976 2.03571415 ))
    NATURAL)
   (5
    ((252 83) (270 64) (292 46) (315 38) (332 49))
    NIL
    ((17.107139 -18.892856 0 0 5.35714245 -0.642857075 )
     (19.785713 -19.214283 5.35714245 -0.642857075 -2.78571415 9.2142849 )
     (23.75 -15.249998 2.5714283 8.5714283 -12.2142849 17.785709 )
     (20.214283 2.2142868 -9.6428566 26.357139 9.6428566 -26.357139 ))
    NATURAL)
   (3
    ((332 49) (332 49) (342 41))
    NIL
    ((-2.5 2. 0 0 15. -12. )
     (5. -4. 15. -12. -15. 12. ))
    NATURAL)
   (6
    ((342 41) (323 17) (294 -4) (262 -11) (226 -3) (193 22))
    NIL
    ((-16.444973 -24.004783 0 0 -15.3301429 0.0287084579 )
     (-24.110046 -23.990428 -15.3301429 0.0287084579 16.6507149 17.856456 )
     (-31.11483 -15.033491 1.32057380 17.885166 -9.27272607 -5.45454788 )
     (-34.430618 0.124403000 -7.95215226 12.430618 14.440189 9.96172715 )
     (-35.162674 17.5358848 6.48803807 22.392345 -6.48803807 -22.392345 ))
    NATURAL)
   (11
    ((193 22) (161 3) (124 -7) (83 -6) (45 7) (22 29)
     (9 59) (12 94) (32 123) (62 143) (92 157))
    NIL
    ((-30.93714 -20.81504 0 0 -6.37713147 10.8902549 )
     (-34.125709 -15.369913 -6.37713147 10.8902549 1.88565731 -0.451280594 )
     (-39.560012 -4.70529843 -4.49147415 10.438974 4.83450318 2.9148693 )
     (-41.63423 7.19110966 0.343029499 13.3538437 20.776321 -5.2081909 )
     (-30.903041 17.9408569 21.119354 8.14565278 -15.939798 -0.0821170807 )
     (-17.753585 26.045452 5.1795559 8.0635357 12.9828586 -0.463335037 )
     (-6.08260155 33.877319 18.162414 7.60020066 0.00836563111 -16.064537 )
     (12.0839958 33.44525 18.17078 -8.4643383 -7.0163231 -1.27850341 )
     (26.746616 24.341659 11.154457 -9.7428417 -13.943071 3.17855263 )
     (30.929534 16.188095 -2.78861427 -6.5642891 2.78861427 6.5642891 ))
    NATURAL)
   (13
    ((92 157) (78 188) (72 220) (75 249) (94 278) (126 295)
     (168 300) (205 296) (235 278) (247 246) (236 215) (209 192)
     (176 180))
    NIL
    ((-15.753526 30.469062 0 0 10.521162 3.18560314 )
     (-10.4929447 32.061866 10.521162 3.18560314 -4.60581589 -9.92801477 )
     (-2.27469063 30.283462 5.91534615 -6.74241257 13.902105 12.5264606 )
     (10.591711 29.804279 19.817451 5.78404808 -9.0026245 -22.177825 )
     (25.907848 24.499412 10.8148269 -16.393779 4.10840798 4.18486214 )
     (38.776878 10.198061 14.9232349 -12.2089176 -25.431003 5.43837738 )
     (40.98461 0.708333016 -10.5077705 -6.77054024 7.6156225 -7.93837739 )
     (34.284652 -10.0313968 -2.89214802 -14.708917 -17.031482 -3.68486214 )
     (22.876762 -26.582744 -19.923633 -18.393779 -5.4896736 22.677825 )
     (0.208288818 -33.63761 -25.413307 4.28404808 8.9901886 2.97353935 )
     (-20.709922 -27.866794 -16.423118 7.25758744 11.528898 7.42801476 )
     (-31.36859 -16.8951988 -4.8942194 14.685602 4.8942194 -14.685602 ))
    NATURAL)
   (3
    ((176 180) (205 138) (236 100))
    NIL
    ((28.5 -43. 0 0 3. 6. )
     (30. -40. 3. 6. -3. -6. ))
    NATURAL)
   (6
    ((236 100) (241 111) (244 131) (241 148) (230 159) (218 164))
    NIL
    ((5.25358773 8.4593296 0 0 -1.52153110 15.244018 )
     (4.49282265 16.081337 -1.52153110 15.244018 -4.39234448 -22.220092 )
     (0.775119424 20.215309 -5.91387558 -6.97607613 -4.90909004 1.63636398 )
     (-7.5933008 14.057415 -10.8229656 -5.33971215 12.0287056 -2.32535934 )
     (-12.4019127 7.5550232 1.20574140 -7.66507149 -1.20574140 7.66507149 ))
    NATURAL)
   (2
    ((218 164) (218 174))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL))

  ((9
    ((169 197) (179 218) (182 243) (176 269) (158 284) (144 271)
     (144 246) (155 217) (169 197))
    NIL
    ((11.465389 20.08155 0 0 -8.79234124 5.51067734 )
     (7.06921864 22.836891 -8.79234124 5.51067734 1.96170807 -3.55338669 )
     (-0.742268205 26.570873 -6.83063317 1.95729065 -11.054491 -9.29713059 )
     (-13.100147 23.8796 -17.885124 -7.33983994 24.256256 -31.25809 )
     (-18.857139 0.910711766 6.3711338 -38.59793 10.029451 32.32952 )
     (-7.4712801 -21.522457 16.400585 -6.26840878 -4.37407494 -2.06001568 )
     (6.7422676 -28.820873 12.02651 -8.32842446 -10.533136 23.91053 )
     (13.5022087 -25.194034 1.4933722 15.582105 -1.4933722 -15.582105 ))
    NATURAL))

  ((4
    ((100 141) (127 100) (150 68) (177 34))
    NIL
    ((28.333332 -43.533332 0 0 -8. 15.1999988 )
     (24.333332 -35.933326 -8. 15.1999988 16. -21.999996 )
     (24.333332 -31.733333 8. -6.79999924 -8. 6.79999924 ))
    NATURAL)
   (7
    ((177 34) (148 34) (121 43) (100 63) (88 91) (89 119)
     (100 141))
    NIL
    ((-29.224357 -1.76794863 0 0 1.34615397 10.6076927 )
     (-28.55128 3.53589726 1.34615397 10.6076927 5.26922989 0.961536408 )
     (-24.57051 14.624359 6.6153841 11.569229 1.57692241 -2.45384407 )
     (-17.166664 24.966663 8.1923065 9.11538507 6.42307854 -9.1461544 )
     (-5.76282025 29.508972 14.615385 -0.0307693854 -3.2692337 -8.9615364 )
     (7.2179489 24.997432 11.346151 -8.99230767 -11.346151 8.99230767 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 50Q)
 (FACE M R R)
 (WIDTH 162 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 14:49:11)
 (MADE-FROM NIL 142 130 35 72)
 (SPLINES

  ((2
    ((152 300) (143 312))
    NIL
    ((-9. 12. 0 0 0 0 ))
    NATURAL)
   (17
    ((143 312) (122 303) (98 289) (74 268) (51 242) (33 213)
     (22 182) (14 144) (13 112) (14 80) (22 42) (33 11)
     (51 -18) (74 -44) (98 -65) (122 -79) (143 -88))
    NIL
    ((-20.19886 -8.08247376 0 0 -4.80682278 -5.5051546 )
     (-22.602272 -10.8350505 -4.80682278 -5.5051546 6.03411675 -2.47422695 )
     (-24.392036 -17.577316 1.22729444 -7.97938157 -1.32964873 3.40206242 )
     (-23.829566 -23.855667 -0.102354377 -4.57731915 5.28447628 0.865979195 )
     (-21.289684 -28. 5.18212223 -3.71133995 4.19173908 5.13401985 )
     (-14.01169 -29.144329 9.3738613 1.42268037 -10.051439 -15.402059 )
     (-9.6635475 -35.422676 -0.677578807 -13.979379 12.014028 26.474224 )
     (-4.33411217 -36.164947 11.3364505 12.494844 -14.0046749 -12.494842 )
     (1.59256160E-7 -29.917522 -2.66822576 5.11072471E-7 14.0046749 -12.494846 )
     (4.33411217 -36.164947 11.3364505 -12.494846 -12.014028 26.474227 )
     (9.6635475 -35.422676 -0.677578926 13.979381 10.051441 -15.402061 )
     (14.011692 -29.144329 9.3738632 -1.42268037 -4.19174195 5.13401985 )
     (21.289684 -27.999996 5.18212128 3.71133947 -5.28447533 0.865979672 )
     (23.829566 -23.855667 -0.102354094 4.57731915 1.32964825 3.40206146 )
     (24.392036 -17.577316 1.22729420 7.9793806 -6.03411675 -2.474226 )
     (22.602272 -10.8350505 -4.80682278 5.5051546 4.80682278 -5.5051546 ))
    NATURAL)
   (2
    ((143 -88) (152 -76))
    NIL
    ((9. 12. 0 0 0 0 ))
    NATURAL)
   (6
    ((152 -76) (134 -59) (117 -33) (104 3) (97 45) (93 112))
    NIL
    ((-18.081337 15.311004 0 0 0.488038302 10.13397 )
     (-17.837318 20.37799 0.488038302 10.13397 3.55980825 3.33014298 )
     (-15.5693779 32.177032 4.0478468 13.464113 3.27272701 -17.45454 )
     (-9.88516618 36.91387 7.3205738 -3.99043036 -4.65071774 42.488029 )
     (-4.8899517 54.167465 2.66985607 38.497604 -2.66985607 -38.497604 ))
    NATURAL)
   (6
    ((93 112) (97 179) (104 221) (117 257) (134 283) (152 300))
    NIL
    ((3.55502367 73.416259 0 0 2.66985655 -38.497604 )
     (4.8899517 54.167457 2.66985655 -38.497604 4.65071678 42.488029 )
     (9.88516618 36.91387 7.3205738 3.99042988 -3.27272797 -17.45454 )
     (15.5693779 32.177032 4.04784584 -13.464113 -3.5598073 3.33014298 )
     (17.837318 20.377986 0.488038302 -10.13397 -0.488038302 10.13397 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 51Q)
 (FACE M R R)
 (WIDTH 162 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 14:51:46)
 (MADE-FROM NIL 226 130 35 72)
 (SPLINES

  ((17
    ((17 312) (38 303) (62 289) (86 268) (109 242) (127 213)
     (138 182) (146 144) (147 112) (146 80) (138 42) (127 11)
     (109 -18) (86 -44) (62 -65) (38 -79) (17 -88))
    NIL
    ((20.19886 -8.08247376 0 0 4.80682278 -5.5051546 )
     (22.602272 -10.8350505 4.80682278 -5.5051546 -6.03411675 -2.47422695 )
     (24.392036 -17.577316 -1.22729444 -7.97938157 1.32964873 3.40206242 )
     (23.829566 -23.855667 0.102354377 -4.57731915 -5.28447628 0.865979195 )
     (21.289684 -28. -5.18212223 -3.71133995 -4.19173908 5.13401985 )
     (14.01169 -29.144329 -9.3738613 1.42268037 10.051439 -15.402059 )
     (9.6635475 -35.422676 0.677578807 -13.979379 -12.014028 26.474224 )
     (4.33411217 -36.164947 -11.3364505 12.494844 14.0046749 -12.494842 )
     (-1.59256160E-7 -29.917522 2.66822576 5.11072471E-7 -14.0046749 -12.494846 )
     (-4.33411217 -36.164947 -11.3364505 -12.494846 12.014028 26.474227 )
     (-9.6635475 -35.422676 0.677578926 13.979381 -10.051441 -15.402061 )
     (-14.011692 -29.144329 -9.3738632 -1.42268037 4.19174195 5.13401985 )
     (-21.289684 -27.999996 -5.18212128 3.71133947 5.28447533 0.865979672 )
     (-23.829566 -23.855667 0.102354094 4.57731915 -1.32964825 3.40206146 )
     (-24.392036 -17.577316 -1.22729420 7.9793806 6.03411675 -2.474226 )
     (-22.602272 -10.8350505 4.80682278 5.5051546 -4.80682278 -5.5051546 ))
    NATURAL)
   (2
    ((17 -88) (8 -76))
    NIL
    ((-9. 12. 0 0 0 0 ))
    NATURAL)
   (11
    ((8 -76) (26 -59) (43 -33) (56 3) (63 45) (67 112)
     (63 179) (56 221) (43 257) (26 283) (8 300))
    NIL
    ((18.091159 15.311004 0 0 -0.546961427 10.13397 )
     (17.817676 20.37799 -0.546961427 10.13397 -3.2651925 3.33014298 )
     (15.63812 32.177032 -3.81215429 13.464113 -4.39226532 -17.45454 )
     (9.6298332 36.91387 -8.2044201 -3.99043036 8.8342533 42.488029 )
     (5.84254074 54.167465 0.629834295 38.497604 -12.9447498 -38.497604 )
     (-1.99303030E-7 73.416259 -12.3149166 0 12.9447498 -38.497604 )
     (-5.84254074 54.167457 0.629834414 -38.497604 -8.8342533 42.488029 )
     (-9.6298332 36.91387 -8.2044201 3.99043083 4.39226532 -17.454544 )
     (-15.63812 32.177032 -3.81215429 -13.464115 3.26519299 3.33014488 )
     (-17.817676 20.377986 -0.546961308 -10.13397 0.546961308 10.13397 ))
    NATURAL)
   (2
    ((8 300) (17 312))
    NIL
    ((9. 12. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 52Q)
 (FACE M R R)
 (WIDTH 282 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 14:56:10)
 (MADE-FROM NIL 104 130 52 68)
 (SPLINES

  ((2
    ((129 224) (114 288))
    NIL
    ((-15. 64. 0 0 0 0 ))
    NATURAL)
   (2
    ((114 288) (164 288))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((164 288) (149 224))
    NIL
    ((-15. -64. 0 0 0 0 ))
    NATURAL)
   (2
    ((149 224) (198 266))
    NIL
    ((49. 42. 0 0 0 0 ))
    NATURAL)
   (2
    ((198 266) (223 236))
    NIL
    ((25. -30. 0 0 0 0 ))
    NATURAL)
   (2
    ((223 236) (158 208))
    NIL
    ((-65. -28. 0 0 0 0 ))
    NATURAL)
   (2
    ((158 208) (223 180))
    NIL
    ((65. -28. 0 0 0 0 ))
    NATURAL)
   (2
    ((223 180) (198 150))
    NIL
    ((-25. -30. 0 0 0 0 ))
    NATURAL)
   (2
    ((198 150) (149 192))
    NIL
    ((-49. 42. 0 0 0 0 ))
    NATURAL)
   (2
    ((149 192) (164 128))
    NIL
    ((15. -64. 0 0 0 0 ))
    NATURAL)
   (2
    ((164 128) (114 128))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((114 128) (129 192))
    NIL
    ((15. 64. 0 0 0 0 ))
    NATURAL)
   (2
    ((129 192) (80 150))
    NIL
    ((-49. -42. 0 0 0 0 ))
    NATURAL)
   (2
    ((80 150) (55 180))
    NIL
    ((-25. 30. 0 0 0 0 ))
    NATURAL)
   (2
    ((55 180) (120 208))
    NIL
    ((65. 28. 0 0 0 0 ))
    NATURAL)
   (2
    ((120 208) (55 236))
    NIL
    ((-65. 28. 0 0 0 0 ))
    NATURAL)
   (2
    ((55 236) (80 266))
    NIL
    ((25. 30. 0 0 0 0 ))
    NATURAL)
   (2
    ((80 266) (129 224))
    NIL
    ((49. -42. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 55Q)
 (FACE M R R)
 (WIDTH 267 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 14:58:21)
 (MADE-FROM NIL 121 130 101 78)
 (SPLINES

  ((2
    ((213 80) (53 80))
    NIL
    ((-160. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((53 80) (53 140))
    NIL
    ((0 60. 0 0 0 0 ))
    NATURAL)
   (2
    ((53 140) (213 140))
    NIL
    ((160. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((213 140) (213 80))
    NIL
    ((0 -60. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 100Q)
 (FACE M R R)
 (WIDTH 241 0)
 (FIDUCIAL 275 275)
 (VERSION 0  3-OCT-77 15:01:19)
 (MADE-FROM NIL 136 116 118 52)
 (SPLINES

  ((12
    ((158 121) (145 128) (128 130) (110 126) (92 113) (80 98)
     (72 82) (70 63) (74 45) (89 32) (112 29) (133 40))
    NIL
    ((-11.972738 8.0720539 0 0 -6.16356755 -6.43233109 )
     (-15.054521 4.85588837 -6.16356755 -6.43233109 6.8178396 2.16165829 )
     (-17.809169 -0.495613098 0.654272318 -4.2706728 -3.10779333 -8.21430207 )
     (-18.708793 -8.87343789 -2.45352125 -12.4849758 11.6133327 12.6955566 )
     (-15.355648 -15.010633 9.1598129 0.210582316 -7.34554005 -0.567935109 )
     (-9.86860658 -15.084018 1.81427216 -0.357352793 5.76882458 -4.42381764 )
     (-5.16992092 -17.653282 7.58309746 -4.78117085 -3.72976494 6.26320649 )
     (0.548294068 -19.302848 3.85333252 1.48203635 9.15023805 3.37098885 )
     (8.9767456 -16.1353149 13.00357 4.85302544 -2.87118912 4.25283432 )
     (20.544719 -9.15587426 10.132381 9.10585977 -15.6654758 9.61767388 )
     (22.844364 4.75882149 -5.53309536 18.723533 5.53309536 -18.723533 ))
    NATURAL)
   (21
    ((133 40) (140 32) (148 27) (164 25) (191 37) (208 57)
     (219 90) (215 123) (198 146) (174 160) (143 167) (108 164)
     (78 154) (51 134) (31 105) (23 71) (27 43) (43 17)
     (63 2) (88 -4) (112 -1))
    NIL
    ((7.04713917 -8.83371926 0 0 -0.282836199 5.00231648 )
     (6.9057207 -6.33256055 -0.282836199 5.00231648 7.41418076 -7.01158429 )
     (10.329975 -4.83603668 7.1313448 -2.00926781 12.626108 23.044021 )
     (23.774375 4.67670918 19.757453 21.034755 -39.918617 -19.16452 )
     (23.572517 16.1292038 -20.161163 1.8702321 21.04837 17.614074 )
     (13.935541 26.806472 0.887209058 19.48431 -20.274875 -21.291782 )
     (4.68531037 35.644889 -19.387668 -1.8074727 6.05114175 -10.446945 )
     (-11.676788 28.613945 -13.3365268 -12.254419 8.0703125 3.0795784 )
     (-20.978157 17.8993149 -5.26621437 -9.1748409 -2.33239746 4.12862969 )
     (-27.410572 10.7887878 -7.59861184 -5.04621125 1.25927829 -7.59409905 )
     (-34.379539 1.94552779 -6.33933354 -12.64031 15.29528 8.24776269 )
     (-33.071235 -6.5709009 8.95594789 -4.39254666 -8.4404068 -7.39695454 )
     (-28.335495 -14.661924 0.515540362 -11.789501 6.46634865 3.34005737 )
     (-24.586776 -24.781395 6.98188973 -8.4494438 6.57500649 0.0367221832 )
     (-14.3173847 -33.212478 13.556896 -8.41272164 -2.76637268 20.51305 )
     (-2.1436758 -31.368675 10.7905235 12.10033 4.49048424 -16.0889358 )
     (10.8920898 -27.312812 15.2810077 -3.9886055 -15.195562 19.842693 )
     (18.575313 -21.380069 0.0854441673 15.854089 8.29176904 -9.281847 )
     (22.806644 -10.1669025 8.37721444 6.57224274 -11.971517 5.28469467 )
     (25.1981 -0.952312470 -3.5943036 11.856937 3.5943036 -11.856937 ))
    NATURAL)
   (2
    ((112 -1) (107 19))
    NIL
    ((-5. 20. 0 0 0 0 ))
    NATURAL)
   (18
    ((107 19) (86 18) (66 26) (50 47) (45 71) (49 95)
     (63 118) (83 134) (107 143) (136 146) (165 142) (186 130)
     (199 110) (200 86) (192 68) (184 59) (172 52) (162 56))
    NIL
    ((-21.157852 -2.53653526 0 0 0.947122574 9.21921159 )
     (-20.684291 2.07307052 0.947122574 9.21921159 1.26438713 7.9039421 )
     (-19.104972 15.244255 2.2115097 17.123153 11.9953289 -16.834991 )
     (-10.8958015 23.949909 14.206838 0.288160145 -7.24570466 -0.563958168 )
     (-0.311814904 23.956092 6.96113396 -0.275798023 4.9874878 1.09082985 )
     (9.1430626 24.225708 11.9486217 0.815032006 -6.70424843 -9.79936029 )
     (17.739559 20.141059 5.24437332 -8.9843292 -2.17049026 2.10661602 )
     (21.898689 12.210039 3.07388306 -6.8777132 3.38620949 1.37289524 )
     (26.665676 6.01877404 6.46009255 -5.50481797 -5.37434674 -1.59819507 )
     (30.438594 -0.285140633 1.08574557 -7.10301304 -11.8888187 -0.980116845 )
     (25.579929 -7.87821198 -10.8030738 -8.08312989 4.92962837 -0.481334686 )
     (17.241668 -16.202007 -5.8734455 -8.56446458 -7.82969475 2.90545654 )
     (7.4533777 -23.313743 -13.70314 -5.65900803 2.38915062 12.859506 )
     (-5.05518723 -22.542999 -11.3139896 7.20049954 16.273094 5.65650845 )
     (-8.23262979 -12.514246 4.95910454 12.8570079 -13.481531 -17.485542 )
     (-10.0142917 -8.40000917 -8.5224266 -4.62853527 13.653032 22.285663 )
     (-11.710201 -1.88571024 5.13060665 17.657131 -5.13060665 -17.657131 ))
    NATURAL)
   (5
    ((162 56) (178 116) (178 126) (168 126) (158 121))
    NIL
    ((19.571426 72.76785 0 0 -21.428569 -76.60713 )
     (8.8571415 34.464279 -21.428569 -76.60713 11.1428566 83.03569 )
     (-7. -0.624999643 -10.285713 6.42857075 12.857141 -15.535713 )
     (-10.857141 -1.96428537 2.5714283 -9.1071434 -2.5714283 9.1071434 ))
    NATURAL))

  ((10
    ((140 100) (136 107) (124 107) (108 95) (100 75) (104 56)
     (118 54) (128 64) (136 84) (140 100))
    NIL
    ((-2.25083256 8.15301515 0 0 -10.4950046 -6.9180908 )
     (-7.49833489 4.69396878 -10.4950046 -6.9180908 4.47502804 -7.409544 )
     (-15.7558269 -5.92889405 -6.0199766 -14.3276348 16.59489 6.55626965 )
     (-13.478355 -16.978393 10.5749149 -7.77136517 1.14539718 5.1844616 )
     (-2.33074379 -22.157527 11.720312 -2.58690309 2.82352638 26.705879 )
     (10.8013305 -11.391489 14.543838 24.118976 -24.439506 -16.007988 )
     (13.1254139 4.72349262 -9.89566995 8.1109867 10.934515 7.32608224 )
     (8.6970024 16.49752 1.03884577 15.4370689 -7.29855633 -25.296333 )
     (6.08656979 19.286418 -6.25971127 -9.85926629 6.25971127 9.85926629 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 134Q)
 (FACE M R R)
 (WIDTH 312 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 15:06:12)
 (MADE-FROM NIL 60 130 27 74)
 (SPLINES

  ((2
    ((241 0) (33 294))
    NIL
    ((-208. 294. 0 0 0 0 ))
    NATURAL)
   (2
    ((33 294) (65 294))
    NIL
    ((32. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((65 294) (273 0))
    NIL
    ((208. -294. 0 0 0 0 ))
    NATURAL)
   (2
    ((273 0) (241 0))
    NIL
    ((-32. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 176Q)
 (FACE M R R)
 (WIDTH 223 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 15:07:05)
 (MADE-FROM NIL 90 130 59 73)
 (SPLINES

  ((2
    ((146 200) (186 200))
    NIL
    ((40. 0 0 0 0 0 ))
    NATURAL)
   (12
    ((186 200) (184 188) (181 173) (173 156) (162 146) (149 142)
     (133 141) (115 147) (101 154) (87 157) (77 151) (74 143))
    NIL
    ((-2.0406394 -11.4451789 0 0 0.243838072 -3.3289156 )
     (-1.91872048 -13.109638 0.243838072 -3.3289156 -7.21918965 -1.35542106 )
     (-5.28447724 -17.116264 -6.97535229 -4.68433666 4.63292313 14.7505989 )
     (-9.943367 -14.4253 -2.34242868 10.066263 0.687495947 -3.64697933 )
     (-11.942049 -6.18252755 -1.65493273 6.41928387 -1.38290715 -6.1626854 )
     (-14.288435 -2.84458589 -3.03783989 0.256598294 -1.15586662 10.2977218 )
     (-17.904209 2.5608735 -4.1937065 10.554321 12.006374 -11.0282058 )
     (-16.094726 7.60109139 7.81266785 -0.473885357 -10.8696327 -2.18489456 )
     (-13.716875 6.03475857 -3.05696487 -2.6587801 7.47215558 -10.23221 )
     (-13.037763 -1.74012756 4.4151907 -12.890991 4.98101139 13.113739 )
     (-6.13206673 -8.07424928 9.3962021 0.222748071 -9.3962021 -0.222748071 ))
    NATURAL)
   (2
    ((74 143) (34 143))
    NIL
    ((-40. 0 0 0 0 0 ))
    NATURAL)
   (12
    ((34 143) (36 155) (39 170) (47 187) (58 197) (71 201)
     (87 202) (105 196) (119 189) (133 186) (143 192) (146 200))
    NIL
    ((2.0406394 11.4451789 0 0 -0.243838072 3.3289156 )
     (1.91872048 13.109638 -0.243838072 3.3289156 7.21918965 1.35542106 )
     (5.28447724 17.116264 6.97535229 4.68433666 -4.63292313 -14.7505989 )
     (9.943367 14.4253 2.34242868 -10.066263 -0.687495947 3.64697933 )
     (11.942049 6.18252755 1.65493273 -6.41928387 1.38290715 6.1626854 )
     (14.288435 2.84458589 3.03783989 -0.256598294 1.15586662 -10.2977218 )
     (17.904209 -2.5608735 4.1937065 -10.554321 -12.006374 11.0282058 )
     (16.094726 -7.60109139 -7.81266785 0.473885357 10.8696327 2.18489456 )
     (13.716875 -6.03475857 3.05696487 2.6587801 -7.47215558 10.23221 )
     (13.037763 1.74012756 -4.4151907 12.890991 -4.98101139 -13.113739 )
     (6.13206673 8.07424928 -9.3962021 -0.222748071 9.3962021 0.222748071 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 30Q)
 (FACE M R R)
 (WIDTH 490 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 15:10:26)
 (MADE-FROM NIL 13 131 0 0)
 (SPLINES

  ((2
    ((0 -53) (489 -53))
    NIL
    ((489. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((489 -53) (489 -93))
    NIL
    ((0 -40. 0 0 0 0 ))
    NATURAL)
   (2
    ((489 -93) (0 -93))
    NIL
    ((-489. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((0 -93) (0 -53))
    NIL
    ((0 40. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 40Q)
 (FACE M R R)
 (WIDTH 312 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 15:11:15)
 (MADE-FROM NIL 142 130 0 0)
 (SPLINES))

((FAMILY TIMESROMAND)
 (CHARACTER 53Q)
 (FACE M R R)
 (WIDTH 327 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:36:02)
 (MADE-FROM NIL 122 130 68 75)
 (SPLINES

  ((2
    ((132 0) (192 0))
    NIL
    ((60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((192 0) (192 80))
    NIL
    ((0 80. 0 0 0 0 ))
    NATURAL)
   (2
    ((192 80) (272 80))
    NIL
    ((80. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((272 80) (272 140))
    NIL
    ((0 60. 0 0 0 0 ))
    NATURAL)
   (2
    ((272 140) (192 140))
    NIL
    ((-80. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((192 140) (192 220))
    NIL
    ((0 80. 0 0 0 0 ))
    NATURAL)
   (2
    ((192 220) (132 220))
    NIL
    ((-60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((132 220) (132 140))
    NIL
    ((0 -80. 0 0 0 0 ))
    NATURAL)
   (2
    ((132 140) (52 140))
    NIL
    ((-80. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((52 140) (52 80))
    NIL
    ((0 -60. 0 0 0 0 ))
    NATURAL)
   (2
    ((52 80) (132 80))
    NIL
    ((80. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((132 80) (132 0))
    NIL
    ((0 -80. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 75Q)
 (FACE M R R)
 (WIDTH 267 0)
 (FIDUCIAL 385 385)
 (VERSION 0  4-OCT-77  9:36:52)
 (MADE-FROM NIL 120 130 84 94)
 (SPLINES

  ((2
    ((214 40) (54 40))
    NIL
    ((-160. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((54 40) (54 100))
    NIL
    ((0 60. 0 0 0 0 ))
    NATURAL)
   (2
    ((54 100) (214 100))
    NIL
    ((160. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((214 100) (214 40))
    NIL
    ((0 -60. 0 0 0 0 ))
    NATURAL))

  ((2
    ((54 140) (54 200))
    NIL
    ((0 60. 0 0 0 0 ))
    NATURAL)
   (2
    ((54 200) (214 200))
    NIL
    ((160. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((214 200) (214 140))
    NIL
    ((0 -60. 0 0 0 0 ))
    NATURAL)
   (2
    ((214 140) (54 140))
    NIL
    ((-160. 0 0 0 0 0 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.S3-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.S3-SF
deleted file mode 100644
index 0185738c..00000000
--- a/obsolete/lispusers/splinefonts/TIMESROMAN.S3-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY TIMESROMAND)
 (CHARACTER 56Q)
 (FACE M R R)
 (WIDTH 168 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:21:11)
 (MADE-FROM NIL 201 130 35 72)
 (SPLINES

  ((17
    ((86 -6) (67 -3) (52 4) (44 13) (41 27) (44 41)
     (52 50) (67 57) (86 60) (105 57) (120 50) (128 41)
     (131 27) (128 13) (120 4) (105 -3) (86 -6))
    NIL
    ((-19.639171 1.98203754 0 0 3.83505154 6.10777474 )
     (-17.721649 5.0359249 3.83505154 6.10777474 4.82474232 -6.53887368 )
     (-11.474226 7.87426186 8.65979386 -0.431099415 -5.1340208 8.04772187 )
     (-5.38144303 11.4670238 3.52577257 7.6166229 3.71134043 -7.65201569 )
     (8.00937414E-8 15.2576389 7.237113 -0.0353937074 -3.71133947 -7.43965436 )
     (5.38144303 11.5024166 3.52577353 -7.47504807 5.13401795 7.41063786 )
     (11.474226 7.73268796 8.65979196 -0.0644102097 -4.8247404 -4.20289994 )
     (17.721649 5.5668268 3.83505154 -4.26731014 -3.83505106 -2.59903431 )
     (19.639171 0 1.27768117E-7 -6.86634446 -3.835052 2.59903335 )
     (17.721649 -5.56682778 -3.835052 -4.2673111 -4.82473946 4.20290089 )
     (11.474226 -7.73268796 -8.65979196 -0.0644097030 5.1340189 -7.4106388 )
     (5.38144303 -11.5024166 -3.52577305 -7.475049 -3.71133995 7.4396553 )
     (-1.59256160E-7 -15.2576389 -7.237113 -0.0353935584 3.71133995 7.65201569 )
     (-5.38144303 -11.4670238 -3.52577305 7.6166229 -5.1340208 -8.04772187 )
     (-11.474226 -7.87426186 -8.65979386 -0.431099653 4.82474232 6.53887368 )
     (-17.721649 -5.0359249 -3.83505154 6.10777474 3.83505154 -6.10777474 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 72Q)
 (FACE M R R)
 (WIDTH 168 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:22:34)
 (MADE-FROM NIL 201 130 35 72)
 (SPLINES

  ((17
    ((86 205) (67 202) (52 195) (44 186) (41 172) (44 158)
     (52 149) (67 142) (86 139) (105 142) (120 149) (128 158)
     (131 172) (128 186) (120 195) (105 202) (86 205))
    NIL
    ((-19.818656 -0.00128221511 0.621745348 -6.86153794 3.04670906 2.59230709 )
     (-17.673553 -5.5666666 3.66845465 -4.26923085 5.0359783 4.20769406 )
     (-11.487112 -7.73204995 8.70443345 -0.0615364760 -5.19062138 -7.4230852 )
     (-5.37798977 -11.5051288 3.51381207 -7.484622 3.72650528 7.48464394 )
     (-9.24904831E-4 -15.2474289 7.24031735 2.27427262E-5 -3.7154026 7.48450757 )
     (5.38169098 -11.5051517 3.52491474 7.48453046 5.13510609 -7.42267228 )
     (11.474159 -7.7319584 8.6600208 0.0618574098 -4.8250265 4.20618153 )
     (17.721668 -5.56700897 3.83499432 4.2680397 -3.83499432 2.59793949 )
     (19.6391639 3.18512320E-7 0 6.8659792 -3.83499432 -2.59793949 )
     (17.721668 5.56700993 -3.83499432 4.2680397 -4.82502842 -4.20618153 )
     (11.474159 7.7319584 -8.66002275 0.0618574098 5.135108 7.4226713 )
     (5.38169098 11.5051517 -3.52491427 7.4845295 -3.71540403 -7.4845066 )
     (-9.25144181E-4 15.2474289 -7.2403183 2.27427262E-5 3.72650576 -7.48464299 )
     (-5.37798977 11.5051288 -3.51381254 -7.48462105 -5.1906185 7.42308427 )
     (-11.487112 7.73204995 -8.70443154 -0.0615367144 5.03597546 -4.20769406 )
     (-17.673553 5.5666666 -3.6684556 -4.26923085 3.04671001 -2.59230709 ))
    PSEUDOCYCLIC))

  ((17
    ((86 -6) (67 -3) (52 4) (44 13) (41 27) (44 41)
     (52 50) (67 57) (86 60) (105 57) (120 50) (128 41)
     (131 27) (128 13) (120 4) (105 -3) (86 -6))
    NIL
    ((-19.818656 0.00128221511 0.621745348 6.86153794 3.04670906 -2.59230709 )
     (-17.673553 5.5666666 3.66845465 4.26923085 5.0359783 -4.20769406 )
     (-11.487112 7.73204995 8.70443345 0.0615364760 -5.19062138 7.4230852 )
     (-5.37798977 11.5051288 3.51381207 7.484622 3.72650528 -7.48464394 )
     (-9.24904831E-4 15.2474289 7.24031735 -2.27427262E-5 -3.7154026 -7.48450757 )
     (5.38169098 11.5051517 3.52491474 -7.48453046 5.13510609 7.42267228 )
     (11.474159 7.7319584 8.6600208 -0.0618574098 -4.8250265 -4.20618153 )
     (17.721668 5.56700897 3.83499432 -4.2680397 -3.83499432 -2.59793949 )
     (19.6391639 -3.18512320E-7 0 -6.8659792 -3.83499432 2.59793949 )
     (17.721668 -5.56700993 -3.83499432 -4.2680397 -4.82502842 4.20618153 )
     (11.474159 -7.7319584 -8.66002275 -0.0618574098 5.135108 -7.4226713 )
     (5.38169098 -11.5051517 -3.52491427 -7.4845295 -3.71540403 7.4845066 )
     (-9.25144181E-4 -15.2474289 -7.2403183 -2.27427262E-5 3.72650576 7.48464299 )
     (-5.37798977 -11.5051288 -3.51381254 7.48462105 -5.1906185 -7.42308427 )
     (-11.487112 -7.73204995 -8.70443154 0.0615367144 5.03597546 4.20769406 )
     (-17.673553 -5.5666666 -3.6684556 4.26923085 3.04671001 2.59230709 ))
    PSEUDOCYCLIC))))

((FAMILY TIMESROMAND)
 (CHARACTER 73Q)
 (FACE M R R)
 (WIDTH 168 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:26:06)
 (MADE-FROM NIL 201 130 35 72)
 (SPLINES

  ((17
    ((86 205) (67 202) (52 195) (44 186) (41 172) (44 158)
     (52 149) (67 142) (86 139) (105 142) (120 149) (128 158)
     (131 172) (128 186) (120 195) (105 202) (86 205))
    NIL
    ((-19.818656 -0.00128221511 0.621745348 -6.86153794 3.04670906 2.59230709 )
     (-17.673553 -5.5666666 3.66845465 -4.26923085 5.0359783 4.20769406 )
     (-11.487112 -7.73204995 8.70443345 -0.0615364760 -5.19062138 -7.4230852 )
     (-5.37798977 -11.5051288 3.51381207 -7.484622 3.72650528 7.48464394 )
     (-9.24904831E-4 -15.2474289 7.24031735 2.27427262E-5 -3.7154026 7.48450757 )
     (5.38169098 -11.5051517 3.52491474 7.48453046 5.13510609 -7.42267228 )
     (11.474159 -7.7319584 8.6600208 0.0618574098 -4.8250265 4.20618153 )
     (17.721668 -5.56700897 3.83499432 4.2680397 -3.83499432 2.59793949 )
     (19.6391639 3.18512320E-7 0 6.8659792 -3.83499432 -2.59793949 )
     (17.721668 5.56700993 -3.83499432 4.2680397 -4.82502842 -4.20618153 )
     (11.474159 7.7319584 -8.66002275 0.0618574098 5.135108 7.4226713 )
     (5.38169098 11.5051517 -3.52491427 7.4845295 -3.71540403 -7.4845066 )
     (-9.25144181E-4 15.2474289 -7.2403183 2.27427262E-5 3.72650576 -7.48464299 )
     (-5.37798977 11.5051288 -3.51381254 -7.48462105 -5.1906185 7.42308427 )
     (-11.487112 7.73204995 -8.70443154 -0.0615367144 5.03597546 -4.20769406 )
     (-17.673553 5.5666666 -3.6684556 -4.26923085 3.04671001 -2.59230709 ))
    PSEUDOCYCLIC))

  ((24
    ((92 -4) (78 -6) (59 -3) (44 4) (36 13) (33 27)
     (36 41) (44 50) (59 57) (78 60) (101 58) (121 49)
     (135 33) (140 6) (134 -19) (114 -44) (94 -58) (75 -66)
     (52 -73) (44 -70) (50 -63) (69 -50) (85 -29) (92 -4))
    NIL
    ((-12.4890136 -3.06699467 0 0 -9.06590844 6.4019699 )
     (-17.0219688 0.133990109 -9.06590844 6.4019699 15.3295459 -2.0098505 )
     (-18.423103 5.53103447 6.26363755 4.3921194 1.74772072 -4.3625698 )
     (-11.285606 7.74186898 8.01135827 0.0295492597 -4.3204298 7.4601326 )
     (-5.4344635 11.5014858 3.69092798 7.4896822 3.53399801 -7.47796345 )
     (0.0234638825 15.2521858 7.224926 0.0117186158 -3.8155613 -7.548275 )
     (5.3406086 11.489765 3.4093647 -7.5365572 5.7282505 7.67106915 )
     (11.614099 7.78874398 9.1376152 0.134512752 -7.0974474 -5.13600445 )
     (17.202991 5.35525418 2.04016733 -5.0014925 4.6615448 0.872951508 )
     (21.573928 0.790237070 6.7017126 -4.128541 -11.5487308 -4.35579968 )
     (22.501277 -5.51620388 -4.8470192 -8.48434068 -0.466615677 4.55025006 )
     (17.4209518 -11.72542 -5.31363487 -3.93409014 -4.58480644 -13.845201 )
     (9.8149128 -22.582111 -9.8984413 -17.779293 0.805843354 26.830558 )
     (0.319392502 -26.946125 -9.09259797 9.0512676 -10.638561 -15.4770488 )
     (-14.092487 -25.63338 -19.731159 -6.4257822 23.748405 23.07764 )
     (-21.94944 -20.520339 4.0172472 16.651859 -0.355079651 -10.8335209 )
     (-18.109733 -9.28524209 3.66216755 5.81833744 -16.328083 -9.74355317 )
     (-22.61161 -8.33868218 -12.665918 -3.9252162 35.667419 19.807739 )
     (-17.443813 -2.36002731 23.001506 15.882526 -12.341625 -15.487413 )
     (-0.613120318 5.77879143 10.6598816 0.395112217 7.6990776 6.14191056 )
     (13.896299 9.2448597 18.358959 6.53702355 -24.454681 2.91976929 )
     (20.027915 17.2417679 -6.09572316 9.4567928 -5.88034535 -5.8209915 )
     (10.9920215 23.788063 -11.976068 3.63580132 11.976068 -3.63580132 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 54Q)
 (FACE M R R)
 (WIDTH 168 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:27:04)
 (MADE-FROM NIL 201 130 35 72)
 (SPLINES

  ((24
    ((92 -4) (78 -6) (59 -3) (44 4) (36 13) (33 27)
     (36 41) (44 50) (59 57) (78 60) (101 58) (121 49)
     (135 33) (140 6) (134 -19) (114 -44) (94 -58) (75 -66)
     (52 -73) (44 -70) (50 -63) (69 -50) (85 -29) (92 -4))
    NIL
    ((-12.4890136 -3.06699467 0 0 -9.06590844 6.4019699 )
     (-17.0219688 0.133990109 -9.06590844 6.4019699 15.3295459 -2.0098505 )
     (-18.423103 5.53103447 6.26363755 4.3921194 1.74772072 -4.3625698 )
     (-11.285606 7.74186898 8.01135827 0.0295492597 -4.3204298 7.4601326 )
     (-5.4344635 11.5014858 3.69092798 7.4896822 3.53399801 -7.47796345 )
     (0.0234638825 15.2521858 7.224926 0.0117186158 -3.8155613 -7.548275 )
     (5.3406086 11.489765 3.4093647 -7.5365572 5.7282505 7.67106915 )
     (11.614099 7.78874398 9.1376152 0.134512752 -7.0974474 -5.13600445 )
     (17.202991 5.35525418 2.04016733 -5.0014925 4.6615448 0.872951508 )
     (21.573928 0.790237070 6.7017126 -4.128541 -11.5487308 -4.35579968 )
     (22.501277 -5.51620388 -4.8470192 -8.48434068 -0.466615677 4.55025006 )
     (17.4209518 -11.72542 -5.31363487 -3.93409014 -4.58480644 -13.845201 )
     (9.8149128 -22.582111 -9.8984413 -17.779293 0.805843354 26.830558 )
     (0.319392502 -26.946125 -9.09259797 9.0512676 -10.638561 -15.4770488 )
     (-14.092487 -25.63338 -19.731159 -6.4257822 23.748405 23.07764 )
     (-21.94944 -20.520339 4.0172472 16.651859 -0.355079651 -10.8335209 )
     (-18.109733 -9.28524209 3.66216755 5.81833744 -16.328083 -9.74355317 )
     (-22.61161 -8.33868218 -12.665918 -3.9252162 35.667419 19.807739 )
     (-17.443813 -2.36002731 23.001506 15.882526 -12.341625 -15.487413 )
     (-0.613120318 5.77879143 10.6598816 0.395112217 7.6990776 6.14191056 )
     (13.896299 9.2448597 18.358959 6.53702355 -24.454681 2.91976929 )
     (20.027915 17.2417679 -6.09572316 9.4567928 -5.88034535 -5.8209915 )
     (10.9920215 23.788063 -11.976068 3.63580132 11.976068 -3.63580132 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 7Q)
 (FACE M R R)
 (WIDTH 168 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:31:50)
 (MADE-FROM NIL 142 130 35 72)
 (SPLINES

  ((24
    ((80 228) (94 230) (113 227) (128 220) (136 211) (139 197)
     (136 183) (128 174) (113 167) (94 164) (71 166) (51 175)
     (37 191) (31 218) (38 243) (58 268) (78 282) (97 290)
     (120 297) (128 294) (122 287) (103 274) (87 253) (80 228))
    NIL
    ((12.4890136 3.06699467 0 0 9.06591035 -6.4019699 )
     (17.0219688 -0.133990109 9.06591035 -6.4019699 -15.329553 2.0098505 )
     (18.423103 -5.53103447 -6.26364327 -4.3921194 -1.74769401 4.3625698 )
     (11.285612 -7.74186898 -8.01133729 -0.0295492597 4.32033539 -7.4601326 )
     (5.43444157 -11.5014858 -3.69100189 -7.4896822 -3.53364849 7.47796345 )
     (-0.0233840942 -15.2521858 -7.22465039 -0.0117186158 3.81425572 7.548275 )
     (-5.34090615 -11.489765 -3.41039467 7.5365572 -5.7233753 -7.67106915 )
     (-11.612989 -7.78874398 -9.13377 -0.134512752 7.07924843 5.13600445 )
     (-17.207134 -5.35525418 -2.05452156 5.0014925 -4.59362126 -0.872951508 )
     (-21.558467 -0.790237070 -6.6481428 4.128541 11.2952366 4.35579968 )
     (-22.55899 5.51620388 4.64709378 8.48434068 1.4126749 -4.55025006 )
     (-17.205558 11.72542 6.05976868 3.93409014 1.05406284 13.845201 )
     (-10.618759 22.582111 7.1138315 17.779293 6.3710699 -26.830558 )
     (-0.319392502 26.946125 13.484901 -9.0512676 3.46165085 15.4770488 )
     (14.896333 25.63338 16.946552 6.4257822 -20.217666 -23.07764 )
     (21.73405 20.520339 -3.2711153 -16.651859 -0.590978146 10.8335209 )
     (18.167446 9.28524209 -3.86209345 -5.81833744 16.581581 9.74355317 )
     (22.596145 8.33868218 12.719488 3.9252162 -35.735343 -19.807739 )
     (17.447956 2.36002731 -23.015861 -15.882526 12.359827 15.487413 )
     (0.612009645 -5.77879143 -10.656034 -0.395112217 -7.7039547 -6.14191056 )
     (-13.8960018 -9.2448597 -18.359989 -6.53702355 24.455986 -2.91976929 )
     (-20.027996 -17.2417679 6.09599686 -9.4567928 5.88000298 5.8209915 )
     (-10.9919986 -23.788063 11.9759998 -3.63580132 -11.9759998 3.63580132 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 47Q)
 (FACE M R R)
 (WIDTH 168 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:37:31)
 (MADE-FROM NIL 201 130 35 72)
 (SPLINES

  ((24
    ((92 236) (85 211) (69 190) (50 177) (44 170) (52 167)
     (75 174) (94 182) (114 196) (134 221) (140 246) (135 273)
     (121 289) (101 298) (78 300) (59 297) (44 290) (36 281)
     (33 267) (36 253) (44 244) (59 237) (78 234) (92 236))
    NIL
    ((-5.00398827 -25.605964 0 0 -11.976068 3.63580179 )
     (-10.992023 -23.788063 -11.976068 3.63580179 5.8803463 5.82099056 )
     (-20.027915 -17.2417679 -6.0957222 9.4567928 24.454681 -2.91976929 )
     (-13.896299 -9.2448597 18.358959 6.53702355 -7.6990757 -6.1419115 )
     (0.613121629 -5.77879143 10.659883 0.395111680 12.341619 15.487413 )
     (17.443817 2.36002684 23.001503 15.882526 -35.667419 -19.807739 )
     (22.61161 8.33868218 -12.665918 -3.9252162 16.328083 9.74355508 )
     (18.109733 9.28524209 3.66216755 5.81833935 0.355080604 10.8335189 )
     (21.949443 20.520343 4.01724816 16.651859 -23.748405 -23.07764 )
     (14.092485 25.63338 -19.731159 -6.4257822 10.638561 15.4770488 )
     (-0.319393754 26.946125 -9.09259797 9.0512676 -0.805843354 -26.830555 )
     (-9.8149128 22.582111 -9.8984413 -17.779289 4.58480644 13.8451976 )
     (-17.4209518 11.72542 -5.31363487 -3.93409157 0.466615677 -4.5502491 )
     (-22.501277 5.51620293 -4.8470192 -8.48434068 11.5487308 4.35579968 )
     (-21.573928 -0.790237547 6.7017126 -4.128541 -4.6615448 -0.872951508 )
     (-17.202991 -5.35525418 2.04016733 -5.0014925 7.0974493 5.1360054 )
     (-11.614099 -7.78874398 9.1376171 0.134513020 -5.72825337 -7.67107106 )
     (-5.3406086 -11.489765 3.40936375 -7.53655816 3.81556225 7.54827595 )
     (-0.0234634876 -15.2521858 7.224926 0.0117186382 -3.53399706 7.4779644 )
     (5.4344635 -11.5014858 3.69092894 7.48968316 4.32042694 -7.46013356 )
     (11.285606 -7.74186898 8.01135636 0.0295491926 -1.74771785 4.3625698 )
     (18.423103 -5.53103447 6.2636385 4.3921194 -15.3295479 2.0098505 )
     (17.0219688 -0.133989960 -9.06591035 6.4019699 9.06591035 -6.4019699 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 42Q)
 (FACE M R R)
 (WIDTH 303 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:38:40)
 (MADE-FROM NIL 24 130 0 0)
 (SPLINES

  ((8
    ((211 300) (191 297) (175 289) (168 275) (170 252) (180 223)
     (191 189) (198 168))
    NIL
    ((-20.560287 -1.93747854 0 0 3.36173153 -6.37512875 )
     (-18.879421 -5.1250429 3.36173153 -6.37512875 7.19134236 1.87564373 )
     (-11.922018 -10.562349 10.5530738 -4.49948502 -2.1271038 -7.1274452 )
     (-2.43249702 -18.6255569 8.42597009 -11.62693 1.31707191 8.63414384 )
     (6.65200997 -25.935417 9.743042 -2.99278593 -9.14118577 -9.4091358 )
     (11.824457 -33.632766 0.601855278 -12.401922 -6.75231934 35.002395 )
     (9.05015374 -28.533493 -6.15046406 22.600479 6.15046406 -22.600479 ))
    NATURAL)
   (2
    ((198 168) (224 168))
    NIL
    ((26. 0 0 0 0 0 ))
    NATURAL)
   (8
    ((224 168) (231 189) (242 223) (252 252) (254 275) (247 289)
     (231 297) (211 300))
    NIL
    ((5.97492218 17.233253 0 0 6.1504631 22.600479 )
     (9.05015374 28.533493 6.1504631 22.600479 -6.75231839 -35.002395 )
     (11.824457 33.632766 -0.601855397 -12.401922 -9.14118577 9.4091358 )
     (6.652009 25.935417 -9.743042 -2.99278593 1.31707191 -8.63414575 )
     (-2.4324975 18.6255569 -8.42597009 -11.626932 -2.1271038 7.12744809 )
     (-11.9220199 10.562349 -10.5530738 -4.49948406 7.19134236 -1.87564468 )
     (-18.879421 5.1250429 -3.36173153 -6.37512875 3.36173153 6.37512875 ))
    NATURAL))

  ((8
    ((91 300) (71 297) (55 289) (48 275) (50 252) (60 223)
     (71 189) (78 168))
    NIL
    ((-20.560287 -1.93747854 0 0 3.36173153 -6.37512875 )
     (-18.879421 -5.1250429 3.36173153 -6.37512875 7.19134236 1.87564373 )
     (-11.922018 -10.562349 10.5530738 -4.49948502 -2.1271038 -7.1274452 )
     (-2.43249702 -18.6255569 8.42597009 -11.62693 1.31707191 8.63414384 )
     (6.65200997 -25.935417 9.743042 -2.99278593 -9.14118577 -9.4091358 )
     (11.824457 -33.632766 0.601855278 -12.401922 -6.75231934 35.002395 )
     (9.05015374 -28.533493 -6.15046406 22.600479 6.15046406 -22.600479 ))
    NATURAL)
   (2
    ((78 168) (104 168))
    NIL
    ((26. 0 0 0 0 0 ))
    NATURAL)
   (8
    ((104 168) (111 189) (122 223) (132 252) (134 275) (127 289)
     (111 297) (91 300))
    NIL
    ((5.97492218 17.233253 0 0 6.1504631 22.600479 )
     (9.05015374 28.533493 6.1504631 22.600479 -6.75231839 -35.002395 )
     (11.824457 33.632766 -0.601855397 -12.401922 -9.14118577 9.4091358 )
     (6.652009 25.935417 -9.743042 -2.99278593 1.31707191 -8.63414575 )
     (-2.4324975 18.6255569 -8.42597009 -11.626932 -2.1271038 7.12744809 )
     (-11.9220199 10.562349 -10.5530738 -4.49948406 7.19134236 -1.87564468 )
     (-18.879421 5.1250429 -3.36173153 -6.37512875 3.36173153 6.37512875 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 57Q)
 (FACE M R R)
 (WIDTH 312 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:41:07)
 (MADE-FROM NIL 117 130 0 0)
 (SPLINES

  ((2
    ((35 0) (67 0))
    NIL
    ((32. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((67 0) (270 294))
    NIL
    ((203. 294. 0 0 0 0 ))
    NATURAL)
   (2
    ((270 294) (238 294))
    NIL
    ((-32. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((238 294) (35 0))
    NIL
    ((-203. -294. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 74Q)
 (FACE M R R)
 (WIDTH 267 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:44:20)
 (MADE-FROM NIL 88 130 0 0)
 (SPLINES

  ((2
    ((166 0) (38 147))
    NIL
    ((-128. 147. 0 0 0 0 ))
    NATURAL)
   (2
    ((38 147) (166 294))
    NIL
    ((128. 147. 0 0 0 0 ))
    NATURAL)
   (2
    ((166 294) (226 294))
    NIL
    ((60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((226 294) (98 147))
    NIL
    ((-128. -147. 0 0 0 0 ))
    NATURAL)
   (2
    ((98 147) (226 0))
    NIL
    ((128. -147. 0 0 0 0 ))
    NATURAL)
   (2
    ((226 0) (166 0))
    NIL
    ((-60. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 76Q)
 (FACE M R R)
 (WIDTH 267 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:46:22)
 (MADE-FROM NIL 155 130 0 0)
 (SPLINES

  ((2
    ((39 0) (167 147))
    NIL
    ((128. 147. 0 0 0 0 ))
    NATURAL)
   (2
    ((167 147) (39 294))
    NIL
    ((-128. 147. 0 0 0 0 ))
    NATURAL)
   (2
    ((39 294) (99 294))
    NIL
    ((60. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((99 294) (227 147))
    NIL
    ((128. -147. 0 0 0 0 ))
    NATURAL)
   (2
    ((227 147) (99 0))
    NIL
    ((-128. -147. 0 0 0 0 ))
    NATURAL)
   (2
    ((99 0) (39 0))
    NIL
    ((-60. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 77Q)
 (FACE M R R)
 (WIDTH 243 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:48:44)
 (MADE-FROM NIL 166 130 35 72)
 (SPLINES

  ((17
    ((121 -6) (140 -3) (155 4) (163 13) (166 27) (163 41)
     (155 50) (140 57) (121 60) (102 57) (87 50) (79 41)
     (76 27) (79 13) (87 4) (102 -3) (121 -6))
    NIL
    ((19.639171 1.98203754 0 0 -3.83505154 6.10777474 )
     (17.721649 5.0359249 -3.83505154 6.10777474 -4.82474232 -6.53887368 )
     (11.474226 7.87426186 -8.65979386 -0.431099415 5.1340208 8.04772187 )
     (5.38144303 11.4670238 -3.52577257 7.6166229 -3.71134043 -7.65201569 )
     (-8.00937414E-8 15.2576389 -7.237113 -0.0353937074 3.71133947 -7.43965436 )
     (-5.38144303 11.5024166 -3.52577353 -7.47504807 -5.13401795 7.41063786 )
     (-11.474226 7.73268796 -8.65979196 -0.0644102097 4.8247404 -4.20289994 )
     (-17.721649 5.5668268 -3.83505154 -4.26731014 3.83505106 -2.59903431 )
     (-19.639171 0 -1.27768117E-7 -6.86634446 3.835052 2.59903335 )
     (-17.721649 -5.56682778 3.835052 -4.2673111 4.82473946 4.20290089 )
     (-11.474226 -7.73268796 8.65979196 -0.0644097030 -5.1340189 -7.4106388 )
     (-5.38144303 -11.5024166 3.52577305 -7.475049 3.71133995 7.4396553 )
     (1.59256160E-7 -15.2576389 7.237113 -0.0353935584 -3.71133995 7.65201569 )
     (5.38144303 -11.4670238 3.52577305 7.6166229 5.1340208 -8.04772187 )
     (11.474226 -7.87426186 8.65979386 -0.431099653 -4.82474232 6.53887368 )
     (17.721649 -5.0359249 3.83505154 6.10777474 -3.83505154 -6.10777474 ))
    NATURAL))

  ((2
    ((100 93) (130 93))
    NIL
    ((30. 0 0 0 0 0 ))
    NATURAL)
   (28
    ((130 93) (133 114) (143 132) (169 148) (197 169) (216 197)
     (217 232) (205 259) (181 280) (149 292) (111 295) (72 290)
     (42 274) (25 246) (33 213) (61 203) (84 206) (101 224)
     (96 250) (87 265) (96 275) (112 267) (123 245) (127 215)
     (120 173) (105 141) (99 113) (100 93))
    NIL
    ((2.20930052 21.587924 0 0 4.74419689 -3.52756643 )
     (4.58139897 19.824142 4.74419689 -3.52756643 18.279014 -0.362166881 )
     (18.465103 16.115493 23.023212 -3.88973332 -23.860263 10.976232 )
     (29.558181 17.713874 -0.837053538 7.08650017 -6.83794499 -1.54276752 )
     (25.302154 24.028991 -7.67499924 5.54373265 -14.787948 7.1948328 )
     (10.233181 33.170143 -22.462947 12.738565 11.989748 -27.23656 )
     (-6.2348919 32.29042 -10.4731998 -14.497997 -3.1710453 11.7514228 )
     (-18.293613 23.66814 -13.644245 -2.74657297 6.69443608 -7.76913357 )
     (-28.59064 17.036998 -6.94980908 -10.515707 0.393295288 1.32511329 )
     (-35.343803 7.18384934 -6.55651379 -9.1905937 3.73237848 2.46868038 )
     (-40.034126 -0.772403956 -2.8241353 -6.72191334 14.6771907 -5.19983578 )
     (-35.519668 -10.094236 11.8530559 -11.921749 -2.44114303 0.330665588 )
     (-24.887184 -21.85065 9.4119129 -11.591083 19.087368 -2.12282944 )
     (-5.9315853 -34.50315 28.499282 -13.7139129 -1.90833282 50.16065 )
     (21.613529 -23.136734 26.59095 36.446739 -41.45404 -30.519794 )
     (27.477458 -1.94989419 -14.86309 5.92694378 17.724498 11.918533 )
     (21.476619 9.93631745 2.86140919 17.845478 -35.443946 -5.15433884 )
     (6.6160507 25.204624 -32.582542 12.691139 28.051315 -33.30117 )
     (-11.940832 21.245174 -4.53122425 -20.610034 31.238666 24.359039 )
     (-0.852723838 12.814661 26.707443 3.7490058 -21.005985 -28.13499 )
     (15.351724 2.49617195 5.70145703 -24.385986 -13.214729 10.180927 )
     (14.4458179 -16.79935 -7.51327229 -14.205059 1.86490535 11.411287 )
     (7.8649988 -25.298767 -5.64836693 -2.79377174 -6.24489403 -19.826076 )
     (-0.905814410 -38.005577 -11.8932609 -22.61985 -0.885330201 43.89302 )
     (-13.241739 -38.678909 -12.778591 21.27317 27.786216 -23.746013 )
     (-12.1272239 -29.27875 15.007625 -2.4728465 -8.259531 15.0910568 )
     (-1.24936437 -24.206069 6.7480936 12.6182117 -6.7480936 -12.6182117 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 133Q)
 (FACE M R R)
 (WIDTH 210 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:51:16)
 (MADE-FROM NIL 147 130 0 0)
 (SPLINES

  ((2
    ((183 294) (183 244))
    NIL
    ((0 -50. 0 0 0 0 ))
    NATURAL)
   (2
    ((183 244) (133 244))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((133 244) (133 -32))
    NIL
    ((0 -276. 0 0 0 0 ))
    NATURAL)
   (2
    ((133 -32) (183 -32))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((183 -32) (183 -82))
    NIL
    ((0 -50. 0 0 0 0 ))
    NATURAL)
   (2
    ((183 -82) (49 -82))
    NIL
    ((-134. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((49 -82) (49 294))
    NIL
    ((0 376. 0 0 0 0 ))
    NATURAL)
   (2
    ((49 294) (183 294))
    NIL
    ((134. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 135Q)
 (FACE M R R)
 (WIDTH 208 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:52:23)
 (MADE-FROM NIL 159 130 0 0)
 (SPLINES

  ((2
    ((157 -82) (23 -82))
    NIL
    ((-134. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((23 -82) (23 -32))
    NIL
    ((0 50. 0 0 0 0 ))
    NATURAL)
   (2
    ((23 -32) (73 -32))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((73 -32) (73 244))
    NIL
    ((0 276. 0 0 0 0 ))
    NATURAL)
   (2
    ((73 244) (23 244))
    NIL
    ((-50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((23 244) (23 294))
    NIL
    ((0 50. 0 0 0 0 ))
    NATURAL)
   (2
    ((23 294) (157 294))
    NIL
    ((134. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((157 294) (157 294) (157 -82))
    NIL
    ((0 94. 0 0 0 -564. )
     (0 -188. 0 -564. 0 564. ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 136Q)
 (FACE M R R)
 (WIDTH 223 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:53:31)
 (MADE-FROM NIL 118 130 0 0)
 (SPLINES

  ((2
    ((142 15) (142 155))
    NIL
    ((0 140. 0 0 0 0 ))
    NATURAL)
   (2
    ((142 155) (192 155))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((192 155) (112 265))
    NIL
    ((-80. 110. 0 0 0 0 ))
    NATURAL)
   (2
    ((112 265) (32 155))
    NIL
    ((-80. -110. 0 0 0 0 ))
    NATURAL)
   (2
    ((32 155) (82 155))
    NIL
    ((50. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((82 155) (82 15))
    NIL
    ((0 -140. 0 0 0 0 ))
    NATURAL)
   (2
    ((82 15) (142 15))
    NIL
    ((60. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 137Q)
 (FACE M R R)
 (WIDTH 327 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:54:28)
 (MADE-FROM NIL 102 130 0 0)
 (SPLINES

  ((2
    ((144 27) (144 77))
    NIL
    ((0 50. 0 0 0 0 ))
    NATURAL)
   (2
    ((144 77) (284 77))
    NIL
    ((140. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((284 77) (284 137))
    NIL
    ((0 60. 0 0 0 0 ))
    NATURAL)
   (2
    ((284 137) (144 137))
    NIL
    ((-140. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((144 137) (144 187))
    NIL
    ((0 50. 0 0 0 0 ))
    NATURAL)
   (2
    ((144 187) (34 107))
    NIL
    ((-110. -80. 0 0 0 0 ))
    NATURAL)
   (2
    ((34 107) (144 27))
    NIL
    ((110. -80. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 174Q)
 (FACE M R R)
 (WIDTH 163 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:57:15)
 (MADE-FROM NIL 156 130 0 0)
 (SPLINES

  ((2
    ((124 294) (40 294))
    NIL
    ((-84. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((40 294) (40 294) (40 -82))
    NIL
    ((0 94. 0 0 0 -564. )
     (0 -188. 0 -564. 0 564. ))
    NATURAL)
   (2
    ((40 -82) (124 -82))
    NIL
    ((84. 0 0 0 0 0 ))
    NATURAL)
   (3
    ((124 -82) (124 294) (124 294))
    NIL
    ((0 470. 0 0 0 -564. )
     (0 188. 0 -564. 0 564. ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 173Q)
 (FACE M R R)
 (WIDTH 237 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 16:58:29)
 (MADE-FROM NIL 126 130 0 0)
 (SPLINES

  ((2
    ((197 294) (154 294))
    NIL
    ((-43. 0 0 0 0 0 ))
    NATURAL)
   (6
    ((154 294) (125 289) (105 279) (87 261) (75 236) (70 210))
    NIL
    ((-31.34928 -4.10526276 0 0 14.095693 -5.3684206 )
     (-24.301433 -6.78947354 14.095693 -5.3684206 -16.478466 -3.15789509 )
     (-18.444973 -13.736841 -2.38277435 -8.5263157 9.81817819 1.90734863E-6 )
     (-15.918659 -22.263156 7.43540478 -8.52631379 1.20574283 9.1578922 )
     (-7.88038254 -26.210525 8.6411476 0.631578803 -8.6411476 -0.631578803 ))
    NATURAL)
   (2
    ((70 210) (70 157))
    NIL
    ((0 -53. 0 0 0 0 ))
    NATURAL)
   (5
    ((70 157) (66 139) (55 127) (40 122) (25 122))
    NIL
    ((-2.41071415 -19.196426 0 0 -9.5357132 7.17857075 )
     (-7.1785717 -15.607141 -9.5357132 7.17857075 5.67857075 0.107143402 )
     (-13.875 -8.3749981 -3.85714245 7.28571416 4.82142735 -1.6071434 )
     (-15.321428 -1.89285683 0.964285732 5.67857075 -0.964285732 -5.67857075 ))
    NATURAL)
   (2
    ((25 122) (25 96))
    NIL
    ((0 -26. 0 0 0 0 ))
    NATURAL)
   (5
    ((25 96) (40 96) (55 91) (66 79) (70 61))
    NIL
    ((14.8392849 0.946428419 0 0 0.964285732 -5.67857075 )
     (15.321428 -1.89285731 0.964285732 -5.67857075 -4.8214283 -1.6071434 )
     (13.874998 -8.375 -3.85714293 -7.28571416 -5.6785698 0.107143402 )
     (7.17857075 -15.607141 -9.5357132 -7.17857075 9.5357132 7.17857075 ))
    NATURAL)
   (2
    ((70 61) (70 8))
    NIL
    ((0 -53. 0 0 0 0 ))
    NATURAL)
   (6
    ((70 8) (75 -18) (87 -43) (105 -61) (125 -71) (154 -76))
    NIL
    ((3.55980873 -25.894733 0 0 8.6411476 -0.631578923 )
     (7.88038254 -26.210525 8.6411476 -0.631578923 -1.20574188 9.15789414 )
     (15.918659 -22.263156 7.43540574 8.5263157 -9.81818009 -1.90734863E-6 )
     (18.444973 -13.736841 -2.38277483 8.52631379 16.478466 -3.15789318 )
     (24.301433 -6.78947354 14.095693 5.3684206 -14.095693 -5.3684206 ))
    NATURAL)
   (2
    ((154 -76) (197 -76))
    NIL
    ((43. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((197 -76) (197 -51))
    NIL
    ((0 25. 0 0 0 0 ))
    NATURAL)
   (7
    ((197 -51) (183 -50) (171 -47) (164 -41) (158 -30) (156 -18)
     (154 -6))
    NIL
    ((-14.17564 0.588461519 0 0 1.05384636 2.46923065 )
     (-13.6487179 1.82307696 1.05384636 2.46923065 6.7307682 -0.346154213 )
     (-9.22948648 4.11923027 7.78461457 2.12307644 -9.97692109 4.91538525 )
     (-6.4333334 8.69999887 -2.19230747 7.03846169 9.17692185 -7.31538487 )
     (-4.037179 12.0807686 6.98461533 -0.276923179 -8.7307682 0.346153974 )
     (-1.41794872 11.976923 -1.74615383 0.0692307949 1.74615383 -0.0692307949 ))
    NATURAL)
   (2
    ((154 -6) (154 57))
    NIL
    ((0 63. 0 0 0 0 ))
    NATURAL)
   (5
    ((154 57) (151 73) (143 89) (131 100) (114 109))
    NIL
    ((-1.85714292 15.6785698 0 0 -6.85714245 1.92857122 )
     (-5.28571415 16.642856 -6.85714245 1.92857122 4.28571415 -9.6428547 )
     (-10. 13.749998 -2.5714283 -7.7142849 -4.28571415 6.64285565 )
     (-14.7142849 9.3571415 -6.85714245 -1.07142853 6.85714245 1.07142853 ))
    NATURAL)
   (5
    ((114 109) (131 118) (143 129) (151 145) (154 161))
    NIL
    ((18.142856 8.8214283 0 0 -6.85714245 1.07142877 )
     (14.7142849 9.3571415 -6.85714245 1.07142877 4.28571415 6.64285565 )
     (9.9999981 13.75 -2.5714283 7.7142849 -4.28571415 -9.6428547 )
     (5.28571415 16.642856 -6.85714245 -1.92857146 6.85714245 1.92857146 ))
    NATURAL)
   (2
    ((154 161) (154 224))
    NIL
    ((0 63. 0 0 0 0 ))
    NATURAL)
   (7
    ((154 224) (156 236) (158 248) (164 259) (171 265) (183 268)
     (197 269))
    NIL
    ((2.29102564 12.011537 0 0 -1.74615383 -0.0692307055 )
     (1.41794872 11.976923 -1.74615383 -0.0692307055 8.7307682 0.346153498 )
     (4.037179 12.0807686 6.98461533 0.276922822 -9.17692185 -7.31538296 )
     (6.4333334 8.69999887 -2.19230747 -7.03846074 9.97692109 4.91538334 )
     (9.22948648 4.11923027 7.78461457 -2.12307691 -6.7307682 -0.346153259 )
     (13.6487179 1.82307672 1.05384612 -2.46923017 -1.05384612 2.46923017 ))
    NATURAL)
   (2
    ((197 269) (197 294))
    NIL
    ((0 25. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 175Q)
 (FACE M R R)
 (WIDTH 237 0)
 (FIDUCIAL 385 385)
 (VERSION 0  3-OCT-77 17:00:08)
 (MADE-FROM NIL 147 130 0 0)
 (SPLINES

  ((2
    ((42 294) (85 294))
    NIL
    ((43. 0 0 0 0 0 ))
    NATURAL)
   (6
    ((85 294) (114 289) (134 279) (152 261) (164 236) (169 210))
    NIL
    ((31.34928 -4.10526276 0 0 -14.095693 -5.3684206 )
     (24.301433 -6.78947354 -14.095693 -5.3684206 16.478466 -3.15789509 )
     (18.444973 -13.736841 2.38277435 -8.5263157 -9.81817819 1.90734863E-6 )
     (15.918659 -22.263156 -7.43540478 -8.52631379 -1.20574283 9.1578922 )
     (7.88038254 -26.210525 -8.6411476 0.631578803 8.6411476 -0.631578803 ))
    NATURAL)
   (2
    ((169 210) (169 157))
    NIL
    ((0 -53. 0 0 0 0 ))
    NATURAL)
   (5
    ((169 157) (173 139) (184 127) (199 122) (214 122))
    NIL
    ((2.41071415 -19.196426 0 0 9.5357132 7.17857075 )
     (7.1785717 -15.607141 9.5357132 7.17857075 -5.67857075 0.107143402 )
     (13.875 -8.3749981 3.85714245 7.28571416 -4.82142735 -1.6071434 )
     (15.321428 -1.89285683 -0.964285732 5.67857075 0.964285732 -5.67857075 ))
    NATURAL)
   (2
    ((214 122) (214 96))
    NIL
    ((0 -26. 0 0 0 0 ))
    NATURAL)
   (5
    ((214 96) (199 96) (184 91) (173 79) (169 61))
    NIL
    ((-14.8392849 0.946428419 0 0 -0.964285732 -5.67857075 )
     (-15.321428 -1.89285731 -0.964285732 -5.67857075 4.8214283 -1.6071434 )
     (-13.874998 -8.375 3.85714293 -7.28571416 5.6785698 0.107143402 )
     (-7.17857075 -15.607141 9.5357132 -7.17857075 -9.5357132 7.17857075 ))
    NATURAL)
   (2
    ((169 61) (169 8))
    NIL
    ((0 -53. 0 0 0 0 ))
    NATURAL)
   (6
    ((169 8) (164 -18) (152 -43) (134 -61) (114 -71) (85 -76))
    NIL
    ((-3.55980873 -25.894733 0 0 -8.6411476 -0.631578923 )
     (-7.88038254 -26.210525 -8.6411476 -0.631578923 1.20574188 9.15789414 )
     (-15.918659 -22.263156 -7.43540574 8.5263157 9.81818009 -1.90734863E-6 )
     (-18.444973 -13.736841 2.38277483 8.52631379 -16.478466 -3.15789318 )
     (-24.301433 -6.78947354 -14.095693 5.3684206 14.095693 -5.3684206 ))
    NATURAL)
   (2
    ((85 -76) (42 -76))
    NIL
    ((-43. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((42 -76) (42 -51))
    NIL
    ((0 25. 0 0 0 0 ))
    NATURAL)
   (7
    ((42 -51) (56 -50) (68 -47) (75 -41) (81 -30) (83 -18)
     (85 -6))
    NIL
    ((14.17564 0.588461519 0 0 -1.05384636 2.46923065 )
     (13.6487179 1.82307696 -1.05384636 2.46923065 -6.7307682 -0.346154213 )
     (9.22948648 4.11923027 -7.78461457 2.12307644 9.97692109 4.91538525 )
     (6.4333334 8.69999887 2.19230747 7.03846169 -9.17692185 -7.31538487 )
     (4.037179 12.0807686 -6.98461533 -0.276923179 8.7307682 0.346153974 )
     (1.41794872 11.976923 1.74615383 0.0692307949 -1.74615383 -0.0692307949 ))
    NATURAL)
   (2
    ((85 -6) (85 57))
    NIL
    ((0 63. 0 0 0 0 ))
    NATURAL)
   (5
    ((85 57) (88 73) (96 89) (108 100) (125 109))
    NIL
    ((1.85714292 15.6785698 0 0 6.85714245 1.92857122 )
     (5.28571415 16.642856 6.85714245 1.92857122 -4.28571415 -9.6428547 )
     (10. 13.749998 2.5714283 -7.7142849 4.28571415 6.64285565 )
     (14.7142849 9.3571415 6.85714245 -1.07142853 -6.85714245 1.07142853 ))
    NATURAL)
   (5
    ((125 109) (108 118) (96 129) (88 145) (85 161))
    NIL
    ((-18.142856 8.8214283 0 0 6.85714245 1.07142877 )
     (-14.7142849 9.3571415 6.85714245 1.07142877 -4.28571415 6.64285565 )
     (-9.9999981 13.75 2.5714283 7.7142849 4.28571415 -9.6428547 )
     (-5.28571415 16.642856 6.85714245 -1.92857146 -6.85714245 1.92857146 ))
    NATURAL)
   (2
    ((85 161) (85 224))
    NIL
    ((0 63. 0 0 0 0 ))
    NATURAL)
   (7
    ((85 224) (83 236) (81 248) (75 259) (68 265) (56 268)
     (42 269))
    NIL
    ((-2.29102564 12.011537 0 0 1.74615383 -0.0692307055 )
     (-1.41794872 11.976923 1.74615383 -0.0692307055 -8.7307682 0.346153498 )
     (-4.037179 12.0807686 -6.98461533 0.276922822 9.17692185 -7.31538296 )
     (-6.4333334 8.69999887 2.19230747 -7.03846074 -9.97692109 4.91538334 )
     (-9.22948648 4.11923027 -7.78461457 -2.12307691 6.7307682 -0.346153259 )
     (-13.6487179 1.82307672 -1.05384612 -2.46923017 1.05384612 2.46923017 ))
    NATURAL)
   (2
    ((42 269) (42 294))
    NIL
    ((0 25. 0 0 0 0 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.UC1-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.UC1-SF
deleted file mode 100644
index e2745a27..00000000
--- a/obsolete/lispusers/splinefonts/TIMESROMAN.UC1-SF
+++ /dev/null
@@ -1 +0,0 @@
-

((FAMILY TIMESROMAND)
 (CHARACTER 101Q)
 (FACE M R R)
 (WIDTH 344 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 15:54:14)
 (MADE-FROM NIL 89 130 69 77)
 (SPLINES

  ((2
    ((191 0) (332 0))
    NIL
    ((141. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((332 0) (332 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (3
    ((332 10) (320 19) (313 29))
    NIL
    ((-13.25 8.75 0 0 7.5 1.5 )
     (-9.5 9.5 7.5 1.5 -7.5 -1.5 ))
    NATURAL)
   (2
    ((313 29) (180 294))
    NIL
    ((-133. 265. 0 0 0 0 ))
    NATURAL)
   (2
    ((180 294) (146 294))
    NIL
    ((-34. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((146 294) (50 54))
    NIL
    ((-96. -240. 0 0 0 0 ))
    NATURAL)
   (4
    ((50 54) (40 33) (28 18) (11 10))
    NIL
    ((-9.79999925 -22.133331 0 0 -1.20000004 6.8000002 )
     (-10.3999996 -18.733329 -1.20000004 6.8000002 -5.99999905 1.99999904 )
     (-14.599998 -10.933332 -7.1999998 8.79999925 7.1999998 -8.79999925 ))
    NATURAL)
   (2
    ((11 10) (11 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (2
    ((11 0) (116 0))
    NIL
    ((105. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((116 0) (116 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (7
    ((116 10) (104 13) (89 19) (78 35) (80 58) (84 74)
     (91 96))
    NIL
    ((-11.152563 2.73589706 0 0 -5.08461476 1.58461571 )
     (-13.6948719 3.52820492 -5.08461476 1.58461571 7.42307664 10.076921 )
     (-15.067947 10.151281 2.33846187 11.661537 17.392303 0.107692718 )
     (-4.03333187 21.866664 19.730766 11.7692299 -22.992301 -28.50769 )
     (4.20128155 19.382049 -3.26153803 -16.73846 8.57692147 29.923076 )
     (5.22820473 17.605125 5.3153839 13.184616 -5.3153839 -13.184616 ))
    NATURAL)
   (3
    ((91 96) (177 96) (177 96))
    NIL
    ((107.5 0 0 0 -129. 0 )
     (43. 0 -129. 0 129. 0 ))
    NATURAL)
   (2
    ((177 96) (200 44))
    NIL
    ((23. -52. 0 0 0 0 ))
    NATURAL)
   (4
    ((200 44) (208 26) (202 13) (191 10))
    NIL
    ((11.3999996 -18.666664 0 0 -20.399997 4. )
     (1.19999909 -16.666664 -20.399997 4. 17.999996 10. )
     (-10.1999988 -7.66666604 -2.39999962 14. 2.39999962 -14. ))
    NATURAL)
   (2
    ((191 10) (191 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL))

  ((2
    ((97 113) (169 113))
    NIL
    ((72. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((169 113) (129 195))
    NIL
    ((-40. 82. 0 0 0 0 ))
    NATURAL)
   (2
    ((129 195) (97 113))
    NIL
    ((-32. -82. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 102Q)
 (FACE M R R)
 (WIDTH 340 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 15:56:46)
 (MADE-FROM NIL 91 130 82 78)
 (SPLINES

  ((2
    ((16 0) (16 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((16 10) (27 11) (40 16) (46 27) (47 39))
    NIL
    ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 )
     (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 )
     (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 )
     (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 ))
    NATURAL)
   (2
    ((47 39) (47 255))
    NIL
    ((0 216. 0 0 0 0 ))
    NATURAL)
   (5
    ((47 255) (46 267) (40 278) (27 283) (16 284))
    NIL
    ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 )
     (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 )
     (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 )
     (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 ))
    NATURAL)
   (2
    ((16 284) (16 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((16 294) (191 294))
    NIL
    ((175. 0 0 0 0 0 ))
    NATURAL)
   (10
    ((191 294) (232 292) (264 284) (287 269) (304 246) (308 215)
     (297 189) (276 172) (246 160) (204 154))
    NIL
    ((42.83139 -0.786138774 0 0 -10.988382 -7.28316689 )
     (37.337204 -4.42772198 -10.988382 -7.28316689 0.941915513 0.415834427 )
     (26.819778 -11.5029716 -10.0464668 -6.86733246 7.22071839 -0.380169869 )
     (20.38367 -18.560386 -2.82574797 -7.24750233 -11.824789 -4.895154 )
     (11.6455288 -28.255466 -14.650537 -12.142656 -1.92156791 19.960781 )
     (-3.96579123 -30.417732 -16.572105 7.81812764 7.51106454 3.05201626 )
     (-16.7823639 -21.073596 -9.06104089 10.8701439 1.87731838 -8.16884805 )
     (-24.904747 -14.287876 -7.1837225 2.7012949 -9.02034379 5.6233797 )
     (-36.59864 -8.7748909 -16.204067 8.3246746 16.204067 -8.3246746 ))
    NATURAL)
   (11
    ((204 154) (236 149) (271 141) (299 127) (317 103) (324 73)
     (316 40) (295 19) (266 6) (243 2) (225 0))
    NIL
    ((30.846077 -4.45746613 0 0 6.92353726 -3.25520086 )
     (34.307838 -6.0850668 6.92353726 -3.25520086 -16.617683 -1.72399473 )
     (32.922538 -10.2022647 -9.694149 -4.9791956 -0.452787399 -7.84881879 )
     (23.001995 -19.105869 -10.146936 -12.828014 0.428838730 9.11927224 )
     (13.069475 -27.374248 -9.7180977 -3.70874214 -7.2625656 -4.628273 )
     (-0.279904365 -33.397125 -16.980663 -8.33701516 4.62141609 27.393817 )
     (-14.949859 -28.037231 -12.359247 19.056804 0.776903153 -14.947021 )
     (-26.920654 -16.453933 -11.582344 4.10978318 22.270965 8.39427377 )
     (-27.367511 -8.1470165 10.688623 12.5040569 -5.86077976 -12.6300697 )
     (-19.609279 -1.95799517 4.82784367 -0.126014232 -4.82784367 0.126014232 ))
    NATURAL)
   (2
    ((225 0) (16 0))
    NIL
    ((-209. 0 0 0 0 0 ))
    NATURAL))

  ((3
    ((147 161) (147 161) (147 278))
    NIL
    ((0 -29.25 0 0 0 175.5 )
     (0 58.5 0 175.5 0 -175.5 ))
    NATURAL)
   (9
    ((147 278) (165 278) (186 272) (204 256) (214 230) (213 202)
     (200 175) (172 161) (147 161))
    NIL
    ((17.0887298 1.07391381 0 0 5.4675989 -6.44348336 )
     (19.822532 -2.14782762 5.4675989 -6.44348336 -9.3379955 -3.78258324 )
     (20.621131 -10.482603 -3.87039757 -10.2260666 -4.11561108 -2.42617798 )
     (14.69293 -21.921756 -7.98600865 -12.652244 -4.1995573 13.487295 )
     (4.60714245 -27.830356 -12.1855659 0.835051299 2.91384315 -3.5230112 )
     (-6.12150193 -28.756809 -9.2717228 -2.68796015 -13.455816 18.604747 )
     (-22.121131 -22.142395 -22.727539 15.916788 32.909423 1.10401344 )
     (-28.393959 -5.6736002 10.1818847 17.020801 -10.1818847 -17.020801 ))
    NATURAL))

  ((2
    ((147 144) (147 36))
    NIL
    ((0 -108. 0 0 0 0 ))
    NATURAL)
   (13
    ((147 36) (150 25) (161 16) (181 15) (199 22) (214 38)
     (221 57) (221 83) (215 111) (200 131) (184 141) (166 145)
     (147 144))
    NIL
    ((1.53440761 -11.070934 0 0 8.7935543 0.425616741 )
     (5.93118477 -10.8581276 8.7935543 0.425616741 4.03222656 9.8719158 )
     (16.740852 -5.4965515 12.8257808 10.297533 -18.922458 -3.91328716 )
     (20.1054 2.84433746 -6.09667969 6.38424588 5.65762043 5.7812376 )
     (16.837532 12.1192016 -0.439059258 12.165483 -9.70802117 -13.211664 )
     (11.544462 17.678852 -10.147081 -1.04618191 3.17446899 11.0654239 )
     (2.98461485 22.165382 -6.97261239 10.019243 3.01014614 -7.0500412 )
     (-2.48292446 28.659606 -3.96246624 2.96920204 -9.21505357 -12.865255 )
     (-11.052917 25.196178 -13.1775207 -9.8960533 15.8500709 -1.48893165 )
     (-16.3054008 14.555662 2.6725502 -11.3849849 -6.18523026 6.82098199 )
     (-16.725467 6.5811672 -3.51268005 -4.56400299 2.89085007 -1.79499531 )
     (-18.79272 1.1196661 -0.621829868 -6.3589983 0.621829868 6.3589983 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 103Q)
 (FACE M R R)
 (WIDTH 317 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 15:57:54)
 (MADE-FROM NIL 87 130 80 88)
 (SPLINES

  ((21
    ((295 206) (283 206) (278 217) (269 237) (252 257) (231 271)
     (203 277) (168 268) (147 247) (135 223) (127 194) (124 157)
     (127 121) (135 86) (151 54) (176 34) (209 25) (243 31)
     (271 48) (286 63) (299 51))
    NIL
    ((-14.023639 -2.3255701 0 0 12.1418419 13.95342 )
     (-7.95271874 4.65114117 12.1418419 13.95342 -18.709209 -3.76710892 )
     (-5.16548252 16.721004 -6.56736756 10.1863117 -3.30500221 -10.884983 )
     (-13.385351 21.464824 -9.87236978 -0.698672533 7.92921925 -6.6929493 )
     (-19.293109 17.419677 -1.94315004 -7.39162255 -4.41187954 1.65678596 )
     (-23.442199 10.856449 -6.35503007 -5.73483658 -8.28169824 -11.9341926 )
     (-33.938079 -0.845483781 -14.636728 -17.669029 37.538665 4.07999039 )
     (-29.805473 -16.474514 22.901939 -13.5890388 -15.872972 13.614221 )
     (-14.840019 -23.256443 7.02896596 0.0251838676 -4.0467739 -4.53687954 )
     (-9.8344402 -25.499698 2.98219156 -4.51169586 2.06007337 -7.4667034 )
     (-5.82221318 -33.744743 5.04226494 -11.978399 1.80648422 16.403694 )
     (0.123294025 -37.521293 6.84874917 4.42529679 -3.2860117 -4.14808369 )
     (5.3290367 -35.170044 3.56273747 0.277212322 5.3375635 0.188641011 )
     (11.560556 -34.798507 8.90030099 0.465853334 -0.0642452240 15.393518 )
     (20.428733 -26.635898 8.83605577 15.859373 0.919410706 -7.7627182 )
     (29.724494 -14.657884 9.75546647 8.0966549 -9.61338998 9.65735055 )
     (34.673263 -1.73255491 0.142075598 17.754005 -4.4658451 -6.86668587 )
     (32.58242 12.588106 -4.32376957 10.8873195 -14.5232219 -6.1906042 )
     (20.997036 20.380123 -18.846992 4.69671536 20.558738 -46.370887 )
     (12.4294166 1.89139294 1.71174884 -41.674179 -1.71174884 41.674179 ))
    NATURAL)
   (26
    ((299 51) (277 28) (249 10) (218 -1) (180 -5) (144 -2)
     (111 8) (82 23) (59 43) (39 69) (27 94) (20 123)
     (17 154) (21 184) (34 217) (52 244) (76 267) (104 284)
     (136 295) (172 300) (212 298) (241 293) (262 288) (280 285)
     (286 294) (296 294))
    NIL
    ((-20.465946 -23.943889 0 0 -9.20431329 5.6633482 )
     (-25.068103 -21.112216 -9.20431329 5.6633482 10.021566 1.68325901 )
     (-29.26163 -14.6072387 0.817253590 7.3466072 -12.881954 -0.396385193 )
     (-34.885353 -7.4588232 -12.064701 6.950222 17.506252 -0.0977230073 )
     (-38.196929 -0.557461977 5.44155407 6.852499 -3.14307118 0.787275315 )
     (-34.326911 6.68867398 2.29848289 7.6397743 1.06602907 -3.05137062 )
     (-31.495414 12.802763 3.36451197 4.5884037 4.8789568 -0.581792832 )
     (-25.691421 17.100269 8.24346925 4.00661087 -8.5818615 5.37854195 )
     (-21.738884 23.79615 -0.338392854 9.3851528 11.448492 -14.9323749 )
     (-16.353031 25.715114 11.1100998 -5.54722309 -7.21210194 12.3509617 )
     (-8.84898377 26.343372 3.89799738 6.80373955 -0.600089073 -4.4714737 )
     (-5.25102997 30.911376 3.2979083 2.33226585 3.61245775 -6.4650688 )
     (-0.146893501 30.011108 6.91036606 -4.13280297 4.15026284 12.3317489 )
     (8.83860398 32.044181 11.0606289 8.198946 -8.2135105 -18.861927 )
     (15.792476 30.81216 2.84711695 -10.6629829 4.70378399 9.1159687 )
     (20.991485 24.707164 7.5509014 -1.54701376 -4.60162544 -5.60194683 )
     (26.241573 20.359176 2.94927549 -7.14896107 1.70271826 1.29182338 )
     (30.042209 13.8561248 4.65199375 -5.85713768 -2.2092433 0.434653282 )
     (33.589576 8.2163143 2.44275045 -5.4224844 7.13425065 -3.03043842 )
     (39.599456 1.27861070 9.57700158 -8.4529228 -26.327758 5.68710327 )
     (36.012573 -4.33076 -16.750759 -2.76581907 8.17679978 4.28201866 )
     (23.350219 -4.95556927 -8.57395936 1.5162003 11.6205539 -4.81518173 )
     (20.586536 -5.84696007 3.04659605 -3.29898214 -24.659015 26.978706 )
     (11.303623 4.3434124 -21.612422 23.679725 33.015525 -43.099655 )
     (6.19896508 6.4733095 11.4031047 -19.419929 -11.4031047 19.419929 ))
    NATURAL)
   (2
    ((296 294) (295 206))
    NIL
    ((-1. -88. 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 104Q)
 (FACE M R R)
 (WIDTH 356 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 15:59:49)
 (MADE-FROM NIL 93 130 82 78)
 (SPLINES

  ((2
    ((181 0) (14 0))
    NIL
    ((-167. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((14 0) (14 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((14 10) (25 11) (38 16) (44 27) (45 39))
    NIL
    ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 )
     (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 )
     (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 )
     (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 ))
    NATURAL)
   (2
    ((45 39) (45 255))
    NIL
    ((0 216. 0 0 0 0 ))
    NATURAL)
   (5
    ((45 255) (44 267) (38 278) (25 283) (14 284))
    NIL
    ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 )
     (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 )
     (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 )
     (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 ))
    NATURAL)
   (2
    ((14 284) (14 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((14 294) (181 294))
    NIL
    ((167. 0 0 0 0 0 ))
    NATURAL)
   (19
    ((181 294) (210 292) (236 288) (260 281) (284 269) (303 254)
     (321 234) (333 211) (342 176) (343 147) (342 118) (333 83)
     (321 60) (303 40) (284 25) (260 13) (236 6) (210 2)
     (181 0))
    NIL
    ((29.633724 -1.5916388 0 0 -3.80235243 -2.45016622 )
     (27.732547 -2.81672191 -3.80235243 -2.45016622 1.01176214 0.250832081 )
     (24.436077 -5.14147187 -2.79059028 -2.19933414 5.75530434 -4.55316258 )
     (24.523136 -9.61738778 2.96471405 -6.7524967 -12.0329799 5.9618187 )
     (21.471363 -13.388975 -9.0682659 -0.790677190 12.3766117 -7.29411507 )
     (18.5914039 -17.826709 3.30834723 -8.0847931 -13.4734687 11.214649 )
     (15.163015 -20.30418 -10.1651229 3.1298561 11.517271 -25.564483 )
     (10.7565269 -29.956565 1.35214877 -22.434627 -14.595617 37.04328 )
     (4.81086636 -33.869545 -13.243469 14.6086578 16.8652038 -14.6086578 )
     (-1.59256160E-7 -26.565223 3.6217351 -5.11072471E-7 -16.8652038 -14.608654 )
     (-4.81086827 -33.869545 -13.243469 -14.6086559 14.595617 37.043273 )
     (-10.7565288 -29.956562 1.35214853 22.434623 -11.517271 -25.564476 )
     (-15.163015 -20.30418 -10.1651229 -3.12985516 13.4734687 11.214647 )
     (-18.5914039 -17.826709 3.30834723 8.0847931 -12.3766098 -7.294116 )
     (-21.471363 -13.388973 -9.068264 0.790676714 12.032978 5.96181965 )
     (-24.523136 -9.61738778 2.96471405 6.7524967 -5.75530434 -4.55316258 )
     (-24.436077 -5.14147187 -2.79059028 2.19933367 -1.01176166 0.250832558 )
     (-27.732547 -2.81672191 -3.80235195 2.45016622 3.80235195 -2.45016622 ))
    NATURAL))

  ((2
    ((145 272) (145 272))
    NIL
    ((0 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((145 272) (145 36))
    NIL
    ((0 -236. 0 0 0 0 ))
    NATURAL)
   (19
    ((145 36) (147 28) (157 18) (182 16) (204 25) (221 41)
     (234 63) (242 90) (245 119) (246 147) (244 172) (240 198)
     (232 229) (218 253) (203 268) (184 277) (164 281) (148 280)
     (145 272))
    NIL
    ((0.969433427 -7.07190228 0 0 6.1833992 -5.56858444 )
     (4.06113243 -9.85619355 6.1833992 -5.56858444 17.083004 15.842924 )
     (18.786033 -7.50331689 23.266403 10.2743396 -32.515426 2.19688225 )
     (25.794723 3.8694644 -9.24902535 12.4712219 4.97872639 -6.63045407 )
     (19.03506 13.025459 -4.27029896 5.84076786 0.600520611 0.324934006 )
     (15.065023 19.028694 -3.66977835 6.16570187 -1.38080835 -0.669278145 )
     (10.7048397 24.859756 -5.0505867 5.49642372 -1.07728576 -3.64782 )
     (5.11561108 28.532268 -6.12787247 1.84860348 5.68994999 -2.73944139 )
     (1.8327136 29.011154 -0.437921703 -0.890838028 -3.68251753 -3.39441252 )
     (-0.446466982 26.423107 -4.12043953 -4.28525067 3.0401206 4.31709099 )
     (-3.04684639 24.296402 -1.08031892 0.0318403318 -2.4779644 10.126047 )
     (-5.36614704 29.391269 -3.55828333 10.157888 -5.12826252 -20.821285 )
     (-11.4885616 29.138511 -8.6865463 -10.6633968 10.991018 1.15910148 )
     (-14.6795997 19.054668 2.30447245 -9.50429536 -8.8358135 4.18487263 )
     (-16.793033 11.6428089 -6.53134156 -5.31942272 6.3522358 0.101410865 )
     (-20.148258 6.3740921 -0.179104834 -5.21801186 1.42686581 1.409482 )
     (-19.613929 1.86082101 1.24776101 -3.80852985 17.940292 -5.73933697 )
     (-9.39601899 -4.81737709 19.1880569 -9.5478668 -19.1880569 9.5478668 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 105Q)
 (FACE M R R)
 (WIDTH 302 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 16:01:30)
 (MADE-FROM NIL 93 130 82 78)
 (SPLINES

  ((2
    ((14 0) (14 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((14 10) (25 11) (38 16) (44 27) (45 39))
    NIL
    ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 )
     (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 )
     (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 )
     (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 ))
    NATURAL)
   (2
    ((45 39) (45 255))
    NIL
    ((0 216. 0 0 0 0 ))
    NATURAL)
   (5
    ((45 255) (44 267) (38 278) (25 283) (14 284))
    NIL
    ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 )
     (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 )
     (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 )
     (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 ))
    NATURAL)
   (2
    ((14 284) (14 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((14 294) (257 294))
    NIL
    ((243. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((257 294) (261 218))
    NIL
    ((4. -76. 0 0 0 0 ))
    NATURAL)
   (2
    ((261 218) (248 218))
    NIL
    ((-13. 0 0 0 0 0 ))
    NATURAL)
   (9
    ((248 218) (243 227) (237 242) (223 262) (206 274) (186 279)
     (164 281) (147 280) (145 272))
    NIL
    ((-5.26095295 7.87279034 0 0 1.56572151 6.7632551 )
     (-4.4780922 11.254417 1.56572151 6.7632551 -13.828607 2.1837244 )
     (-9.8266754 19.109535 -12.262886 8.9469795 11.7487106 -21.498157 )
     (-16.215206 17.307434 -0.514174938 -12.551178 -3.16623783 5.8089094 )
     (-18.3125 7.66071416 -3.68041277 -6.74226857 0.916238309 4.26251889 )
     (-21.534793 3.04970503 -2.76417446 -2.4797492 5.5012865 1.14101576 )
     (-21.54832 1.14046359 2.73711204 -1.33873343 19.078605 -8.82658196 )
     (-9.2719059 -4.61156082 21.815719 -10.1653156 -21.815719 10.1653156 ))
    NATURAL)
   (2
    ((145 272) (145 158))
    NIL
    ((0 -114. 0 0 0 0 ))
    NATURAL)
   (5
    ((145 158) (163 162) (177 174) (186 191) (190 215))
    NIL
    ((18.803569 2.08928585 0 0 -4.8214283 11.4642849 )
     (16.392856 7.8214283 -4.8214283 11.4642849 0.107143402 -9.3214264 )
     (11.624998 14.625 -4.7142849 2.14285707 -1.6071434 7.82142735 )
     (6.10714245 20.678569 -6.3214283 9.9642849 6.3214283 -9.9642849 ))
    NATURAL)
   (2
    ((190 215) (204 215))
    NIL
    ((14. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((204 215) (204 89))
    NIL
    ((0 -126. 0 0 0 0 ))
    NATURAL)
   (2
    ((204 89) (190 89))
    NIL
    ((-14. 0 0 0 0 0 ))
    NATURAL)
   (5
    ((190 89) (186 109) (177 126) (163 138) (145 142))
    NIL
    ((-2.9464283 20.589283 0 0 -6.3214283 -3.53571415 )
     (-6.10714245 18.821426 -6.3214283 -3.53571415 1.6071434 -0.321428776 )
     (-11.625 15.124998 -4.7142849 -3.85714293 -0.107143402 -7.1785698 )
     (-16.392856 7.67857075 -4.8214283 -11.035713 4.8214283 11.035713 ))
    NATURAL)
   (2
    ((145 142) (145 36))
    NIL
    ((0 -106. 0 0 0 0 ))
    NATURAL)
   (9
    ((145 36) (147 30) (156 20) (181 18) (211 21) (233 32)
     (250 47) (262 64) (271 84))
    NIL
    ((1.14101600 -4.4138441 0 0 5.153903 -9.51693536 )
     (3.7179675 -9.17231179 5.153903 -9.51693536 16.230484 23.584678 )
     (16.98711 -6.8969059 21.384387 14.067745 -16.0758438 -12.821794 )
     (30.333576 0.759941102 5.3085413 1.24594950 -17.927093 9.7025032 )
     (26.678569 6.85714245 -12.618555 10.9484539 9.7842388 -7.9882183 )
     (18.952133 13.811487 -2.8343153 2.96023512 -3.20986652 -1.7496314 )
     (14.512886 15.8969059 -6.04418183 1.21060371 3.05522776 2.98674488 )
     (9.9963169 18.600883 -2.98895407 4.1973486 2.98895407 -4.1973486 ))
    NATURAL)
   (2
    ((271 84) (286 80))
    NIL
    ((15. -4. 0 0 0 0 ))
    NATURAL)
   (2
    ((286 80) (266 0))
    NIL
    ((-20. -80. 0 0 0 0 ))
    NATURAL)
   (2
    ((266 0) (14 0))
    NIL
    ((-252. 0 0 0 0 0 ))
    NATURAL))

  ((2
    ((145 272) (145 272))
    NIL
    ((0 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 106Q)
 (FACE M R R)
 (WIDTH 274 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 16:03:04)
 (MADE-FROM NIL 93 130 82 78)
 (SPLINES

  ((2
    ((14 0) (14 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((14 10) (25 11) (38 16) (44 27) (45 39))
    NIL
    ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 )
     (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 )
     (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 )
     (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 ))
    NATURAL)
   (2
    ((45 39) (45 255))
    NIL
    ((0 216. 0 0 0 0 ))
    NATURAL)
   (5
    ((45 255) (44 267) (38 278) (25 283) (14 284))
    NIL
    ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 )
     (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 )
     (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 )
     (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 ))
    NATURAL)
   (2
    ((14 284) (14 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((14 294) (257 294))
    NIL
    ((243. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((257 294) (261 228))
    NIL
    ((4. -66. 0 0 0 0 ))
    NATURAL)
   (2
    ((261 228) (245 228))
    NIL
    ((-16. 0 0 0 0 0 ))
    NATURAL)
   (5
    ((245 228) (237 248) (220 266) (199 277) (173 280))
    NIL
    ((-5.78571415 20.178569 0 0 -13.285713 -1.07142877 )
     (-12.4285717 19.642856 -13.285713 -1.07142877 12.4285698 -6.64285565 )
     (-19.5 15.249998 -0.857143045 -7.7142849 -6.4285698 -2.3571434 )
     (-23.571426 6.35714245 -7.2857132 -10.071428 7.2857132 10.071428 ))
    NATURAL)
   (2
    ((173 280) (145 280))
    NIL
    ((-28. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((145 280) (145 162))
    NIL
    ((0 -118. 0 0 0 0 ))
    NATURAL)
   (5
    ((145 162) (165 164) (180 171) (191 185) (196 214))
    NIL
    ((21.160713 0.892857195 0 0 -6.9642849 6.6428566 )
     (17.678569 4.2142849 -6.9642849 6.6428566 4.82142735 -3.21428442 )
     (13.124998 9.25 -2.14285707 3.42857218 -6.32142735 18.214279 )
     (7.8214283 21.785713 -8.4642849 21.642852 8.4642849 -21.642852 ))
    NATURAL)
   (2
    ((196 214) (210 214))
    NIL
    ((14. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((210 214) (210 89))
    NIL
    ((0 -125. 0 0 0 0 ))
    NATURAL)
   (2
    ((210 89) (196 89))
    NIL
    ((-14. 0 0 0 0 0 ))
    NATURAL)
   (5
    ((196 89) (191 118) (180 132) (165 139) (145 141))
    NIL
    ((-3.58928585 32.607139 0 0 -8.4642849 -21.642856 )
     (-7.8214283 21.785713 -8.4642849 -21.642856 6.32142735 18.214283 )
     (-13.125 9.2499981 -2.14285707 -3.42857122 -4.8214283 -3.21428537 )
     (-17.678569 4.2142849 -6.96428586 -6.6428566 6.96428586 6.6428566 ))
    NATURAL)
   (2
    ((145 141) (145 39))
    NIL
    ((0 -102. 0 0 0 0 ))
    NATURAL)
   (5
    ((145 39) (146 27) (152 16) (165 11) (176 10))
    NIL
    ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 )
     (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 )
     (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 )
     (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 ))
    NATURAL)
   (2
    ((176 10) (176 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (2
    ((176 0) (14 0))
    NIL
    ((-162. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 107Q)
 (FACE M R R)
 (WIDTH 350 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 16:04:05)
 (MADE-FROM NIL 93 130 82 78)
 (SPLINES

  ((25
    ((298 296) (289 284) (268 287) (236 296) (200 301) (166 300)
     (130 295) (98 284) (70 267) (46 244) (28 217) (17 188)
     (12 154) (14 123) (21 94) (32 68) (52 42) (76 23)
     (105 8) (138 -2) (174 -6) (214 -6) (253 -1) (289 9)
     (315 20))
    NIL
    ((-6.48319245 -15.5386657 0 0 -15.100845 21.231998 )
     (-14.033615 -4.92266464 -15.100845 21.231998 3.5042324 -16.160003 )
     (-27.382343 8.22933007 -11.5966129 5.07199288 7.08391667 -10.5919685 )
     (-35.436996 8.00533868 -4.51269627 -5.5199766 10.160097 -1.47210884 )
     (-34.869644 1.74930858 5.64740086 -6.99208546 -11.724308 4.48040486 )
     (-35.084396 -3.00257444 -6.07690716 -2.5116806 12.7371368 -4.44951058 )
     (-34.792739 -7.7390108 6.66022969 -6.96119118 -3.22424364 1.3176403 )
     (-29.744628 -14.0413818 3.43598604 -5.64355088 0.159837722 -0.821053506 )
     (-26.228725 -20.095459 3.59582377 -6.46460438 2.58489275 1.96657467 )
     (-21.340454 -25.576774 6.1807165 -4.4980297 1.50059128 4.95475292 )
     (-14.4094429 -27.597427 7.6813078 0.456723809 -2.58725929 -9.7855873 )
     (-8.02176477 -32.0335 5.0940485 -9.32886506 2.8484478 16.1876068 )
     (-1.50349259 -33.268562 7.9424963 6.85874367 -2.80653286 -6.96485234 )
     (5.03573704 -29.892242 5.13596344 -0.106108874 -3.62231398 5.67179966 )
     (8.3605423 -27.162452 1.51364922 5.565691 11.2957878 -9.72234918 )
     (15.522087 -26.457935 12.8094387 -4.15665818 -11.560844 15.2176017 )
     (22.551101 -23.005794 1.24859380 11.0609436 4.94758892 -9.14805795 )
     (26.27349 -16.5188789 6.1961832 1.91288566 -2.22951364 3.37462616 )
     (31.354919 -12.91868 3.96666956 5.28751183 -2.02953386 1.64955234 )
     (34.306823 -6.80639268 1.93713569 6.93706418 4.34765053 -3.97283316 )
     (38.417778 -1.85574507 6.28478623 2.96423101 -9.3610668 2.2417779 )
     (40.022033 2.22937488 -3.07628202 5.2060089 3.0966239 1.00572204 )
     (38.494064 7.9382448 0.0203422196 6.21173096 -15.0254268 -6.2646637 )
     (31.001693 11.0176429 -15.005085 -0.0529328808 15.005085 0.0529328808 ))
    NATURAL)
   (2
    ((315 20) (315 89))
    NIL
    ((0 69. 0 0 0 0 ))
    NATURAL)
   (5
    ((315 89) (316 108) (324 117) (331 120) (339 123))
    NIL
    ((-0.964285494 21.25 0 0 11.785713 -13.5 )
     (4.9285717 14.499998 11.785713 -13.5 -16.928569 7.50000096 )
     (8.2499981 4.74999905 -5.1428566 -5.99999905 7.92857075 7.4999981 )
     (7.0714283 2.5 2.78571415 1.49999976 -2.78571415 -1.49999976 ))
    NATURAL)
   (2
    ((339 123) (339 133))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((339 133) (187 133))
    NIL
    ((-152. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((187 133) (187 123))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (5
    ((187 123) (199 122) (210 115) (215 102) (217 90))
    NIL
    ((11.8928566 0.160714298 0 0 0.642857075 -6.96428586 )
     (12.2142849 -3.3214283 0.642857075 -6.96428586 -9.2142849 -1.17857074 )
     (8.2499981 -10.875 -8.5714283 -8.1428566 6.21428586 11.6785698 )
     (2.78571415 -13.1785698 -2.35714245 3.53571415 2.35714245 -3.53571415 ))
    NATURAL)
   (2
    ((217 90) (217 19))
    NIL
    ((0 -71. 0 0 0 0 ))
    NATURAL)
   (16
    ((217 19) (200 11) (172 13) (146 28) (128 56) (120 97)
     (118 141) (121 181) (130 223) (145 253) (170 274) (206 279)
     (240 266) (266 245) (282 224) (295 196))
    NIL
    ((-14.0182419 -9.93531228 0 0 -17.890541 11.611883 )
     (-22.963512 -4.12937165 -17.890541 11.611883 23.452705 1.94058037 )
     (-29.1277 8.45280076 5.56216717 13.552463 2.07970333 -1.37420463 )
     (-22.52568 21.31816 7.6418705 12.1782589 4.22847367 3.55624008 )
     (-12.769571 35.274536 11.870344 15.7344989 -6.9935951 -12.8507557 )
     (-4.39602566 44.583663 4.87674904 2.88374233 -0.254091263 -12.1532116 )
     (0.353678048 41.390792 4.62265778 -9.2694702 2.00995827 19.463611 )
     (5.98131466 41.853134 6.63261605 10.194141 -1.78574085 -29.70124 )
     (11.7210598 37.196655 4.84687519 -19.507099 5.1330061 15.341362 )
     (19.134437 25.360233 9.9798813 -4.1657362 5.2537136 -13.664211 )
     (31.741176 14.362392 15.2335949 -17.829948 -20.147857 -2.68451309 )
     (36.90084 -4.8098135 -4.91426468 -20.514461 -2.66227054 12.402265 )
     (30.65544 -19.123142 -7.5765352 -8.11219598 -5.20305348 13.075447 )
     (20.477378 -20.697612 -12.7795887 4.96325207 11.474485 -16.704063 )
     (13.4350338 -24.086395 -1.30510235 -11.740812 1.30510235 11.740812 ))
    NATURAL)
   (2
    ((295 196) (310 196))
    NIL
    ((15. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((310 196) (308 296))
    NIL
    ((-2. 100. 0 0 0 0 ))
    NATURAL)
   (2
    ((308 296) (298 296))
    NIL
    ((-10. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 110Q)
 (FACE M R R)
 (WIDTH 398 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 16:09:07)
 (MADE-FROM NIL 86 130 82 78)
 (SPLINES

  ((2
    ((15 0) (15 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((15 10) (26 11) (39 16) (45 27) (46 39))
    NIL
    ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 )
     (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 )
     (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 )
     (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 ))
    NATURAL)
   (2
    ((46 39) (46 255))
    NIL
    ((0 216. 0 0 0 0 ))
    NATURAL)
   (5
    ((46 255) (45 267) (39 278) (26 283) (15 284))
    NIL
    ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 )
     (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 )
     (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 )
     (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 ))
    NATURAL)
   (2
    ((15 284) (15 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((15 294) (177 294))
    NIL
    ((162. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((177 294) (177 284))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (5
    ((177 284) (166 283) (153 278) (147 267) (146 255))
    NIL
    ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 )
     (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 )
     (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 )
     (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 ))
    NATURAL)
   (2
    ((146 255) (146 161))
    NIL
    ((0 -94. 0 0 0 0 ))
    NATURAL)
   (2
    ((146 161) (247 161))
    NIL
    ((101. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((247 161) (247 255))
    NIL
    ((0 94. 0 0 0 0 ))
    NATURAL)
   (5
    ((247 255) (246 267) (240 278) (227 283) (216 284))
    NIL
    ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 )
     (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 )
     (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 )
     (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 ))
    NATURAL)
   (2
    ((216 284) (216 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((216 294) (378 294))
    NIL
    ((162. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((378 294) (378 284))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (5
    ((378 284) (367 283) (354 278) (348 267) (347 255))
    NIL
    ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 )
     (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 )
     (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 )
     (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 ))
    NATURAL)
   (2
    ((347 255) (347 39))
    NIL
    ((0 -216. 0 0 0 0 ))
    NATURAL)
   (5
    ((347 39) (348 27) (354 16) (367 11) (378 10))
    NIL
    ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 )
     (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 )
     (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 )
     (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 ))
    NATURAL)
   (2
    ((378 10) (378 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (2
    ((378 0) (216 0))
    NIL
    ((-162. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((216 0) (216 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((216 10) (227 11) (240 16) (246 27) (247 39))
    NIL
    ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 )
     (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 )
     (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 )
     (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 ))
    NATURAL)
   (2
    ((247 39) (247 139))
    NIL
    ((0 100. 0 0 0 0 ))
    NATURAL)
   (2
    ((247 139) (146 139))
    NIL
    ((-101. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((146 139) (146 39))
    NIL
    ((0 -100. 0 0 0 0 ))
    NATURAL)
   (5
    ((146 39) (147 27) (153 16) (166 11) (177 10))
    NIL
    ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 )
     (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 )
     (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 )
     (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 ))
    NATURAL)
   (2
    ((177 10) (177 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (2
    ((177 0) (15 0))
    NIL
    ((-162. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 111Q)
 (FACE M R R)
 (WIDTH 193 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 16:10:25)
 (MADE-FROM NIL 104 130 82 78)
 (SPLINES

  ((2
    ((14 0) (14 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((14 10) (25 11) (38 16) (44 27) (45 39))
    NIL
    ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 )
     (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 )
     (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 )
     (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 ))
    NATURAL)
   (2
    ((45 39) (45 255))
    NIL
    ((0 216. 0 0 0 0 ))
    NATURAL)
   (5
    ((45 255) (44 267) (38 278) (25 283) (14 284))
    NIL
    ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 )
     (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 )
     (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 )
     (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 ))
    NATURAL)
   (2
    ((14 284) (14 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((14 294) (176 294))
    NIL
    ((162. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((176 294) (176 284))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (5
    ((176 284) (165 283) (152 278) (146 267) (145 255))
    NIL
    ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 )
     (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 )
     (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 )
     (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 ))
    NATURAL)
   (2
    ((145 255) (144 39))
    NIL
    ((-1. -216. 0 0 0 0 ))
    NATURAL)
   (5
    ((144 39) (145 27) (151 16) (164 11) (175 10))
    NIL
    ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 )
     (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 )
     (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 )
     (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 ))
    NATURAL)
   (2
    ((175 10) (175 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (2
    ((175 0) (14 0))
    NIL
    ((-161. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 112Q)
 (FACE M R R)
 (WIDTH 271 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 16:11:38)
 (MADE-FROM NIL 115 130 82 78)
 (SPLINES

  ((2
    ((124 59) (124 255))
    NIL
    ((0 196. 0 0 0 0 ))
    NATURAL)
   (5
    ((124 255) (123 267) (117 278) (104 283) (93 284))
    NIL
    ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 )
     (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 )
     (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 )
     (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 ))
    NATURAL)
   (2
    ((93 284) (93 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((93 294) (255 294))
    NIL
    ((162. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((255 294) (255 284))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (5
    ((255 284) (244 283) (231 278) (225 267) (224 255))
    NIL
    ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 )
     (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 )
     (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 )
     (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 ))
    NATURAL)
   (2
    ((224 255) (223 79))
    NIL
    ((-1. -176. 0 0 0 0 ))
    NATURAL)
   (18
    ((223 79) (217 45) (197 18) (164 1) (118 -5) (78 -3)
     (42 7) (21 25) (12 53) (26 81) (56 91) (86 81)
     (101 55) (92 33) (95 15) (111 16) (124 36) (124 59))
    NIL
    ((-2.9017105 -35.337036 0 0 -18.5897369 8.0222225 )
     (-12.1965789 -31.325923 -18.5897369 8.0222225 8.9486904 1.8888855 )
     (-26.311969 -22.359256 -9.6410465 9.911108 -11.2050266 2.42223167 )
     (-41.555526 -11.2370338 -20.846073 12.3333397 35.871421 -5.57781029 )
     (-44.465889 -1.69259977 15.02535 6.7555294 -18.280677 1.88901138 )
     (-38.580879 6.0074358 -3.25532723 8.6445408 25.251281 -1.97823906 )
     (-29.210563 13.662857 21.995956 6.66630173 -16.724468 6.02394868 )
     (-15.576843 23.341133 5.27148724 12.69025 23.646598 -10.1175556 )
     (1.51794481 30.972602 28.918087 2.57269335 -11.8619308 -25.553714 )
     (24.505065 20.768436 17.056156 -22.981021 -18.198871 4.3324356 )
     (32.461784 -0.0463663712 -1.14271569 -18.648586 -11.342575 -3.77604294 )
     (25.647781 -20.582973 -12.485292 -22.424629 -26.43082 34.771736 )
     (-0.0529238358 -25.62173 -38.916114 12.3471107 63.065887 -15.310928 )
     (-7.43609429 -20.930084 24.149772 -2.96381903 -9.8327484 26.47198 )
     (11.797304 -10.657913 14.317024 23.508163 -17.734897 -0.577007294 )
     (17.246875 12.5617447 -3.41787434 22.931156 -15.227651 -24.163944 )
     (6.21517563 23.410926 -18.645526 -1.23278904 18.645526 1.23278904 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 113Q)
 (FACE M R R)
 (WIDTH 347 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 16:15:22)
 (MADE-FROM NIL 93 130 82 78)
 (SPLINES

  ((2
    ((191 284) (191 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((191 294) (311 294))
    NIL
    ((120. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((311 294) (311 286))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (4
    ((311 286) (285 273) (255 248) (208 199))
    NIL
    ((-26.066665 -11.3999996 0 0 0.399999619 -9.60000039 )
     (-25.866664 -16.1999969 0.399999619 -9.60000039 -25.999996 -23.999996 )
     (-38.466667 -37.799995 -25.599998 -33.599998 25.599998 33.599998 ))
    NATURAL)
   (4
    ((208 199) (273 90) (311 30) (335 8))
    NIL
    ((71.26666 -119.5333 0 0 -37.599998 63.199997 )
     (52.466659 -87.933319 -37.599998 63.199997 26. -22. )
     (27.866664 -35.733329 -11.599998 41.199996 11.599998 -41.199996 ))
    NATURAL)
   (2
    ((335 8) (335 0))
    NIL
    ((0 -8. 0 0 0 0 ))
    NATURAL)
   (2
    ((335 0) (192 0))
    NIL
    ((-143. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((192 0) (192 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (3
    ((192 10) (204 17) (204 28))
    NIL
    ((15. 6. 0 0 -18. 6. )
     (6. 9. -18. 6. 18. -6. ))
    NATURAL)
   (2
    ((204 28) (145 137))
    NIL
    ((-59. 109. 0 0 0 0 ))
    NATURAL)
   (2
    ((145 137) (145 39))
    NIL
    ((0 -98. 0 0 0 0 ))
    NATURAL)
   (4
    ((145 39) (146 27) (152 16) (162 10))
    NIL
    ((-0.0666666031 -11.933332 0 0 6.3999996 -0.399999857 )
     (3.1333332 -12.133333 6.3999996 -0.399999857 -2. 7.99999905 )
     (8.5333328 -8.5333328 4.39999962 7.59999943 -4.39999962 -7.59999943 ))
    NATURAL)
   (2
    ((162 10) (162 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (2
    ((162 0) (24 0))
    NIL
    ((-138. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((24 0) (24 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (4
    ((24 10) (38 16) (44 27) (45 39))
    NIL
    ((15.799999 4.73333264 0 0 -10.799999 7.59999943 )
     (10.3999996 8.5333328 -10.799999 7.59999943 6. -7.99999905 )
     (2.59999943 12.133333 -4.79999924 -0.399999976 4.79999924 0.399999976 ))
    NATURAL)
   (2
    ((45 39) (45 255))
    NIL
    ((0 216. 0 0 0 0 ))
    NATURAL)
   (4
    ((45 255) (44 267) (38 278) (24 284))
    NIL
    ((-0.199999958 11.933332 0 0 -4.80000019 0.399999857 )
     (-2.5999999 12.133333 -4.80000019 0.399999857 -5.99999905 -7.99999905 )
     (-10.3999996 8.5333328 -10.799999 -7.59999943 10.799999 7.59999943 ))
    NATURAL)
   (2
    ((24 284) (24 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((24 294) (162 294))
    NIL
    ((138. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((162 294) (162 284))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (4
    ((162 284) (152 278) (146 267) (145 255))
    NIL
    ((-10.7333316 -4.73333264 0 0 4.39999962 -7.59999943 )
     (-8.5333328 -8.5333328 4.39999962 -7.59999943 2. 7.99999905 )
     (-3.1333332 -12.133333 6.3999996 0.399999976 -6.3999996 -0.399999976 ))
    NATURAL)
   (2
    ((145 255) (145 163))
    NIL
    ((0 -92. 0 0 0 0 ))
    NATURAL)
   (7
    ((145 163) (174 190) (205 222) (221 247) (222 268) (206 280)
     (191 284))
    NIL
    ((27.587177 25.198715 0 0 8.476923 10.8076915 )
     (31.825637 30.602561 8.476923 10.8076915 -30.384613 -24.038459 )
     (25.110256 29.391021 -21.907691 -13.230768 11.0615387 13.346151 )
     (8.73333169 22.833332 -10.846153 0.115384549 -13.8615379 -11.346151 )
     (-9.04358865 17.275638 -24.70769 -11.230768 32.384613 2.03846168 )
     (-17.558971 7.06410218 7.6769228 -9.1923065 -7.6769228 9.1923065 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 114Q)
 (FACE M R R)
 (WIDTH 277 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 16:18:16)
 (MADE-FROM NIL 125 130 82 78)
 (SPLINES

  ((2
    ((12 0) (12 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((12 10) (23 11) (36 16) (42 27) (43 39))
    NIL
    ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 )
     (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 )
     (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 )
     (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 ))
    NATURAL)
   (2
    ((43 39) (43 255))
    NIL
    ((0 216. 0 0 0 0 ))
    NATURAL)
   (5
    ((43 255) (42 267) (36 278) (23 283) (12 284))
    NIL
    ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 )
     (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 )
     (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 )
     (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 ))
    NATURAL)
   (2
    ((12 284) (12 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((12 294) (174 294))
    NIL
    ((162. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((174 294) (174 284))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (5
    ((174 284) (163 283) (150 278) (144 267) (143 255))
    NIL
    ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 )
     (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 )
     (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 )
     (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 ))
    NATURAL)
   (2
    ((143 255) (143 39))
    NIL
    ((0 -216. 0 0 0 0 ))
    NATURAL)
   (8
    ((143 39) (145 29) (154 19) (184 19) (214 31) (235 51)
     (247 71) (256 101))
    NIL
    ((1.59704542 -9.46822358 0 0 2.41772652 -3.1906557 )
     (2.80590868 -11.0635509 2.41772652 -3.1906557 29.911365 15.953277 )
     (20.179317 -6.2775669 32.329093 12.7626228 -38.063201 -0.622465134 )
     (33.476806 6.17382336 -5.73411179 12.1401577 -3.658535 -1.46341705 )
     (25.913429 17.582271 -9.3926468 10.6767406 -1.30264663 -17.523868 )
     (15.869459 19.497077 -10.695293 -6.84713078 8.86911584 23.55891 )
     (9.6087246 24.429405 -1.8261764 16.71178 1.8261764 -16.71178 ))
    NATURAL)
   (2
    ((256 101) (269 98))
    NIL
    ((13. -3. 0 0 0 0 ))
    NATURAL)
   (2
    ((269 98) (256 0))
    NIL
    ((-13. -98. 0 0 0 0 ))
    NATURAL)
   (2
    ((256 0) (12 0))
    NIL
    ((-244. 0 0 0 0 0 ))
    NATURAL))))

((FAMILY TIMESROMAND)
 (CHARACTER 115Q)
 (FACE M R R)
 (WIDTH 452 0)
 (FIDUCIAL 385 385)
 (VERSION 0 30-SEP-77 16:20:58)
 (MADE-FROM NIL 35 130 82 78)
 (SPLINES

  ((2
    ((12 0) (12 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((12 10) (23 11) (36 16) (42 27) (43 39))
    NIL
    ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 )
     (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 )
     (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 )
     (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 ))
    NATURAL)
   (2
    ((43 39) (43 255))
    NIL
    ((0 216. 0 0 0 0 ))
    NATURAL)
   (5
    ((43 255) (42 267) (36 278) (23 283) (12 284))
    NIL
    ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 )
     (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 )
     (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 )
     (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 ))
    NATURAL)
   (2
    ((12 284) (12 294))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (2
    ((12 294) (148 294))
    NIL
    ((136. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((148 294) (228 121))
    NIL
    ((80. -173. 0 0 0 0 ))
    NATURAL)
   (2
    ((228 121) (304 294))
    NIL
    ((76. 173. 0 0 0 0 ))
    NATURAL)
   (2
    ((304 294) (436 294))
    NIL
    ((132. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((436 294) (436 284))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (5
    ((436 284) (425 283) (412 278) (406 267) (405 255))
    NIL
    ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 )
     (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 )
     (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 )
     (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 ))
    NATURAL)
   (2
    ((405 255) (405 39))
    NIL
    ((0 -216. 0 0 0 0 ))
    NATURAL)
   (5
    ((405 39) (406 27) (412 16) (425 11) (436 10))
    NIL
    ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 )
     (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 )
     (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 )
     (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 ))
    NATURAL)
   (2
    ((436 10) (436 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (2
    ((436 0) (274 0))
    NIL
    ((-162. 0 0 0 0 0 ))
    NATURAL)
   (2
    ((274 0) (274 10))
    NIL
    ((0 10. 0 0 0 0 ))
    NATURAL)
   (5
    ((274 10) (285 11) (298 16) (304 27) (305 39))
    NIL
    ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 )
     (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 )
     (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 )
     (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 ))
    NATURAL)
   (2
    ((305 39) (305 231))
    NIL
    ((0 192. 0 0 0 0 ))
    NATURAL)
   (2
    ((305 231) (205 0))
    NIL
    ((-100. -231. 0 0 0 0 ))
    NATURAL)
   (3
    ((205 0) (180 0) (180 0))
    NIL
    ((-31.25 0 0 0 37.5 0 )
     (-12.5 0 37.5 0 -37.5 0 ))
    NATURAL)
   (2
    ((180 0) (75 225))
    NIL
    ((-105. 225. 0 0 0 0 ))
    NATURAL)
   (2
    ((75 225) (75 39))
    NIL
    ((0 -186. 0 0 0 0 ))
    NATURAL)
   (5
    ((75 39) (76 27) (82 16) (95 11) (106 10))
    NIL
    ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 )
     (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 )
     (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 )
     (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 ))
    NATURAL)
   (2
    ((106 10) (106 0))
    NIL
    ((0 -10. 0 0 0 0 ))
    NATURAL)
   (2
    ((106 0) (12 0))
    NIL
    ((-94. 0 0 0 0 0 ))
    NATURAL))))

STOP
\ No newline at end of file
diff --git a/obsolete/sources/FILESETS.NOETHER b/obsolete/sources/FILESETS.NOETHER
deleted file mode 100644
index 0ac33fbb..00000000
--- a/obsolete/sources/FILESETS.NOETHER
+++ /dev/null
@@ -1 +0,0 @@
-(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
\ No newline at end of file
diff --git a/obsolete/sources/FILESETS.ORIG b/obsolete/sources/FILESETS.ORIG
deleted file mode 100644
index a88668a2..00000000
--- a/obsolete/sources/FILESETS.ORIG
+++ /dev/null
@@ -1 +0,0 @@
-(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
\ No newline at end of file
diff --git a/obsolete/sources/FILESETS.PUP b/obsolete/sources/FILESETS.PUP
deleted file mode 100644
index 3dac6662..00000000
--- a/obsolete/sources/FILESETS.PUP
+++ /dev/null
@@ -1 +0,0 @@
-(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
\ No newline at end of file
diff --git a/obsolete/sources/LISPBCPLFILES.DM b/obsolete/sources/LISPBCPLFILES.DM
deleted file mode 100644
index b4a5edfb..00000000
Binary files a/obsolete/sources/LISPBCPLFILES.DM and /dev/null differ
diff --git a/obsolete/sources/LOADFULL.CM b/obsolete/sources/LOADFULL.CM
deleted file mode 100644
index f2f0ba43..00000000
--- a/obsolete/sources/LOADFULL.CM
+++ /dev/null
@@ -1 +0,0 @@
-//////////////////////////////////////////////////////////////////////////
//
//				L O A D F U L L . C M
//
//	(C) Copyright 1990, Venue & Fuji Xerox, Ltd.
//	    All Rights Reserved.
//
//	Make LISP.SYSOUT and FULL.SYSOUT on {PELE:}<Lispcore>Basics>.
//
//////////////////////////////////////////////////////////////////////////
ftp ERINYES Directory/C LispCore>SOURCES Retrieve/<>A LOADFULL.CM LoadInit.cm LoadFullFromDLInit.cm

@LoadInit.CM@
@LoadFullFromDLInit.cm@
\ No newline at end of file
diff --git a/obsolete/sources/LOADFULL.LISP b/obsolete/sources/LOADFULL.LISP
deleted file mode 100644
index d5b39ee1..00000000
--- a/obsolete/sources/LOADFULL.LISP
+++ /dev/null
@@ -1 +0,0 @@
-(RESETVARS
   ((IDLE.PROFILE (QUOTE (TIMEOUT NIL))))
    (DEL.PROCESS (QUOTE IDLE))
    (SETQQ DISPLAYFONTDIRECTORIES
            ({ERIS}<LISP>FONTS>))
    (SETQQ PRESSFONTWIDTHSFILES
            ({ERIS}<LISP>FONTS>FONTS.WIDTHS))
    (SETQQ INTERPRESSFONTDIRECTORIES
            ({ERIS}<LISP>FONTS>))
    (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
    (SETQQ LOADUPDIRECTORIES
            ({Eris}<Lispcore>Sources> 
             {Eris}<Lispcore>Library> 
             {Eris}<Lispcore>Internal>Library>))
  (LOADUP (QUOTE (GIVE-AND-TAKE CHANGECONTROL CHAT PUPCHAT NSCHAT PRESS PUPPRINT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP MAILCLIENT GRAPEVINE NSMAIL LAFITE FILEBROWSER TELERAID GRAPHER SPY AREDIT WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE)))
  (\DAYTIME0 \LASTUSERACTION)
  (ENDLOADUP))
STOP
\ No newline at end of file
diff --git a/obsolete/sources/LOADFULLFROMDLINIT.CM b/obsolete/sources/LOADFULLFROMDLINIT.CM
deleted file mode 100644
index a8677653..00000000
--- a/obsolete/sources/LOADFULLFROMDLINIT.CM
+++ /dev/null
@@ -1 +0,0 @@
-//////////////////////////////////////////////////////////////////////////
//
//			L O A D F U L L F R O M D L I N I T . C M
//
//	(C) Copyright 1990, Venue & Fuji Xerox, Ltd.
//	    All Rights Reserved.
//
//	Make the INIT.DLINIT into a LISP.SYSOUT & a FULL.SYSOUT.
//
//////////////////////////////////////////////////////////////////////////
// IF YOU EDIT THIS FILE, BE SURE TO EDIT LOADFULLFROMDLINITSLOW.CM

// LoadFullFromDLInit.cm, edited   8-Mar-87 15:40:50 vanMelle



// ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE



// bring over files necessary to run INIT.DLINIT.

FTP/-E ERINYES Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb;

// start up DLInit. MAKESYSNAME gets set here. The (SPECVARS . T) is because some file in the loadup (unknown) sets it wrong

Lisp {DSK6}Init.DLInit ;"
(SETQQ MAKESYSNAME LISPCORE)
(PROGN (LOAD (QUOTE \"{Pele:MV:Envos}<LISPCORE>SOURCES>LOADUP.LISP\")) (HARDRESET))
SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS '\"{Pele:MV:Envos}<LISPCORE>Basics>LISP.SYSOUT\"))
SHH(PROGN (IL:LOAD '\"{Pele:MV:Envos}<LISPCORE>SOURCES>LOADFULL.LISP\") (IL:MAKESYS '\"{Pele:MV:Envos}<LISPCORE>Basics>FULL.SYSOUT\") (IL:LOGOUT T))


"

\ No newline at end of file
diff --git a/obsolete/sources/LOADFULLFROMDLINITSLOW.CM b/obsolete/sources/LOADFULLFROMDLINITSLOW.CM
deleted file mode 100644
index 9058d7f3..00000000
--- a/obsolete/sources/LOADFULLFROMDLINITSLOW.CM
+++ /dev/null
@@ -1 +0,0 @@
-// IF YOU EDIT THIS FILE, BE SURE TO EDIT LOADFULLFROMDLINIT.CM


// LoadFullFromDLInitSlow.cm, edited  8-Mar-87 15:40:50 vanMelle


// ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE



// bring over files necessary to run INIT.DLINIT.
FTP/-E ERIS Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb;

// start up DLInit. MAKESYSNAME gets set here. The (SPECVARS . T) is because some file in the loadup (unknown) sets it wrong

Lisp [ERIS]<LispCore>Next>Init.dlinit ;"
(SETQQ MAKESYSNAME LISPCORE)
(PROGN (LOAD (QUOTE {ERIS}<LISPCORE>SOURCES>LOADUP.LISP))(HARDRESET))
SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:* IL:MAKESYS '{ERIS}<LISPCORE>NEXT>LISP.SYSOUT))
SHH(PROGN (IL:LOAD '{ERIS}<LISPCORE>SOURCES>LOADFULL.LISP) (IL:MAKESYS '{ERIS}<LISPCORE>NEXT>FULL.SYSOUT) (IL:LOGOUT T))

"

\ No newline at end of file
diff --git a/obsolete/sources/LOADFULLFROMLISP.CM b/obsolete/sources/LOADFULLFROMLISP.CM
deleted file mode 100644
index 64c731cd..00000000
--- a/obsolete/sources/LOADFULLFROMLISP.CM
+++ /dev/null
@@ -1 +0,0 @@
-// LoadFullFromLisp.cm Edited 24-Feb-87 19:10:47 -- van Melle --

Delete INIT.DFASL!* INIT.SAVE* // otherwise Lisp might read INIT.DFASL!2
Copy INIT.SAVE _ INIT.DFASL  // save away site file to be restored below

FTP/-E ERIS Login/C Dir/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb Ret/S <Lisp>Current>Init.null Init.DFASL

Lisp [ERIS]<LispCore>Next>Lisp.sysout ;"  
SHH(PROGN (DELFILE '{DSK}INIT.DFASL) (RENAMEFILE '{DSK}INIT.SAVE '{DSK}INIT.DFASL;1) )
SHH(LOAD '{ERIS}<LISPCORE>SOURCES>LOADFULL.LISP)
SHH(MAKESYS '{ERIS}<LISPCORE>NEXT>FULL.SYSOUT]
SHH(LOGOUT] "

\ No newline at end of file
diff --git a/obsolete/sources/LOADFULLSLOW.CM b/obsolete/sources/LOADFULLSLOW.CM
deleted file mode 100644
index 33eaa7e8..00000000
--- a/obsolete/sources/LOADFULLSLOW.CM
+++ /dev/null
@@ -1 +0,0 @@
-ftp ERIS Directory/C LispCore>SOURCES Retrieve/<>A LOADFULLSLOW.CM LoadInitSlow.cm LoadFullFromDLInitSlow.cm

@LoadInitSlow.CM@
@LoadFullFromDLInitSlow.cm@
\ No newline at end of file
diff --git a/obsolete/sources/LOADINIT.CM b/obsolete/sources/LOADINIT.CM
deleted file mode 100644
index 3353168f..00000000
--- a/obsolete/sources/LOADINIT.CM
+++ /dev/null
@@ -1 +0,0 @@
-//////////////////////////////////////////////////////////////////////////
//
//				L O A D I N I T . C M
//
//	(C) Copyright 1990, Venue & Fuji Xerox, Ltd.
//	    All Rights Reserved.
//
//	Make the INIT.DLINIT starting sysout for a new loadup.
//
//////////////////////////////////////////////////////////////////////////
// IF YOU EDIT THIS FILE, EDIT LOADINITSLOW.CM TOO!!!!

// Edit November 3, 1987 by vanMelle, note comment ^^

// The path given to the Lisp command below should point to the LispCore sysout cache.
// Code that runs after Lisp starts up assures that the cached sysout
// is the most recent, and if not, fetches a new one and restarts itself.
// Edited so that the most recent patch file is loaded
// Updated Lisp version for big physical memory --bvm 11/3/87

Delete INIT.DFASL!* INIT.SAVE* // otherwise Lisp might read INIT.LISP!2
Copy INIT.SAVE _ INIT.DFASL  // save away site file to be restored below

FTP/-E ERINYES Login/C Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb Ret/S <Lisp>Current>Init-NOGREET Init.DFASL

Lisp {DSK7}LispCore.Sysout;"
(XCL:RESTORE-PROFILE \"INTERLISP\")
(DELFILE '{DSK}INIT.DFASL)
(AND (INFILEP '{DSK}INIT.SAVE) (RENAMEFILE '{DSK}INIT.SAVE '{DSK}INIT.DFASL))
(DIRECTORY '{DSK6}INIT.DLINIT;* '(DELETE))
(* Make sure we have a valid sysout)
(LET
((DATE (CAR (NLSETQ (GETFILEINFO '{Pele:mv:envos}<LispCore>Saved>FULL.SYSOUT 'ICREATIONDATE)))))
(IF (AND DATE (IGREATERP DATE (GETFILEINFO '{DSK7}LispCore.Sysout;1 'ICREATIONDATE)))
THEN (* Get new saved sysout)
(NLSETQ (PROGN
(COPYFILE '{Pele:mv:envos}<LispCore>Saved>FULL.SYSOUT '{DSK7}LispCore.Sysout;1)
(COPYFILE '{DSK}REM.CM;1 '{CORE}REM.CM) (* Repeat current command now)
(OUTFILE '{DSK}REM.CM;1)
(PRIN1 '@LoadInit.cm@)
(COPYBYTES (OPENSTREAM '{CORE}REM.CM 'INPUT))
(CLOSEF)
(LOGOUT T]
(PROGN (* Make old sysout work with new read tables)
   (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM FILERDTBL)
   (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM CODERDTBL)
   (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM \\ORIGREADTABLE))
(LOAD \"{Pele:mv:envos}<LISPCORE>NEXT>LOAD-LISPCORE-PATCH\")
CONN \"{pele:mv:envos}<LispCore>SOURCES>\"
(SETQ DIRECTORIES '(\"{Pele:MV:Envos}<LISPCORE>SOURCES>\"
\"{Pele:MV:Envos}<LISPCORE>LIBRARY>\" \"{Pele:MV:Envos}<LISPCORE>INTERNAL>LIBRARY>\"))
(SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)
(SETQ *REMOVE-INTERLISP-COMMENTS* NIL)
(* Get new exports since last loadup)
(LOAD 'CONDITION-PACKAGE.LCOM 'SYSLOAD)
(LOAD 'XCL-PACKAGE.LCOM 'SYSLOAD)
(* FILESETS has where to get things from)
(LOAD 'FILESETS) 
(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
(* Versions are Lisp Microcode Bcpl)
(PROGN
 (CNDIR '{CORE})
 (IDLE.SET.OPTION 'TIMEOUT 0)
 (IDLE.SET.OPTION 'SAVEVM 0)
 (DORENAME 'I)
 (DLFIXINIT
   (MAKEINIT '(115000Q 13062Q 25400Q)
     NIL NIL
     '(\"{Pele:MV:Envos}<LISPCORE>SOURCES>\" \"{Pele:MV:Envos}<LISPCORE>INTERNAL>LIBRARY>\" \"{Pele:MV:Envos}<LISPCORE>LIBRARY>\"))
   '{DSK6}INIT.DLINIT
   \"{Pele:MV:Envos}<LISPCORE>NEXT>LispDLion.db\"
    300)
 (LOGOUT T]]
" 

\ No newline at end of file
diff --git a/obsolete/sources/LOADINITSLOW.CM b/obsolete/sources/LOADINITSLOW.CM
deleted file mode 100644
index 5628c9a8..00000000
--- a/obsolete/sources/LOADINITSLOW.CM
+++ /dev/null
@@ -1 +0,0 @@
-// LoadInitSlow.cm edited: November 3, 1987 by vanMelle
// IF YOU EDIT THIS FILE, EDIT LOADINIT.CM TOO

// edit 30-Nov-86 12:06:48 by masinter, merge LOADINIT changes, add comment above
// Updated Lisp version for big physical memory --bvm 11/3/87


// The path given to the Lisp command below should point to the LispCore sysout cache.

Delete INIT.DFASL!* INIT.SAVE* // otherwise Lisp might read INIT.LISP!2
Copy INIT.SAVE _ INIT.DFASL  // save away site file to be restored below

FTP/-E ERIS Login/C Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb Ret/S <Lisp>Current>Init-NOGREET Init.DFASL

Lisp [ERIS]<LispCore>saved>Full.Sysout;"
(XCL:RESTORE-PROFILE \"INTERLISP\")
(DELFILE '{DSK}INIT.DFASL)
(AND (INFILEP '{DSK}INIT.SAVE) (RENAMEFILE '{DSK}INIT.SAVE '{DSK}INIT.DFASL))
(PROGN (* Make old sysout work with new read tables)
   (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM FILERDTBL)
   (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM CODERDTBL)
   (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM \\ORIGREADTABLE))
(LOAD '{ERIS}<LISPCORE>NEXT>LOAD-LISPCORE-PATCH)
CONN {ERIS}<LispCore>SOURCES>
(SETQ DIRECTORIES '({ERIS}<LISPCORE>SOURCES>
{ERIS}<LISPCORE>LIBRARY> {ERIS}<LISPCORE>INTERNAL>LIBRARY>))
(SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL)
(SETQ *REMOVE-INTERLISP-COMMENTS* NIL)
(* Get new exports since last loadup)
(LOAD 'CONDITION-PACKAGE.LCOM 'SYSLOAD)
(LOAD 'XCL-PACKAGE.LCOM 'SYSLOAD)
(* FILESETS has where to get things from)
(LOAD 'FILESETS) 
(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
(* Versions are Lisp Microcode Bcpl)
(PROGN
 (CNDIR '{CORE})
 (IDLE.SET.OPTION 'TIMEOUT 0)
 (IDLE.SET.OPTION 'SAVEVM 0)
 (DORENAME 'I)
 (DLFIXINIT
   (MAKEINIT '(115000Q 13062Q 25400Q)
     NIL NIL
     '({ERIS}<LISPCORE>SOURCES> {ERIS}<LISPCORE>LIBRARY>))
   '{ERIS}<LISPCORE>NEXT>INIT.DLINIT
   '{ERIS}<LISPCORE>NEXT>LispDLion.db
    300)
 (LOGOUT T]]
" 

\ No newline at end of file
diff --git a/obsolete/sources/LOADUP.LISP b/obsolete/sources/LOADUP.LISP
deleted file mode 100644
index 5f2c4783..00000000
--- a/obsolete/sources/LOADUP.LISP
+++ /dev/null
@@ -1,53 +0,0 @@
-(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)))
-(* ;; "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)))
-(* ;; "needed for makesys")
-(LOADUP (QUOTE (MOD44IO)))
-(* ;; 
-"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 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 (HARDCOPY LOGOW IDLER ICONW FREEMENU SEDIT)))
-(CLOSEW (LOGOW)) (MOVD 'NILL 'LOGOW)
-(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)
- (* ;; "Additional stuff that should be folded into original definitions")
-  (LOADUP (QUOTE (LOADUP-LISP)))
-  STOP
-  
diff --git a/obsolete/sources/LispDMC.DM b/obsolete/sources/LispDMC.DM
deleted file mode 100644
index e88c9f69..00000000
Binary files a/obsolete/sources/LispDMC.DM and /dev/null differ
diff --git a/obsolete/sources/MAPATOMS b/obsolete/sources/MAPATOMS
deleted file mode 100644
index 299f47a3..00000000
--- a/obsolete/sources/MAPATOMS
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "29-Mar-95 11:53:28" |{DSK}<lispcore>sources>MAPATOMS.;2| 3719   

      |changes| |to:|  (FNS MAPATOMS)

      |previous| |date:| "29-Mar-95 10:47:32" |{DSK}<lispcore>sources>MAPATOMS.;1|)


(PRETTYCOMPRINT MAPATOMSCOMS)

(RPAQQ MAPATOMSCOMS ((FNS MAPATOMS)))
(DEFINEQ

(MAPATOMS
  (LAMBDA (FN)                                       (* \; "Edited 29-Mar-95 11:52 by sybalsky")

    (* |;;| "8-FEB-92 JDS:  We now switch over into big-atom mode at 12288  (changes in \\CREATE.SYMBOL should be lected here)")

    (PROG ((A 0)
           (DTD (\\GETDTD \\NEW-ATOM)))
          (|for| |old| A |from| 0 |to| (IMIN |\\AtomFrLst| 12286)
             |do| (APPLY* FN (\\INDEXATOMPNAME A)))
          (COND
             ((IGREATERP |\\AtomFrLst| 12286)
              (LET* ((SIZE (|fetch| DTDSIZE |of| DTD))
                     (ATOM# A)
                     (FIRSTFREE (|fetch| DTDFREE |of| DTD))
                     (LASTFREE (|create| POINTER
                                      PAGE# _ (LOGAND (|fetch| (POINTER PAGE#) |of| FIRSTFREE
                                                             )
                                                     65534)))
                     (LASTFREE2 (|create| POINTER
                                       PAGE# _ (ADD1 (LOGAND (|fetch| (POINTER PAGE#)
                                                                |of| FIRSTFREE)
                                                            65534))))
                     RESULT FIRSTPAGE LASTPAGE LIMIT)
                    (COND
                       ((.ALLOCATED.PER.PAGE. SIZE)
                        (SETQ LASTPAGE (SUB1 |\\PagesPerMDSUnit|))
                        (SETQ LIMIT WORDSPERPAGE))
                       (T (SETQ LASTPAGE 0)
                          (SETQ LIMIT (FOLDLO |\\MDSIncrement| |\\PagesPerMDSUnit|))))
                    (|for| MDSPAGE# |from| 0 |by| (ADD1 LASTPAGE)
                       |while| (<= MDSPAGE# \\MAXVMPAGE) |when| (EQ (MDSTYPE# MDSPAGE#)
                                                                            \\NEW-ATOM)
                       |do| 

                             (* |;;| 
                    "Now collect all pointers not on free list.  This code parallels \\INITMDSPAGE")

                             (|for| N |from| 0 |to| LASTPAGE
                                |do| (SETQ FIRSTPAGE (|create| POINTER
                                                                PAGE# _ (IPLUS N MDSPAGE#)))
                                      (|for| (DISP _ 0) |while| (<= (|add| DISP SIZE)
                                                                            LIMIT)
                                         |as| (DATUMBASE _ FIRSTPAGE)
                                         |by| (\\ADDBASE DATUMBASE SIZE)
                                         |when| (OR (AND (NEQ FIRSTPAGE LASTFREE)
                                                             (NEQ FIRSTPAGE LASTFREE2))
                                                        (|for| (FREE _ FIRSTFREE)
                                                           |by| (\\GETBASEPTR FREE 0)
                                                           |while| FREE
                                                           |never| (EQ DATUMBASE FREE)))
                                         |do| (APPLY* FN DATUMBASE)
                                               (|add| ATOM# 1))))
                    NIL))))))
)
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (341 3696 (MAPATOMS 351 . 3694)))))
STOP
\ No newline at end of file
diff --git a/obsolete/sources/MAPATOMS.LCOM b/obsolete/sources/MAPATOMS.LCOM
deleted file mode 100644
index a09cf6f2..00000000
Binary files a/obsolete/sources/MAPATOMS.LCOM and /dev/null differ
diff --git a/obsolete/sources/NEW-EDIT-INTERFACE b/obsolete/sources/NEW-EDIT-INTERFACE
deleted file mode 100644
index 2c6a174e..00000000
--- a/obsolete/sources/NEW-EDIT-INTERFACE
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "25-Jan-91 16:57:19" |{DSK}<users>woz>SOURCES>NEW-EDIT-INTERFACE.;8| 6497   

      |changes| |to:|  (FUNCTIONS XCL::EDIT-EXPRESSION XCL::EDIT-DEFINITION XCL::EDIT 
                              SEDIT::EDIT-EXPRESSION SEDIT::MYED)
                       (VARS NEW-EDIT-INTERFACECOMS)

      |previous| |date:| " 3-Dec-90 18:01:41" |{DSK}<users>woz>SOURCES>NEW-EDIT-INTERFACE.;1|)


; Copyright (c) 1990, 1991 by Venue.  All rights reserved.

(PRETTYCOMPRINT NEW-EDIT-INTERFACECOMS)

(RPAQQ NEW-EDIT-INTERFACECOMS ((FUNCTIONS XCL::EDIT XCL::EDIT-DEFINITION XCL::EDIT-EXPRESSION)))

(CL:DEFUN XCL::EDIT (CL:STRUCTURE XCL::PROPS XCL::OPTIONS)

(* |;;;| "this is the new way to start the current editor, once you have all the props and options figured out.")

   (CL:UNLESS (CL:LISTP XCL::OPTIONS)
       (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS)))
   (CL:FUNCALL (EDITMODE)
          CL:STRUCTURE XCL::PROPS XCL::OPTIONS))

(CL:DEFUN XCL::EDIT-DEFINITION (XCL::NAME TYPE &OPTIONAL XCL::SOURCE XCL::OPTIONS XCL::PROPS)

(* |;;;| "this is a new version of IL:EDITDEF, consistent with the new definition of how to start the current editor.  figure out how to get the definition (same as il:editdef), then build the necessary stuff to start the editor and have completion work properly.  since we have a \"definition\" there is no need for a root-changed-fn, because putdef will be handed the right structure on completion anyway.  Do not wait for completion, just return NAME.")

   (CL:UNLESS (CL:LISTP XCL::OPTIONS)
       (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS)))
   (LET* ((XCL::DEFINITION (COND
                              (XCL::SOURCE (GETDEF XCL::NAME TYPE XCL::SOURCE '(EDIT NOCOPY)))
                              ((GETDEF XCL::NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR)))
                              ((GETDEF XCL::NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR)))
                              (T (LET ((XCL::FILES (WHEREIS XCL::NAME TYPE T)))
                                      (CL:IF (NULL XCL::FILES)
                                          (CL:FORMAT T "~S has no ~A definition.~%" XCL::NAME TYPE)
                                          (LET ((XCL::FILE (PROGN (CL:FORMAT T 
                                                                       "~S is contained on~{ ~S~}.~%"
                                                                         XCL::NAME XCL::FILES)
                                                                  (CL:IF (CL:ENDP (CDR XCL::FILES))
                                                                      (CL:IF (CL:Y-OR-N-P 
                                                                      "Shall I load this file PROP? "
                                                                                    )
                                                                             (CAR XCL::FILES))
                                                                      (ASKUSER NIL NIL 
                                                                 "indicate which file to load PROP: "
                                                                             (MAKEKEYLST XCL::FILES)
                                                                             T)))))
                                               (CL:WHEN XCL::FILE
                                                   (LOAD XCL::FILE 'PROP)
                                                   (GETDEF XCL::NAME TYPE '? '(EDIT NOCOPY)))))))))
          (XCL::USER-COMPLETION (LISTGET XCL::PROPS :COMPLETION-FN))
          (XCL::COMPLETION-FN #'(CL:LAMBDA (XCL::CONTEXT XCL::NEW-DEF XCL::CHANGED?)
                                       (CL:WHEN XCL::USER-COMPLETION (CL:FUNCALL XCL::USER-COMPLETION
                                                                            XCL::CONTEXT XCL::NEW-DEF
                                                                            XCL::CHANGED?))
                                       (CL:WHEN (EQ XCL::CHANGED? T)

                                           (* |;;| "don't reinstall on :ABORT or NIL (no changes)")

                                           (PUTDEF XCL::NAME TYPE XCL::NEW-DEF 'CHANGED)))))
         (CL:WHEN XCL::DEFINITION
             (XCL::EDIT XCL::DEFINITION (LIST :NAME XCL::NAME :TYPE TYPE :COMPLETION-FN 
                                                  XCL::COMPLETION-FN)
                    XCL::OPTIONS))
         XCL::NAME))

(CL:DEFUN XCL::EDIT-EXPRESSION (XCL::EXPR &OPTIONAL XCL::OPTIONS XCL::PROPS)

(* |;;;| "similar to ED, but just a one-time un-named edit of an expression.  start the editor with :close-on-completion, wait until the edit session completes, and return the structure.  Copy the expression before starting the editor so that changes won't be destructive, then recreate eqness on completion.  This way aborted changes will not be kept.")

   (CL:UNLESS (CL:CONSP XCL::EXPR)
       (CL:ERROR "~S - Not Editable.  Must be a list expression." XCL::EXPR)
       (CL:RETURN-FROM XCL::EDIT-EXPRESSION NIL))
   (CL:UNLESS (CL:LISTP XCL::OPTIONS)
       (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS)))
   (LET* ((XCL::EVENT (CREATE.EVENT "EDIT-EXPRESSION Completion"))
          (XCL::USER-COMPLETION (LISTGET XCL::PROPS :COMPLETION-FN))
          (XCL::NEW-EXPR NIL)
          (XCL::COMPLETION-FN #'(CL:LAMBDA (XCL::CONTEXT CL:STRUCTURE XCL::CHANGED?)
                                       (CL:WHEN XCL::USER-COMPLETION (CL:FUNCALL XCL::USER-COMPLETION
                                                                            XCL::CONTEXT CL:STRUCTURE
                                                                            XCL::CHANGED?))
                                       (CL:WHEN (EQ XCL::CHANGED? T)
                                              (CL:SETQ XCL::NEW-EXPR CL:STRUCTURE))
                                       (NOTIFY.EVENT XCL::EVENT))))
         (XCL::EDIT (CL:COPY-TREE XCL::EXPR)
                (LIST :COMPLETION-FN XCL::COMPLETION-FN)
                (LIST* :CLOSE-ON-COMPLETION XCL::OPTIONS))
         (CL:UNLESS (CL:MEMBER :DONTWAIT XCL::OPTIONS)
                (AWAIT.EVENT XCL::EVENT))
         (CL:IF (AND XCL::NEW-EXPR (CL:CONSP XCL::NEW-EXPR))
             (RPLNODE2 XCL::EXPR (CL:COPY-TREE XCL::NEW-EXPR))
             XCL::EXPR)))
(PUTPROPS NEW-EDIT-INTERFACE COPYRIGHT ("Venue" 1990 1991))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/obsolete/sources/NEW-EDIT-INTERFACE.LCOM b/obsolete/sources/NEW-EDIT-INTERFACE.LCOM
deleted file mode 100644
index db8f911d..00000000
--- a/obsolete/sources/NEW-EDIT-INTERFACE.LCOM
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "25-Jan-98 18:00:13" ("compiled on " |{DSK}<lispcore>sources>NEW-EDIT-INTERFACE.;1|) 
"30-Mar-95 20:33:04" |bcompl'd| |in| "Medley 14-Aug-95 ..." |dated| "14-Aug-95 15:27:48")
(FILECREATED "25-Jan-91 16:57:19" |{DSK}<users>woz>SOURCES>NEW-EDIT-INTERFACE.;8| 6497 |changes| |to:|
 (FUNCTIONS XCL::EDIT-EXPRESSION XCL::EDIT-DEFINITION XCL::EDIT SEDIT::EDIT-EXPRESSION SEDIT::MYED) (
VARS NEW-EDIT-INTERFACECOMS) |previous| |date:| " 3-Dec-90 18:01:41" 
|{DSK}<users>woz>SOURCES>NEW-EDIT-INTERFACE.;1|)
(PRETTYCOMPRINT NEW-EDIT-INTERFACECOMS)
(RPAQQ NEW-EDIT-INTERFACECOMS ((FUNCTIONS XCL::EDIT XCL::EDIT-DEFINITION XCL::EDIT-EXPRESSION)))
(CL:DEFUN XCL::EDIT (CL:STRUCTURE XCL::PROPS XCL::OPTIONS) (* |;;;| 
"this is the new way to start the current editor, once you have all the props and options figured out."
) (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (CL:FUNCALL (EDITMODE
) CL:STRUCTURE XCL::PROPS XCL::OPTIONS))
(CL:DEFUN XCL::EDIT-DEFINITION (XCL::NAME TYPE &OPTIONAL XCL::SOURCE XCL::OPTIONS XCL::PROPS) (* |;;;|
 
"this is a new version of IL:EDITDEF, consistent with the new definition of how to start the current editor.  figure out how to get the definition (same as il:editdef), then build the necessary stuff to start the editor and have completion work properly.  since we have a \"definition\" there is no need for a root-changed-fn, because putdef will be handed the right structure on completion anyway.  Do not wait for completion, just return NAME."
) (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (LET* ((XCL::DEFINITION
 (COND (XCL::SOURCE (GETDEF XCL::NAME TYPE XCL::SOURCE (QUOTE (EDIT NOCOPY)))) ((GETDEF XCL::NAME TYPE
 (QUOTE CURRENT) (QUOTE (EDIT NOCOPY NOERROR)))) ((GETDEF XCL::NAME TYPE (QUOTE SAVED) (QUOTE (EDIT 
NOCOPY NOERROR)))) (T (LET ((XCL::FILES (WHEREIS XCL::NAME TYPE T))) (CL:IF (NULL XCL::FILES) (CL:FORMAT
 T "~S has no ~A definition.~%" XCL::NAME TYPE) (LET ((XCL::FILE (PROGN (CL:FORMAT T 
"~S is contained on~{ ~S~}.~%" XCL::NAME XCL::FILES) (CL:IF (CL:ENDP (CDR XCL::FILES)) (CL:IF (
CL:Y-OR-N-P "Shall I load this file PROP? ") (CAR XCL::FILES)) (ASKUSER NIL NIL 
"indicate which file to load PROP: " (MAKEKEYLST XCL::FILES) T))))) (CL:WHEN XCL::FILE (LOAD XCL::FILE
 (QUOTE PROP)) (GETDEF XCL::NAME TYPE (QUOTE ?) (QUOTE (EDIT NOCOPY)))))))))) (XCL::USER-COMPLETION (
LISTGET XCL::PROPS :COMPLETION-FN)) (XCL::COMPLETION-FN (CL:FUNCTION (CL:LAMBDA (XCL::CONTEXT 
XCL::NEW-DEF XCL::CHANGED?) (CL:WHEN XCL::USER-COMPLETION (CL:FUNCALL XCL::USER-COMPLETION XCL::CONTEXT
 XCL::NEW-DEF XCL::CHANGED?)) (CL:WHEN (EQ XCL::CHANGED? T) (* |;;| 
"don't reinstall on :ABORT or NIL (no changes)") (PUTDEF XCL::NAME TYPE XCL::NEW-DEF (QUOTE CHANGED)))
)))) (CL:WHEN XCL::DEFINITION (XCL::EDIT XCL::DEFINITION (LIST :NAME XCL::NAME :TYPE TYPE 
:COMPLETION-FN XCL::COMPLETION-FN) XCL::OPTIONS)) XCL::NAME))
(CL:DEFUN XCL::EDIT-EXPRESSION (XCL::EXPR &OPTIONAL XCL::OPTIONS XCL::PROPS) (* |;;;| 
"similar to ED, but just a one-time un-named edit of an expression.  start the editor with :close-on-completion, wait until the edit session completes, and return the structure.  Copy the expression before starting the editor so that changes won't be destructive, then recreate eqness on completion.  This way aborted changes will not be kept."
) (CL:UNLESS (CL:CONSP XCL::EXPR) (CL:ERROR "~S - Not Editable.  Must be a list expression." XCL::EXPR
) (CL:RETURN-FROM XCL::EDIT-EXPRESSION NIL)) (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS 
(LIST XCL::OPTIONS))) (LET* ((XCL::EVENT (CREATE.EVENT "EDIT-EXPRESSION Completion")) (
XCL::USER-COMPLETION (LISTGET XCL::PROPS :COMPLETION-FN)) (XCL::NEW-EXPR NIL) (XCL::COMPLETION-FN (
CL:FUNCTION (CL:LAMBDA (XCL::CONTEXT CL:STRUCTURE XCL::CHANGED?) (CL:WHEN XCL::USER-COMPLETION (
CL:FUNCALL XCL::USER-COMPLETION XCL::CONTEXT CL:STRUCTURE XCL::CHANGED?)) (CL:WHEN (EQ XCL::CHANGED? T
) (CL:SETQ XCL::NEW-EXPR CL:STRUCTURE)) (NOTIFY.EVENT XCL::EVENT))))) (XCL::EDIT (CL:COPY-TREE XCL::EXPR
) (LIST :COMPLETION-FN XCL::COMPLETION-FN) (LIST* :CLOSE-ON-COMPLETION XCL::OPTIONS)) (CL:UNLESS (
CL:MEMBER :DONTWAIT XCL::OPTIONS) (AWAIT.EVENT XCL::EVENT)) (CL:IF (AND XCL::NEW-EXPR (CL:CONSP 
XCL::NEW-EXPR)) (RPLNODE2 XCL::EXPR (CL:COPY-TREE XCL::NEW-EXPR)) XCL::EXPR)))
(PUTPROPS NEW-EDIT-INTERFACE COPYRIGHT ("Venue" 1990 1991))
NIL
\ No newline at end of file
diff --git a/obsolete/sources/POSTLOADUP b/obsolete/sources/POSTLOADUP
deleted file mode 100644
index 3b6e5450..00000000
--- a/obsolete/sources/POSTLOADUP
+++ /dev/null
@@ -1,37 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED "16-May-90 21:05:36" {DSK}<usr>local>lde>lispcore>sources>POSTLOADUP.;2 870    
-
-      changes to%:  (VARS POSTLOADUPCOMS)
-
-      previous date%: " 8-DEC-81 15:27:54" {DSK}<usr>local>lde>lispcore>sources>POSTLOADUP.;1)
-
-
-(* ; "
-Copyright (c) 1990 by Venue.  All rights reserved.
-")
-
-(PRETTYCOMPRINT POSTLOADUPCOMS)
-
-(RPAQQ POSTLOADUPCOMS
-       [(* set up so that files can be loaded directly from phylum)
-        (* turn off checking for dates of source)
-        (P (MOVD 'NILL 'LOADUP2A)
-           (CHANGENAME 'LOADUP2 'ASSOC 'TRUE])
-
-
-
-(* set up so that files can be loaded directly from phylum)
-
-
-
-
-(* turn off checking for dates of source)
-
-
-(MOVD 'NILL 'LOADUP2A)
-
-(CHANGENAME 'LOADUP2 'ASSOC 'TRUE)
-(PUTPROPS POSTLOADUP COPYRIGHT ("Venue" 1990))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
diff --git a/obsolete/sources/POSTLOADUP.LCOM b/obsolete/sources/POSTLOADUP.LCOM
deleted file mode 100644
index e46fea2b..00000000
--- a/obsolete/sources/POSTLOADUP.LCOM
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "26-Jan-98 13:27:16" ("compiled on " 
{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>POSTLOADUP.;1) "30-Mar-95 20:33:04" bcompl'd in 
"Medley 14-Aug-95 ..." dated "14-Aug-95 15:27:48")
(FILECREATED "16-May-90 21:05:36" {DSK}<usr>local>lde>lispcore>sources>POSTLOADUP.;2 870 changes to%: 
(VARS POSTLOADUPCOMS) previous date%: " 8-DEC-81 15:27:54" 
{DSK}<usr>local>lde>lispcore>sources>POSTLOADUP.;1)
(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)))))
(MOVD (QUOTE NILL) (QUOTE LOADUP2A))
(CHANGENAME (QUOTE LOADUP2) (QUOTE ASSOC) (QUOTE TRUE))
(PUTPROPS POSTLOADUP COPYRIGHT ("Venue" 1990))
NIL
\ No newline at end of file
diff --git a/obsolete/sources/SUNFONT b/obsolete/sources/SUNFONT
deleted file mode 100644
index c449f5e4..00000000
--- a/obsolete/sources/SUNFONT
+++ /dev/null
@@ -1,32 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-(FILECREATED "28-Jan-98 10:46:39" |{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>SUNFONT.;2| 1164   
-
-      |changes| |to:|  (VARS DISPLAYFONTDIRECTORIES)
-
-      |previous| |date:| "24-Jan-90 15:53:22" 
-|{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>SUNFONT.;1|)
-
-
-; Copyright (c) 1990, 1998 by John Sybalsky.  All rights reserved.
-
-(PRETTYCOMPRINT SUNFONTCOMS)
-
-(RPAQQ SUNFONTCOMS ((VARS DISPLAYFONTDIRECTORIES)))
-
-(RPAQQ DISPLAYFONTDIRECTORIES (
-                              "{DSK}~/lispcore/fonts/display/presentation/"
-                                   
-                                "{DSK}~/lispcore/fonts/display/PRINTWHEEL/"
-                                   
-                                "{DSK}~/lispcore/fonts/display/publishing/"
-                                   
-                             "{DSK}~/lispcore/fonts/display/miscellaneous/"
-                                   ))
-(PUTPROPS SUNFONT COPYRIGHT ("John Sybalsky" 1990 1998))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
-
-
-
-
diff --git a/obsolete/sources/SYNCLISPFILES b/obsolete/sources/SYNCLISPFILES
deleted file mode 100644
index 6f003db6..00000000
--- a/obsolete/sources/SYNCLISPFILES
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 6-Feb-2021 15:19:48" {DSK}<home>larry>ilisp>medley>sources>SYNCLISPFILES.;2 7670   

      changes to%:  (FNS SYNCLISPFILES)

      previous date%: " 5-Feb-2021 15:41:04" {DSK}<home>larry>ilisp>medley>sources>SYNCLISPFILES.;1
)


(PRETTYCOMPRINT SYNCLISPFILESCOMS)

(RPAQQ SYNCLISPFILESCOMS ((FNS)
                              (FNS SYNCLISPFILES NOPUPPATCH)))
(DEFINEQ

(SYNCLISPFILES
  [LAMBDA (NOSYSLOAD)                                  (* ; "Edited  6-Feb-2021 15:16 by larry")
                                                             (* ; "Edited  5-Feb-2021 15:40 by lmm")
                                                             (* ; 
                                                           "Edited 23-Oct-2020 23:51 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 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 MEDLEYDIR")

    (LET ((SKIPFILES '(SYNCLISPFILES))
          (SOURCEDIR (MEDLEYDIR "sources")))

         (* ;; 
      "FASLOAD has to come first, unconditionally, to get the DFASL file dates converted properly.")

         (PRINTOUT T T "Synchronizing Lisp sysout at " (DATE)
                T)
         (PRINTOUT T 5 (CDAR (GETP 'SYNCLISPFILES 'FILEDATES))
                T 5 "created " (CAAR (GETP 'SYNCLISPFILES 'FILEDATES))
                T T)

         (* ;; 
      "FASLOAD has to come first, unconditionally, to get the DFASL file dates converted properly.")

         (push SKIPFILES 'FASLOAD)
         (LOAD (MEDLEYDIR "sources" "FASLOAD.DFASL")
               (IF NOSYSLOAD
                   THEN NIL
                 ELSE 'SYSLOAD))
         (push SKIPFILES 'ATBL)                          (* ; 
                                                   "Whole file can't be reloaded--smashes readtabl")
         (LOADFNS '(\ATBLSET \MAPCHARTABLE RESETREADTABLE)
                (MEDLEYDIR "sources" "ATBL.LCOM")
                'SYSLOAD)
         (LOADVARS '\KEYNAMES (MEDLEYDIR "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")
         (push SKIPFILES 'SUNFONT)                       (* ; 
                                                           "Old font organization, not relevant")
         (for LF FF CFILE LOADEDDATE FILEDATE IFILEDATE NOCOMPILEDFILES CFILES (COUNT _ 0)
            in (LDIFFERENCE SYSFILES SKIPFILES)
            do [SETQ LOADEDDATE (CAAR (GETP LF 'FILEDATES] 
                                                             (* ; 
                                              "Date of symbolic file whose compile file was loaded")
                  (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))              (* ; "Date of current source file")
                  (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 (COND
                                 [CFILES 

                                        (* ;; 
                                      "If more than one (LCOM, DFASL), pick the newest one.")

                                        (for CF in CFILES
                                           largest (IDATE (FILEDATE CF T]
                                 (T (PRINTOUT T "Note: No compiled file for " LF T)
                                    (push NOTCOMPILEDFILES 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 an updated source and compiled file were copied from another directory, we update the FILEDATES property to point to the new location.  If the loaded and file dates are the same, then update the FILEDATES property to point to the possibly new path name and version even if we don't need to load.")

                  (SETQ LOADEDDATE (IDATE LOADEDDATE))
                  (if (IGREATERP IFILEDATE LOADEDDATE)
                      then (add COUNT 1) 

                            (* ;; " FINALLY do the load")

                            (LOAD CFILE (if NOSYSLOAD
                                            then NIL
                                          else 'SYSLOAD))
                            (CL:WHEN [STREQUAL FILEDATE (CAAR (GETP LF 'FILEDATES]

                                (* ;; "If copied, the compiled file may install the original location.  Not sure what happens with copied DFASLs")

                                (RPLACD (CAR (GETP LF 'FILEDATES))
                                       (INFILEP FF)))
                    elseif (IEQP IFILEDATE LOADEDDATE)
                      then (RPLACD (CAR (GETP LF 'FILEDATES))
                                      (INFILEP FF)))
            finally (PRINTOUT T T T COUNT " files loaded" T)
                  (CL:WHEN NOCOMPILEDFILES (PRINTOUT T "Symbolic files loaded:  " .PPVTL 
                                                  NOCOMPILEDFILES T T)))
         (NOPUPPATCH])

(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])
)
(PUTPROPS SYNCLISPFILES COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (449 7605 (SYNCLISPFILES 459 . 7113) (NOPUPPATCH 7115 . 7603)))))
STOP
\ No newline at end of file
diff --git a/obsolete/sources/SYNCLISPFILES.LCOM b/obsolete/sources/SYNCLISPFILES.LCOM
deleted file mode 100644
index ef7cdd66..00000000
Binary files a/obsolete/sources/SYNCLISPFILES.LCOM and /dev/null differ
diff --git a/obsolete/sources/XMAS b/obsolete/sources/XMAS
deleted file mode 100644
index f6a6705d..00000000
--- a/obsolete/sources/XMAS
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 3-Oct-91 20:16:54" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>XMAS.;1| 160511 

      changes to%:  (RECORDS XSCREEN)
                    (FNS CREATEXSCREEN)

      previous date%: " 2-Oct-91 15:15:20" {DSK}<users>nilsson>xmas-split>XMAS.;3)


(* ; "
Copyright (c) 1991 by Venue.  All rights reserved.
")

(PRETTYCOMPRINT XMASCOMS)

(RPAQQ XMASCOMS
       [(RECORDS XSCREEN SCREENREGION)
        (INITVARS XLIB::*DISPLAY* XLIB::*SCREEN* XLIB::*ROOT* XLIB::*BLACK* XLIB::*WHITE* 
               XLIB::*DEFAULTFONT* (XLIB::*DEFAULT-FONT-NAME* "FIXED")
               XLIB::*GC* XLIB::*COLORMAP*)
        (MACROS \XCURVESMOOTH)
        (FNS XLIB::SETUP-CLX)
        (FNS \XDISPLAYINIT CREATEXSCREEN BITSPERPIXEL BITMAPHEIGHT BITMAPWIDTH DSPDESTINATION 
             XDSPCREATE \DSPOPERATION.XDISPLAY \DSPRESET.XDISPLAY \BLTSHADE.XDISPLAY \BITBLT.XDISPLAY
             \XBITBLTSUB \XBLTSHADE.PIXMAP \XBITBLT.PIXMAP \DRAWPOINT.XDISPLAY \DRAWLINE.XDISPLAY 
             \XLINEWITHBRUSH \DRAWCIRCLE.XDISPLAY \DRAWCURVE.XDISPLAY \XCURVE2 \XCURVE)
        (FNS BITBLT)
        (FNS XCREATEWFROMPIXMAP PIXMAPCREATE PIXMAPWIDTH PIXMAPHEIGHT)
        (FNS XCREATEW ADVISEXWDS XOPENW \XOPENW1 XCLOSEW \XCLOSEW1 \XSFFixClippingRegion XSHOWWFRAME
             XSHOWWTITLE \XCREATEBASEW \DSPCLIPPINGREGION.XDISPLAY)
        (FNS \XDSPPRINTCHAR \XBLTCHAR \XDSPPRINTCR/LF)
        (FNS OPENWINDOWS \INSURESCREEN DSPSOURCETYPE PUTWINDOWPROP RESHOWBORDER \XRESHOWBORDER1 
             \GETWINDOWHEIGHT)
        (FNS XWHICHW)
        (FNS TOTOPW)
        (FNS XSHAPEW1 XMOVEW XMOVEW1 XMOVEORRESIZED.WINDOW XMOVED.WINDOW)
        (INITVARS (\XSCREEN NIL))
        [ADDVARS (\DISPLAYSTREAMTYPES XDISPLAY)
               (IMAGESTREAMTYPES (XDISPLAY (OPENSTREAM NILL)
                                        (FONTCREATE \CREATEXDISPLAYFONT)
                                        (FONTSAVAILABLE NILL)
                                        (CREATECHARSET NILL]
        (FILES XLLKEY XLLBITMAP XLLCURSOR XLLMOUSE XLLFONT XSERVER XWATCHER)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA XLIB::SETUP-CLX])
(DECLARE%: EVAL@COMPILE

(DATATYPE XSCREEN (SCONOFF SCDESTINATION SCTOPW SCTOPWDS SCTITLEDS SCFDEV SCDS SCDATA 

                             (* ;; "Access fns and their caches.")

                             \SCBITSPERPIXELCACHE            (* ; "The cache for pixeldepth.")
                             \GETSCBITSPERPIXEL              (* ; "The access function for pixdepth. This function must return a number, larger than 0. This function is applied to the screen structure.")
                             \SCWIDTHCACHE                   (* ; "The screenwidth cache. ")
                             \GETSCWIDTH                     (* ; "The access function for screenwidth. This function must return a number, larger than 0. This function is applied to the screen structure.")
                             \SCHEIGHTCACHE                  (* ; "The screenheigth cache. ")
                             \GETSCHEIGHT                    (* ; "The access function for screenheigth. This function must return a number, larger than 0. This function is applied to the screen structure")
                             CREATEWFN OPENWFN CLOSEWFN)
                      SCONOFF _ 'OFF 

                      (* ;; "The function for getting the pixeldepth of the screen.")

                      [ACCESSFNS ((SCBITSPERPIXEL (OR \SCBITSPERPIXELCACHE
                                                      (replace (XSCREEN \SCBITSPERPIXELCACHE)
                                                         of DATUM
                                                         with (APPLY (fetch (XSCREEN 
                                                                                   \GETSCBITSPERPIXEL
                                                                                           )
                                                                            of DATUM)
                                                                         (LIST DATUM)))
                                                      (SHOULDNT "Pixel depth of screen is NIL"))
                                         (replace (XSCREEN \SCBITSPERPIXELCACHE) of DATUM
                                            with NEWVALUE))
                                  (SCWIDTH (OR \SCWIDTHCACHE (replace (XSCREEN \SCWIDTHCACHE)
                                                                of DATUM
                                                                with (APPLY (fetch
                                                                                 (XSCREEN \GETSCWIDTH
                                                                                        )
                                                                                   of DATUM)
                                                                                (LIST DATUM)))
                                               (SHOULDNT "Width of screen is NIL"))
                                         (replace (XSCREEN \SCWIDTHCACHE) of DATUM
                                            with NEWVALUE))
                                  (SCHEIGHT (OR \SCHEIGHTCACHE (replace (XSCREEN \SCHEIGHTCACHE)
                                                                  of DATUM
                                                                  with (APPLY (fetch
                                                                                   (XSCREEN 
                                                                                         \GETSCHEIGHT
                                                                                          )
                                                                                     of DATUM)
                                                                                  (LIST DATUM)))
                                                (SHOULDNT "Heigth of screen is NIL"))
                                         (replace (XSCREEN \SCHEIGHTCACHE) of DATUM
                                            with NEWVALUE))
                                  (SCREGION (create REGION
                                                   LEFT _ 0
                                                   BOTTOM _ 0 
                                                             (* ; "Behold clever recursion.")
                                                   WIDTH _ (fetch (XSCREEN SCWIDTH) of DATUM)
                                                             (* ; "Dito.")
                                                   HEIGHT _ (fetch (XSCREEN SCHEIGHT)
                                                               of DATUM]
                      (SYSTEM))

(RECORD SCREENREGION (SCREEN . REGION)
                         (SUBRECORD REGION)
                         [TYPE? (AND (LISTP DATUM)
                                         (type? SCREEN (CAR DATUM))
                                         (type? REGION (CDR DATUM]
                         (SYSTEM))
)

(/DECLAREDATATYPE 'XSCREEN
       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
               POINTER POINTER POINTER POINTER POINTER POINTER)
       '((XSCREEN 0 POINTER)
         (XSCREEN 2 POINTER)
         (XSCREEN 4 POINTER)
         (XSCREEN 6 POINTER)
         (XSCREEN 8 POINTER)
         (XSCREEN 10 POINTER)
         (XSCREEN 12 POINTER)
         (XSCREEN 14 POINTER)
         (XSCREEN 16 POINTER)
         (XSCREEN 18 POINTER)
         (XSCREEN 20 POINTER)
         (XSCREEN 22 POINTER)
         (XSCREEN 24 POINTER)
         (XSCREEN 26 POINTER)
         (XSCREEN 28 POINTER)
         (XSCREEN 30 POINTER)
         (XSCREEN 32 POINTER))
       '34)

(RPAQ? XLIB::*DISPLAY* NIL)

(RPAQ? XLIB::*SCREEN* NIL)

(RPAQ? XLIB::*ROOT* NIL)

(RPAQ? XLIB::*BLACK* NIL)

(RPAQ? XLIB::*WHITE* NIL)

(RPAQ? XLIB::*DEFAULTFONT* NIL)

(RPAQ? XLIB::*DEFAULT-FONT-NAME* "FIXED")

(RPAQ? XLIB::*GC* NIL)

(RPAQ? XLIB::*COLORMAP* NIL)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \XCURVESMOOTH MACRO (OPENLAMBDA
                                       (NEWX NEWY USERFN DISPLAYSTREAM)
                                       (PROG [(DX (IABS (IDIFFERENCE NEWX \OLDX)))
                                              (DY (IABS (IDIFFERENCE NEWY \OLDY]
                                             (COND
                                                ((OR (IGREATERP DX 1)
                                                     (IGREATERP DY 1))
                                                 [COND
                                                    ((NEQ [IPLUS (ADD1 (IDIFFERENCE \OLDX \OLDERX))
                                                                 (ITIMES 3 (ADD1 (IDIFFERENCE \OLDY 
                                                                                        \OLDERY]
                                                          4)
                                                     [COND
                                                        (DASHON (COND
                                                                   (USERFN (APPLY* USERFN \OLDX \OLDY
                                                                                  DISPLAYSTREAM))
                                                                   (T (DRAWPOINT \OLDX \OLDY BRUSHBM
                                                                             DISPLAYSTREAM]
                                                     (COND
                                                        (DASHTAIL (COND
                                                                     ((EQ 0 (SETQ DASHCNT
                                                                             (SUB1 DASHCNT)))
                                                                      (SETQ DASHON (NOT DASHON))
                                                                      (SETQ DASHTAIL
                                                                       (OR (LISTP (CDR DASHTAIL))
                                                                           DASHLST))
                                                                      (SETQ DASHCNT (CAR DASHTAIL]
                                                 (SETQ \OLDERX \OLDX)
                                                 (SETQ \OLDERY \OLDY)
                                                 (SETQ \OLDX \CURX)
                                                 (SETQ \OLDY \CURY)))
                                             (SETQ \CURX NEWX)
                                             (SETQ \CURY NEWY))))
)
(DEFINEQ

(XLIB::SETUP-CLX
  [CL:LAMBDA (&OPTIONAL (XLIB:DISPLAY "unix:0.0"))       (* ; "Edited 11-Sep-91 19:29 by jn")
         (CL:BLOCK XLIB::SETUP-CLX
             (LET ((XLIB::HOST-PORT (XSERVERNAME XLIB:DISPLAY)))
                  (CL:SETQ XLIB::*DISPLAY* (XLIB:OPEN-DISPLAY (CAR XLIB::HOST-PORT)
                                                  :DISPLAY
                                                  (CDR XLIB::HOST-PORT)))
                  (CL:SETQ XLIB::*SCREEN* (XLIB:DISPLAY-DEFAULT-SCREEN XLIB::*DISPLAY*))
                  (CL:SETQ XLIB::*BLACK* (XLIB:SCREEN-BLACK-PIXEL XLIB::*SCREEN*))
                  (CL:SETQ XLIB::*WHITE* (XLIB:SCREEN-WHITE-PIXEL XLIB::*SCREEN*))
                  (CL:SETQ XLIB::*COLORMAP* (XLIB:SCREEN-DEFAULT-COLORMAP XLIB::*SCREEN*))
                  (CL:SETQ XLIB::*ROOT* (XLIB:SCREEN-ROOT XLIB::*SCREEN*))
                  (CL:SETQ XLIB::*DEFAULTFONT* (XLIB:OPEN-FONT XLIB::*DISPLAY* 
                                                      XLIB::*DEFAULT-FONT-NAME*))
                  (CL:SETQ XLIB::*GC* (XLIB:CREATE-GCONTEXT :DRAWABLE XLIB::*ROOT*))
                  (CL:SETF (XLIB:DISPLAY-AFTER-FUNCTION XLIB::*DISPLAY*)
                         #'XLIB:DISPLAY-FINISH-OUTPUT)))])
)
(DEFINEQ

(\XDISPLAYINIT
  [LAMBDA NIL
    (DECLARE (GLOBALVARS XDisplayFDEV \XDISPLAYIMAGEOPS \XDisplayDeviceMethods 
                        \XDisplayDeviceData))          (* ; "Edited 16-Feb-91 15:03 by matsuda")
    (SETQ \XDisplayDeviceMethods (create WSOPS))
    (SETQ \XDisplayDeviceData
     (create WSDATA
            WSDESTINATION _ "Destination"
            WSREGION _ (create REGION
                              LEFT _ 0
                              BOTTOM _ 0
                              WIDTH _ 1024
                              HEIGHT _ 808)))
    (SETQ \XDISPLAYIMAGEOPS (create IMAGEOPS
                                   IMAGETYPE _ 'XDISPLAY
                                   IMFONT _ (FUNCTION \DSPFONT.XDISPLAY)
                                   IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.DISPLAY)
                                   IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.DISPLAY)
                                   IMLINEFEED _ (FUNCTION \DSPLINEFEED.DISPLAY)
                                   IMXPOSITION _ (FUNCTION \DSPXPOSITION.DISPLAY)
                                   IMYPOSITION _ (FUNCTION \DSPYPOSITION.DISPLAY)
                                   IMCLOSEFN _ (FUNCTION NILL)
                                   IMDRAWCURVE _ (FUNCTION \DRAWCURVE.XDISPLAY)
                                   IMFILLCIRCLE _ '\FILLCIRCLE.XDISPLAY
                                   IMDRAWLINE _ (FUNCTION \DRAWLINE.XDISPLAY)
                                   IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.XDISPLAY)
                                   IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.XDISPLAY)
                                   IMFILLPOLYGON _ (FUNCTION POLYSHADE.XDISPLAY)
                                   IMBITBLT _ (FUNCTION \BITBLT.XDISPLAY)
                                   IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.XDISPLAY)
                                   IMBLTSHADE _ (FUNCTION \BLTSHADE.XDISPLAY)
                                   IMNEWPAGE _ (FUNCTION \NEWPAGE.XDISPLAY)
                                   IMSCALE _ [FUNCTION (LAMBDA NIL 1]
                                   IMSPACEFACTOR _ (FUNCTION NILL)
                                   IMFONTCREATE _ 'XDISPLAY
                                   IMCOLOR _ (FUNCTION NILL)
                                   IMBACKCOLOR _ (FUNCTION \BACKCOLOR.XDISPLAY)
                                   IMOPERATION _ (FUNCTION \DSPOPERATION.XDISPLAY)
                                   IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.XDISPLAY)
                                   IMCHARWIDTH _ (FUNCTION \CHARWIDTH.XDISPLAY)
                                   IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.XDISPLAY)
                                   IMRESET _ (FUNCTION \DSPRESET.XDISPLAY)
                                   IMDRAWARC _ (FUNCTION \DRAWARC.XDISPLAY)
                                   IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.XDISPLAY)
                                   IMDRAWPOINT _ (FUNCTION \DRAWPOINT.XDISPLAY)))
    (SETQ XDisplayFDEV (create FDEV
                              DEVICENAME _ 'XDISPLAY
                              RESETABLE _ NIL
                              RANDOMACCESSP _ NIL
                              PAGEMAPPED _ NIL
                              CLOSEFILE _ (FUNCTION NILL)
                              DELETEFILE _ (FUNCTION NILL)
                              GETFILEINFO _ (FUNCTION NILL)
                              OPENFILE _ [FUNCTION (LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV)
                                                     NAME]
                              READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP)
                              SETFILEINFO _ (FUNCTION NILL)
                              GENERATEFILES _ (FUNCTION \GENERATENOFILES)
                              TRUNCATEFILE _ (FUNCTION NILL)
                              WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP)
                              GETFILENAME _ [FUNCTION (LAMBDA (NAME RECOG FDEV)
                                                        NAME]
                              REOPENFILE _ [FUNCTION (LAMBDA (NAME)
                                                       NAME]
                              EVENTFN _ (FUNCTION \XDisplayEventFn)
                              DIRECTORYNAMEP _ (FUNCTION NILL)
                              HOSTNAMEP _ (FUNCTION NILL)
                              BIN _ (FUNCTION \ILLEGAL.DEVICEOP)
                              BOUT _ (FUNCTION \DSPPRINTCHAR)
                              PEEKBIN _ (FUNCTION \ILLEGAL.DEVICEOP)
                              BACKFILEPTR _ (FUNCTION \PAGEDBACKFILEPTR)
                              BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP)
                              BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS)
                              WINDOWOPS _ \DisplayDeviceMethods
                              WINDOWDATA _ \DisplayDeviceData
                              DEVICEINFO _ (create DISPLAYSTATE)))
    (\DEFINEDEVICE 'XDISPLAY XDisplayFDEV])

(CREATEXSCREEN
  [LAMBDA (DESTINATION)                                  (* ; "Edited  3-Oct-91 20:15 by jn")
    (PROG (TITLEDS SCREEN)
          (SETQ TITLEDS (XDSPCREATE DESTINATION))        (* ; "Create TITLEDS. ")
          (DSPOPERATION 'INVERT TITLEDS)
          (DSPFONT XWINDOWTITLEFONT TITLEDS)
          (DSPRIGHTMARGIN MAX.SMALLP TITLEDS)                (* ; 
                                                       "Set right margin so title doesn't autoCR. ")

     (* ;; "now create SCREEN. ")

          [SETQ SCREEN (create XSCREEN
                              SCONOFF _ 'OFF
                              SCDESTINATION _ DESTINATION
                              SCTOPW _ NIL
                              SCTITLEDS _ TITLEDS 

                              (* ;; "Cached fns.")

                              \GETSCWIDTH _ '[LAMBDA (DATUM)
                                               (XLIB:DRAWABLE-WIDTH (fetch (XSCREEN SCDESTINATION
                                                                                      ) of DATUM]
                              \GETSCHEIGHT _ '[LAMBDA (DATUM)
                                                (XLIB:DRAWABLE-HEIGHT (fetch (XSCREEN 
                                                                                        SCDESTINATION
                                                                                        )
                                                                         of DATUM]
                              \GETSCBITSPERPIXEL _ '(LAMBDA (DATUM)
                                                      (XLIB:DRAWABLE-DEPTH (fetch (XSCREEN 
                                                                                        SCDESTINATION
                                                                                             )
                                                                              of DATUM]
          (RETURN SCREEN])

(BITSPERPIXEL
  [LAMBDA (BITMAP)                                     (* ; "Edited 31-Jan-91 14:24 by matsuda")

    (* ;; "returns the height in pixels of a bitmap.")

    (COND
       ((type? BITMAP BITMAP)
        (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP))
       ((XLIB:DRAWABLE-P BITMAP)
        (XLIB:DRAWABLE-DEPTH BITMAP))
       ((type? SCREEN BITMAP)
        (BITSPERPIXEL (fetch (SCREEN SCDESTINATION) of BITMAP)))
       ((type? XSCREEN BITMAP)
        (BITSPERPIXEL (fetch (XSCREEN SCDESTINATION) of BITMAP)))
       ((type? WINDOW BITMAP)
        (BITSPERPIXEL (fetch (WINDOW SCREEN) of BITMAP)))
       ((ARRAYP BITMAP)                                      (* ; 
                                                           "Consider array to be a colormap.")
        (SELECTQ (ARRAYSIZE BITMAP)
            (256 8)
            (16 4)
            (LISPERROR "ILLEGAL ARG" BITMAP)))
       (T (LISPERROR "ILLEGAL ARG" BITMAP])

(BITMAPHEIGHT
  [LAMBDA (BITMAP)                                     (* ; "Edited 17-Jul-91 08:44 by matsuda")

    (* ;; "returns the height in pixels of a bitmap.")

    (COND
       ((type? BITMAP BITMAP)
        (fetch (BITMAP BITMAPHEIGHT) of BITMAP))
       ((XLIB:DRAWABLE-P BITMAP)
        (XLIB:DRAWABLE-HEIGHT BITMAP))
       ((type? WINDOW BITMAP)
        (WINDOWPROP BITMAP 'HEIGHT))
       (T (\ILLEGAL.ARG BITMAP])

(BITMAPWIDTH
  [LAMBDA (BITMAP)                                     (* ; "Edited 17-Jul-91 08:42 by matsuda")

    (* ;; "returns the width of a bitmap in pixels")

    (COND
       ((type? BITMAP BITMAP)
        (ffetch (BITMAP BITMAPWIDTH) of BITMAP))
       ((XLIB:DRAWABLE-P BITMAP)
        (XLIB:DRAWABLE-WIDTH BITMAP))
       ((type? WINDOW BITMAP)
        (WINDOWPROP BITMAP 'WIDTH))
       (T (\ILLEGAL.ARG BITMAP])

(DSPDESTINATION
  [LAMBDA (DESTINATION DISPLAYSTREAM)                  (* ; "Edited 31-Jan-91 14:46 by matsuda")
    (DECLARE (GLOBALVARS \DISPLAYIMAGEOPS \4DISPLAYIMAGEOPS \8DISPLAYIMAGEOPS \24DISPLAYIMAGEOPS
                        \XDISPLAYIMAGEOPS))
    (PROG (DD)
          (SETQ DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM))
          (RETURN (PROG1 (ffetch (\DISPLAYDATA DDDestination) of DD)
                      [COND
                         (DESTINATION (COND
                                         ((XLIB:DRAWABLE-P DESTINATION)
                                                             (* ; "XDISPLAY case ")
                                          (UNINTERRUPTABLY
                                              (replace (STREAM DEVICE) of DISPLAYSTREAM
                                                 with XDisplayFDEV)
                                              (replace (STREAM IMAGEOPS) of DISPLAYSTREAM
                                                 with \XDISPLAYIMAGEOPS)
                                              (freplace (\DISPLAYDATA DDDestination) of
                                                                                         DD
                                                 with DESTINATION)))
                                         (T                  (* ; "LFDISPLAY case")
                                            (SETQ DESTINATION (\DTEST DESTINATION 'BITMAP))
                                            (UNINTERRUPTABLY
                                                (replace (STREAM DEVICE) of DISPLAYSTREAM
                                                   with (SELECTQ (fetch (BITMAP 
                                                                                   BITMAPBITSPERPIXEL
                                                                                       ) of
                                                                                         DESTINATION)
                                                                (1 DisplayFDEV)
                                                                (4 \4DISPLAYFDEV)
                                                                (8 \8DISPLAYFDEV)
                                                                (24 \24DISPLAYFDEV)
                                                                (SHOULDNT)))
                                                (replace (STREAM IMAGEOPS) of DISPLAYSTREAM
                                                   with (SELECTQ (fetch (BITMAP 
                                                                                   BITMAPBITSPERPIXEL
                                                                                       ) of
                                                                                         DESTINATION)
                                                                (1 \DISPLAYIMAGEOPS)
                                                                (4 \4DISPLAYIMAGEOPS)
                                                                (8 \8DISPLAYIMAGEOPS)
                                                                (24 \24DISPLAYIMAGEOPS)
                                                                (SHOULDNT)))
                                                (freplace (\DISPLAYDATA DDDestination)
                                                   of DD with DESTINATION)
                                                (\SFFixDestination DD DISPLAYSTREAM))])])

(XDSPCREATE
  [LAMBDA (DESTINATION)                                (* ; "Edited 15-Feb-91 18:29 by matsuda")
    (LET (DSTRM GC)
         (COND
            ((XLIB:DRAWABLE-P DESTINATION)
             (SETQ DSTRM (create STREAM
                                USERCLOSEABLE _ NIL
                                OUTCHARFN _ (FUNCTION \XDSPPRINTCHAR)
                                IMAGEDATA _ (create \DISPLAYDATA)
                                IMAGEOPS _ \XDISPLAYIMAGEOPS
                                DEVICE _ XDisplayFDEV
                                ACCESS _ 'OUTPUT))
             (replace (\DISPLAYDATA DDPILOTBBT) of (fetch (STREAM IMAGEDATA) of
                                                                                         DSTRM)
                with (SETQ GC (XLIB:CREATE-GCONTEXT :DRAWABLE DESTINATION)))
             (CL:SETF (XLIB:GCONTEXT-FOREGROUND GC)
                    XLIB::*BLACK*)                           (* ; "temp foreground color ")
             (CL:SETF (XLIB:GCONTEXT-BACKGROUND GC)
                    XLIB::*WHITE*)                           (* ; "temp background color")
             (DSPFONT XDEFAULTFONT DSTRM)
             (DSPDESTINATION DESTINATION DSTRM)
             (DSPRIGHTMARGIN (MAX SCREENWIDTH (XLIB:DRAWABLE-WIDTH DESTINATION))
                    DSTRM)
             (DSPSOURCETYPE 'INPUT DSTRM)
             (DSPOPERATION 'REPLACE DSTRM)
             DSTRM)
            (T NIL])

(\DSPOPERATION.XDISPLAY
  [LAMBDA (DISPLAYSTREAM OPERATION)                    (* ; "Edited 15-Feb-91 12:32 by matsuda")

    (* ;; "sets the operation field of a display stream")

    (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
          (RETURN (PROG1 (fetch DDOPERATION of DD)
                      [COND
                         (OPERATION (OR (FMEMB OPERATION '(PAINT REPLACE INVERT ERASE))
                                        (LISPERROR "ILLEGAL ARG" OPERATION))
                                (UNINTERRUPTABLY
                                    (freplace DDOPERATION of DD with OPERATION)
                                    (\SETGCFUNCTION (fetch DDPILOTBBT of DD)
                                           (fetch DDSOURCETYPE of DD)
                                           OPERATION))])])

(\DSPRESET.XDISPLAY
  [LAMBDA (DISPLAYSTREAM)
    (DECLARE (GLOBALVARS \CURRENTDISPLAYLINE))     (* ; "Edited 22-Feb-91 17:41 by matsuda")
    (LET [CREG FONT FONTASCENT (DD (\DTEST (fetch (STREAM IMAGEDATA) of (SETQ DISPLAYSTREAM
                                                                                 (\OUTSTREAMARG
                                                                                  DISPLAYSTREAM)))
                                          '\DISPLAYDATA]
         (SETQ CREG (ffetch (\DISPLAYDATA DDClippingRegion) of DD))
         (SETQ FONT (fetch (\DISPLAYDATA DDFONT) of DD))
         (SETQ FONTASCENT (FONTASCENT FONT))
         (SELECTQ (fetch (FONTDESCRIPTOR ROTATION) of FONT)
             (0 (\DSPXPOSITION.DISPLAY DISPLAYSTREAM (ffetch (\DISPLAYDATA DDLeftMargin)
                                                        of DD))
                (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (ADD1 (IDIFFERENCE (fetch (REGION TOP)
                                                                           of CREG)
                                                                  FONTASCENT))))
             (ERROR "only supported rotations are 0"))
         (CL:SETF (XLIB:GCONTEXT-FOREGROUND XLIB::*GC*)
                XLIB::*WHITE*)
         (XLIB:DRAW-RECTANGLE (fetch (\DISPLAYDATA DDDestination) of DD)
                XLIB::*GC*
                (\DSPTRANSFORMX (fetch (REGION LEFT) of CREG)
                       DD)
                (\DSPTRANSFORMY (fetch (REGION BOTTOM) of CREG)
                       DD)
                (fetch (REGION WIDTH) of CREG)
                (fetch (REGION HEIGHT) of CREG)
                T)                                           (* ; "(BITBLT NIL NIL NIL DISPLAYSTREAM (fetch (REGION LEFT) of CREG) (fetch (REGION BOTTOM) of CREG) (fetch (REGION WIDTH) of CREG) (fetch (REGION HEIGHT) of CREG) 'TEXTURE 'REPLACE (ffetch (\DISPLAYDATA DDTexture) of DD))")

         (* ;; "if this display stream is the tty display stream of a process, reset the # of lines in that process.")

         (PROG ((X (WFROMDS DISPLAYSTREAM T)))
               (COND
                  ((AND X (SETQ X (WINDOWPROP X 'PROCESS))
                        (EQ (PROCESS.TTY X)
                            DISPLAYSTREAM))
                   (PROCESS.EVAL X '(SETQ \CURRENTDISPLAYLINE 0])

(\BLTSHADE.XDISPLAY
  [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)
                                                           (* ; "Edited 28-Feb-91 13:08 by matsuda")
                                                             (* ; "BLTSHADE to a display stream")
    (DECLARE (LOCALVARS . T))
    (PROG (left top bottom right DESTINATIONBITMAP DESTDD DESTINATIONNBITS GC PIXMAP ORGFUNCTION)
          (SETQ DESTDD (fetch (STREAM IMAGEDATA) of STREAM))
          (SETQ GC (fetch (\DISPLAYDATA DDPILOTBBT) of DESTDD))
          (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD))
          (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM 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
                    (CLIPPINGREGION                          (* ; 
                      "hard case, two destination clipping regions: do calculations to merge them.")
                           (PROG (CRLEFT CRBOTTOM)
                                 [SETQ left (IMAX left (SETQ CRLEFT (\DSPTRANSFORMX
                                                                     (fetch (REGION LEFT)
                                                                        of CLIPPINGREGION)
                                                                     DESTDD]
                                 [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (\DSPTRANSFORMY
                                                                           (fetch (REGION BOTTOM)
                                                                              of CLIPPINGREGION)
                                                                           DESTDD]
                                 [SETQ right (IMIN right (IPLUS CRLEFT (fetch (REGION WIDTH)
                                                                          of CLIPPINGREGION]
                                 (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch (REGION HEIGHT)
                                                                        of CLIPPINGREGION]
          (SETQ DESTINATIONBITMAP (fetch (\DISPLAYDATA DDDestination) of DESTDD))
          (SETQ DESTINATIONNBITS (BITSPERPIXEL DESTINATIONBITMAP))

     (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions.  Clip to region in the arguments of this call.")

          [PROGN (SETQ left (IMAX DESTINATIONLEFT left))
                 (SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
                 [COND
                    (WIDTH                                   (* ; "WIDTH is optional")
                           (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
                                             right]
                 (COND
                    (HEIGHT                                  (* ; "HEIGHT is optional")
                           (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
                                           top]
          (COND
             ((OR (ILEQ right left)
                  (ILEQ top bottom))                         (* ; "there is nothing to move.")
              (RETURN)))
          (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE)
                            (LITATOM (COND
                                        ((NULL TEXTURE)      (* ; 
                                                "NIL case.  default texture to background texture.")
                                         (ffetch (\DISPLAYDATA DDTexture) of DESTDD))
                                        (T (\ILLEGAL.ARG TEXTURE))))
                            ((SMALLP FIXP) 
                                 (LOGAND TEXTURE 65535))
                            (BITMAP TEXTURE)
                            (\ILLEGAL.ARG TEXTURE)))
          (SETQ PIXMAP (PIXMAPFROMTEXTURE TEXTURE))
          (SETQ ORGFUNCTION (XLIB:GCONTEXT-FUNCTION GC))
          (CL:SETF (XLIB:GCONTEXT-FUNCTION GC)
                 (SELECTQ (OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))
                     (REPLACE CL:BOOLE-1)
                     (PAINT CL:BOOLE-IOR)
                     (INVERT CL:BOOLE-XOR)
                     (ERASE CL:BOOLE-ANDC1)
                     CL:BOOLE-1))
          (CL:SETF (XLIB:GCONTEXT-TILE GC)
                 PIXMAP)
          (CL:SETF (XLIB:GCONTEXT-FILL-STYLE GC)
                 :TILED)
          (PROG (Y WIDTH HEIGHT)
                (SETQ HEIGHT (IDIFFERENCE top bottom))
                (SETQ WIDTH (IDIFFERENCE right left))
                (SETQ Y (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTINATIONBITMAP)
                               top))
                (XLIB:DRAW-RECTANGLE DESTINATIONBITMAP GC left Y WIDTH HEIGHT :FILL-P T))
          (CL:SETF (XLIB:GCONTEXT-FUNCTION GC)
                 ORGFUNCTION)
          (RETURN T])

(\BITBLT.XDISPLAY
  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH 
                 HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
                 CLIPPEDSOURCEBOTTOM)
    (DECLARE (LOCALVARS . T))                      (* ; "Edited 17-Jul-91 10:37 by matsuda")
    (PROG (stodx stody left top bottom right DESTDD DESTBITMAP DESTINATIONNBITS SOURCENBITS MAXSHADE)
          (SETQ DESTDD (fetch (STREAM IMAGEDATA) of DESTSTRM))
          (SETQ DESTBITMAP (fetch (\DISPLAYDATA DDDestination) of DESTDD))
          (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD))
          (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM 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
                    (CLIPPINGREGION                          (* ; 
                      "hard case, two destination clipping regions: do calculations to merge them.")
                           (PROG (CRLEFT CRBOTTOM)
                                 [SETQ left (IMAX left (SETQ CRLEFT (\DSPTRANSFORMX
                                                                     (fetch (REGION LEFT)
                                                                        of CLIPPINGREGION)
                                                                     DESTDD]
                                 [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (\DSPTRANSFORMY
                                                                           (fetch (REGION BOTTOM)
                                                                              of CLIPPINGREGION)
                                                                           DESTDD]
                                 [SETQ right (IMIN right (IPLUS CRLEFT (fetch (REGION WIDTH)
                                                                          of CLIPPINGREGION]
                                 (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch (REGION HEIGHT)
                                                                        of CLIPPINGREGION]
          [PROGN (SETQ left (IMAX DESTINATIONLEFT left))
                 (SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
                 [COND
                    (WIDTH                                   (* ; "WIDTH is optional")
                           (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
                                             right]
                 (COND
                    (HEIGHT                                  (* ; "HEIGHT is optional")
                           (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
                                           top]              (* ; "Clip and translate coordinates.")
          (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT))
          (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM))
          [PROGN                                             (* ; "compute left margin")
                 (SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx)
                                  0))                        (* ; "compute bottom margin")
                 (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom stody)
                                    0))                      (* ; "compute right margin")
                 (SETQ right (IMIN (BITMAPWIDTH SOURCEBITMAP)
                                   (IDIFFERENCE right stodx)
                                   (IPLUS CLIPPEDSOURCELEFT WIDTH)))
                                                             (* ; "compute top margin")
                 (SETQ top (IMIN (BITMAPHEIGHT SOURCEBITMAP)
                                 (IDIFFERENCE top stody)
                                 (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT]
          (COND
             ((OR (ILEQ right left)
                  (ILEQ top bottom))                         (* ; "there is nothing to move.")
              (RETURN)))
          (OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD)))
          (PROG (GC HEIGHT WIDTH DTY DLX STY SLX)
                (SETQ GC (fetch (\DISPLAYDATA DDPILOTBBT) of DESTDD))
                (SETQ HEIGHT (IDIFFERENCE top bottom))
                (SETQ WIDTH (IDIFFERENCE right left))
                (SETQ DTY (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTBITMAP)
                                 (IPLUS top stody)))
                (SETQ DLX (IPLUS left stodx))
                (SETQ STY (IDIFFERENCE (BITMAPWIDTH SOURCEBITMAP)
                                 top))
                (SETQ SLX left)
                (\XBITBLTSUB GC SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT SOURCETYPE 
                       OPERATION TEXTURE))
          (RETURN T])

(\XBITBLTSUB
  [LAMBDA (GC SourceBitMap SLX STY DestinationDrawable DLX DTY WIDTH HEIGHT SourceType Operation 
              Texture WindowXOffset WindowYOffset)     (* ; "Edited 17-Jul-91 08:31 by matsuda")
    (CL:SETF (XLIB:GCONTEXT-FUNCTION GC)
           (SELECTQ SourceType
               (INVERT (SELECTQ SourceType
                           (PAINT CL:BOOLE-ORC1)
                           (INVERT CL:BOOLE-EQV)
                           (ERASE CL:BOOLE-AND)
                           CL:BOOLE-C1))
               (SELECTQ Operation
                   (PAINT CL:BOOLE-IOR)
                   (INVERT CL:BOOLE-XOR)
                   (ERASE CL:BOOLE-ANDC1)
                   CL:BOOLE-1)))
    (SELECTQ (TYPENAME SourceBitMap)
        (BITMAP [PROG (XIMAGE)
                      (SETQ XIMAGE (XIMAGEFROMBITMAP SourceBitMap))
                      (COND
                         ((EQ (BITSPERPIXEL SourceBitMap)
                              1)
                          (XLIB:PUT-IMAGE DestinationDrawable GC XIMAGE :SRC-X SLX :SRC-Y STY :X DLX
                                 :Y DTY :HEIGHT HEIGHT :WIDTH WIDTH :BITMAP-P T))
                         (T (XLIB:PUT-IMAGE DestinationDrawable GC XIMAGE :SRC-X SLX :SRC-Y STY :X 
                                   DLX :Y DTY :HEIGHT HEIGHT :WIDTH WIDTH])
        ((XLIB:WINDOW XLIB:PIXMAP) 
             (XLIB:COPY-AREA SourceBitMap GC SLX STY WIDTH HEIGHT DestinationDrawable DLX DTY))
        NIL])

(\XBLTSHADE.PIXMAP
  [LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION 
                 CLIPPINGREGION)
    (DECLARE (LOCALVARS . T))                      (* ; "Edited  6-Mar-91 17:09 by matsuda")
    (PROG (left bottom top right PIXMAP)
          (SETQ left 0)
          (SETQ bottom 0)
          (SETQ top (PIXMAPHEIGHT DESTINATIONBITMAP))
          (SETQ right (PIXMAPWIDTH DESTINATIONBITMAP))
          [COND
             (CLIPPINGREGION                                 (* ; "adjust limits")
                    (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION)))
                    (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION)))
                    [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION)
                                                   (fetch (REGION LEFT) of CLIPPINGREGION]
                    (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION)
                                               (fetch (REGION HEIGHT) of CLIPPINGREGION]
          (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0))
          (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0))
          [PROGN (SETQ left (IMAX DESTINATIONLEFT left))
                 (SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
                 [COND
                    (WIDTH                                   (* ; "WIDTH is optional")
                           (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
                                             right]
                 (COND
                    (HEIGHT                                  (* ; "HEIGHT is optional")
                           (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
                                           top]
          (COND
             ((OR (ILEQ right left)
                  (ILEQ top bottom))                         (* ; "there is nothing to move.")
              (RETURN)))
          (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE)
                            (LITATOM                         (* ; "includes NIL case")
                                     (COND
                                        ((NULL TEXTURE)
                                         WHITESHADE)
                                        (T (\ILLEGAL.ARG TEXTURE))))
                            ((SMALLP FIXP) 
                                 (LOGAND TEXTURE BLACKSHADE))
                            (BITMAP TEXTURE)
                            (\ILLEGAL.ARG TEXTURE)))
          (SETQ PIXMAP (PIXMAPFROMTEXTURE TEXTURE))
          (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*)
                 (SELECTQ OPERATION
                     (REPLACE CL:BOOLE-1)
                     (PAINT CL:BOOLE-IOR)
                     (INVERT CL:BOOLE-XOR)
                     (ERASE CL:BOOLE-ANDC1)
                     CL:BOOLE-1))
          (CL:SETF (XLIB:GCONTEXT-TILE XLIB::*GC*)
                 PIXMAP)
          (CL:SETF (XLIB:GCONTEXT-FILL-STYLE XLIB::*GC*)
                 :TILED)
          (PROG (Y WIDTH HEIGHT)
                (SETQ HEIGHT (IDIFFERENCE top bottom))
                (SETQ WIDTH (IDIFFERENCE right left))
                (SETQ Y (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTINATIONBITMAP)
                               top))
                (XLIB:DRAW-RECTANGLE DESTINATIONBITMAP XLIB::*GC* left Y WIDTH HEIGHT :FILL-P T))
          (RETURN T])

(\XBITBLT.PIXMAP
  [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH 
                 HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
                 CLIPPEDSOURCEBOTTOM)
    (DECLARE (LOCALVARS . T))                      (* ; "Edited 17-Jul-91 08:46 by matsuda")
    (PROG (stodx stody right top DESTINATIONNBITS left bottom SOURCENBITS)
          (SETQ top (PIXMAPHEIGHT DESTBITMAP))
          (SETQ left 0)
          (SETQ bottom 0)
          (SETQ SOURCENBITS (BITSPERPIXEL SOURCEBITMAP))
          (SETQ right (PIXMAPWIDTH DESTBITMAP))
          [COND
             (CLIPPINGREGION                                 (* ; "adjust limits")
                    (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION)))
                    (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION)))
                    [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION)
                                                   (fetch (REGION LEFT) of CLIPPINGREGION]
                    (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION)
                                               (fetch (REGION HEIGHT) of CLIPPINGREGION]
          [PROGN (SETQ left (IMAX DESTINATIONLEFT left))
                 (SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
                 [COND
                    (WIDTH                                   (* ; "WIDTH is optional")
                           (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
                                             right]
                 (COND
                    (HEIGHT                                  (* ; "HEIGHT is optional")
                           (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
                                           top]              (* ; "Clip and translate coordinates.")
          (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT))
          (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM))
          [PROGN                                             (* ; "compute left margin")
                 (SETQ left (IMAX CLIPPEDSOURCELEFT 0 (IDIFFERENCE left stodx)))
                                                             (* ; "compute bottom margin")
                 (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM 0 (IDIFFERENCE bottom stody)))
                                                             (* ; "compute right margin")
                 (SETQ right (IMIN (BITMAPWIDTH SOURCEBITMAP)
                                   (IDIFFERENCE right stodx)
                                   (IPLUS CLIPPEDSOURCELEFT WIDTH)))
                                                             (* ; "compute top margin")
                 (SETQ top (IMIN (BITMAPHEIGHT SOURCEBITMAP)
                                 (IDIFFERENCE top stody)
                                 (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT]
          (COND
             ((OR (ILEQ right left)
                  (ILEQ top bottom))                         (* ; "there is nothing to move.")
              (RETURN)))
          (SELECTQ SOURCETYPE
              (MERGE (\ILLEGAL.ARG TEXTURE))
              NIL)
          (COND
             ((OR (XLIB:DRAWABLE-P SOURCEBITMAP)
                  (EQ SOURCENBITS 1))
              (PROG (HEIGHT WIDTH DTY DLX STY SLX)
                    (SETQ HEIGHT (IDIFFERENCE top bottom))
                    (SETQ WIDTH (IDIFFERENCE right left))
                    (SETQ DTY (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTBITMAP)
                                     (IPLUS top stody)))
                    (SETQ DLX (IPLUS left stodx))
                    (SETQ STY (\SFInvert SOURCEBITMAP top))
                    (SETQ SLX left)
                    (\XBITBLTSUB XLIB::*GC* SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT
                           SOURCETYPE OPERATION TEXTURE)))
             (T (ERROR "Source bitmap should not color bitmaps." SOURCEBITMAP)))
          (RETURN T])

(\DRAWPOINT.XDISPLAY
  [LAMBDA (DISPLAYSTREAM X Y BRUSH OPERATION)          (* ; "Edited 17-Jul-91 10:43 by matsuda")
    (PROG ((BRUSHBM (XPIXMAPFROMBRUSH BRUSH)))
          (RETURN (BITBLT BRUSHBM 0 0 DISPLAYSTREAM [IDIFFERENCE X (HALF (SUB1 (BITMAPWIDTH
                                                                                    BRUSHBM]
                         [IDIFFERENCE Y (HALF (SUB1 (BITMAPHEIGHT BRUSHBM]
                         NIL NIL NIL (SELECTQ (OR OPERATION (DSPOPERATION NIL DISPLAYSTREAM))
                                         (REPLACE 'PAINT)
                                         OPERATION])

(\DRAWLINE.XDISPLAY
  [LAMBDA (DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING)
                                                           (* ; "Edited 16-Jul-91 13:20 by matsuda")
    [COND
       [(OR DASHING (BRUSHP WIDTH))
        (LET ((BRUSH (INSURE.BRUSH WIDTH)))
             (if COLOR
                 then (replace (BRUSH BRUSHCOLOR) of BRUSH with COLOR))
             (\XLINEWITHBRUSH X1 Y1 X2 Y2 BRUSH (\GOOD.DASHLST DASHING BRUSH)
                    DISPLAYSTREAM
                    (SELECTQ OPERATION
                        (NIL (ffetch DDOPERATION of (fetch IMAGEDATA of DISPLAYSTREAM
                                                                   )))
                        ((REPLACE PAINT INVERT ERASE) 
                             OPERATION)
                        (\ILLEGAL.ARG OPERATION]
       (T (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM))
                 X Y DRAWABLE GC)
                (SETQ DRAWABLE (fetch (\DISPLAYDATA DDDestination) of DD))
                (SETQ GC (fetch (\DISPLAYDATA DDPILOTBBT) of DD))
                (SETQ X1 (\DSPTRANSFORMX (OR (FIXP X1)
                                             (FIXR X1))
                                DD))
                (SETQ Y1 (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DRAWABLE)
                                (\DSPTRANSFORMY (OR (FIXP Y1)
                                                    (FIXR Y1))
                                       DD)))
                (SETQ X (\DSPTRANSFORMX (OR (FIXP X2)
                                            (FIXR X2))
                               DD))
                (SETQ Y (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DRAWABLE)
                               (\DSPTRANSFORMY (OR (FIXP Y2)
                                                   (FIXR Y2))
                                      DD)))
                (SETQ OPERATION (SELECTQ OPERATION
                                    (NIL (ffetch DDOPERATION of DD))
                                    ((REPLACE PAINT INVERT ERASE) 
                                         OPERATION)
                                    (\ILLEGAL.ARG OPERATION)))
                (CL:SETF (XLIB:GCONTEXT-FUNCTION GC)
                       (SELECTQ OPERATION
                           (REPLACE CL:BOOLE-1)
                           (PAINT CL:BOOLE-IOR)
                           (INVERT CL:BOOLE-XOR)
                           (ERASE CL:BOOLE-ANDC1)
                           CL:BOOLE-1))
                [CL:SETF (XLIB:GCONTEXT-LINE-WIDTH GC)
                       (COND
                          ((NULL WIDTH)
                           1)
                          ((OR (FIXP WIDTH)
                               (FIXR WIDTH]
                (CL:SETF (XLIB:GCONTEXT-JOIN-STYLE GC)
                       :ROUND)
                (CL:SETF (XLIB:GCONTEXT-CAP-STYLE GC)
                       :ROUND)
                (XLIB:DRAW-LINE DRAWABLE GC X1 Y1 X Y]
    (MOVETO X2 Y2 DISPLAYSTREAM])

(\XLINEWITHBRUSH
  [LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST DISPLAYSTREAM OPERATION)
    (DECLARE (LOCALVARS . T))                      (* ; "Edited 16-Jul-91 13:38 by matsuda")
    (PROG (DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH 
                 BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH 
                 BRUSHRASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS 
                 HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY YINC CDL (DASHON T)
                 (DASHTAIL DASHLST)
                 (DASHCNT (CAR DASHLST))
                 (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
                 (USERFN (AND (LITATOM BRUSH)
                              BRUSH))
                 (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)))
                                                             (* ; 
                                                           "arrange things so that dx is positive.")
          (COND
             ((IGREATERP X1 X2)                              (* ; "switch points")
              (swap X1 X2)
              (swap Y1 Y2)))
          (SETQ DX (ADD1 (IDIFFERENCE X2 X1)))
          [SETQ DY (ADD1 (COND
                            ((IGREATERP Y2 Y1)
                             (SETQ YINC 1)
                             (IDIFFERENCE Y2 Y1))
                            (T (SETQ YINC -1)
                               (IDIFFERENCE Y1 Y2]
          [SETQ CDL (HALF (COND
                             ((IGREATERP DX DY)              (* ; 
                                             "set up the bucket so that the ends will be the same.")
                              (IREMAINDER DX DY))
                             (T (IREMAINDER DY DX]
          [COND
             [USERFN                                         (* ; 
           "if user function is being called, don't bother bringing window to top uninterruptably.")
                    (COND
                       ((IGEQ DX DY)                         (* ; "X is the fastest mover.")
                        (until (IGREATERP X1 X2)
                           do                            (* ; "main loop")
                                 (COND
                                    (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM)))
                                 [COND
                                    (DASHTAIL                (* ; "do dashing.")
                                           (COND
                                              ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
                                               (SETQ DASHON (NOT DASHON))
                                               (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
                                                                  DASHLST))
                                               (SETQ DASHCNT (CAR DASHTAIL]
                                 [COND
                                    ((NOT (IGREATERP DX (add CDL DY)))
                                     (add Y1 YINC)
                                     (COND
                                        ((COND
                                            ((EQ YINC -1)
                                             (ILESSP Y1 Y2))
                                            ((IGREATERP Y1 Y2)))
                                         (RETURN)))
                                     (SETQ CDL (IDIFFERENCE CDL DX]
                                 (add X1 1)))
                       (T                                    (* ; "Y is the fastest mover.")
                          (until (COND
                                        ((EQ YINC -1)
                                         (ILESSP Y1 Y2))
                                        ((IGREATERP Y1 Y2)))
                             do                          (* ; "main loop")
                                   (COND
                                      (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM)))
                                   [COND
                                      (DASHTAIL              (* ; "do dashing.")
                                             (COND
                                                ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
                                                 (SETQ DASHON (NOT DASHON))
                                                 (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
                                                                    DASHLST))
                                                 (SETQ DASHCNT (CAR DASHTAIL]
                                   [COND
                                      ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
                                       (COND
                                          ((IGREATERP (SETQ X1 (ADD1 X1))
                                                  X2)
                                           (RETURN)))
                                       (SETQ CDL (IDIFFERENCE CDL DY]
                                   (add Y1 YINC]
             (T                                              (* ; 
                                              "when we put the points down make it uninterruptable")
                (COND
                   [(IGEQ DX DY)                             (* ; "X is the fastest mover.")
                    (until (IGREATERP X1 X2)
                       do                                (* ; "main loop")
                             (COND
                                (DASHON (DRAWPOINT X1 Y1 BRUSH DISPLAYSTREAM OPERATION)))
                             [COND
                                (DASHTAIL                    (* ; "do dashing.")
                                       (COND
                                          ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
                                           (SETQ DASHON (NOT DASHON))
                                           (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
                                                              DASHLST))
                                           (SETQ DASHCNT (CAR DASHTAIL]
                             [COND
                                ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
                                 (SETQ Y1 (IPLUS Y1 YINC))
                                 (COND
                                    ((COND
                                        ((EQ YINC -1)
                                         (ILESSP Y1 Y2))
                                        ((IGREATERP Y1 Y2)))
                                     (RETURN)))
                                 (SETQ CDL (IDIFFERENCE CDL DX]
                             (SETQ X1 (ADD1 X1]
                   (T                                        (* ; "Y is the fastest mover.")
                      (until (COND
                                    ((EQ YINC -1)
                                     (ILESSP Y1 Y2))
                                    ((IGREATERP Y1 Y2)))
                         do                              (* ; "main loop")
                               (COND
                                  (DASHON (DRAWPOINT X1 Y1 BRUSH DISPLAYSTREAM OPERATION)))
                               [COND
                                  (DASHTAIL                  (* ; "do dashing.")
                                         (COND
                                            ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT)))
                                             (SETQ DASHON (NOT DASHON))
                                             (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL))
                                                                DASHLST))
                                             (SETQ DASHCNT (CAR DASHTAIL]
                               [COND
                                  ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
                                   (COND
                                      ((IGREATERP (SETQ X1 (ADD1 X1))
                                              X2)
                                       (RETURN)))
                                   (SETQ CDL (IDIFFERENCE CDL DY]
                               (SETQ Y1 (IPLUS Y1 YINC]
          (RETURN NIL])

(\DRAWCIRCLE.XDISPLAY
  [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING)
    (DECLARE (LOCALVARS . T))                      (* ; "Edited 16-Jul-91 14:59 by matsuda")
    (COND
       ((OR (NOT (NUMBERP RADIUS))
            (ILESSP (SETQ RADIUS (FIXR RADIUS))
                   0))
        (\ILLEGAL.ARG RADIUS))
       ((EQ RADIUS 0)
        NIL)
       (DASHING (DRAWCURVE (CDR (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS 0 360))
                       T BRUSH DASHING DISPLAYSTREAM))
       (T (PROG (X Y D DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT 
                   LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE 
                   RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION HEIGHTMINUS1 CX CY BBT 
                   COLOR COLORBRUSHBASE NBITS DISPLAYDATA USERFN)
                (SETQ X 0)
                (SETQ Y RADIUS)
                (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS)))
                (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM))
                (SETQ USERFN (AND (LITATOM BRUSH)
                                  BRUSH))
                (SETQ CX CENTERX)
                (SETQ CY CENTERY)
                [COND
                   ((EQ RADIUS 1)
                    (COND
                       (USERFN (APPLY* USERFN CX CY DISPLAYSTREAM))
                       (T (DRAWPOINT CX CY BRUSH DISPLAYSTREAM)))
                    (RETURN))
                   (T (COND
                         (USERFN (APPLY* USERFN CX (IPLUS CY RADIUS)
                                        DISPLAYSTREAM)
                                (APPLY* USERFN CX (IDIFFERENCE CY RADIUS)
                                       DISPLAYSTREAM))
                         (T (DRAWPOINT CX (IPLUS CY RADIUS)
                                   BRUSH DISPLAYSTREAM)
                            (DRAWPOINT CX (IDIFFERENCE CY RADIUS)
                                   BRUSH DISPLAYSTREAM]
            LP  [COND
                   [(IGREATERP 0 D)
                    (SETQ X (ADD1 X))
                    (COND
                       ((IGREATERP (UNFOLD (IPLUS D Y)
                                          2)
                               1)
                        (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
                                                2)
                                       4))
                        (SETQ Y (SUB1 Y)))
                       (T (SETQ D (IPLUS D (UNFOLD X 2)
                                         1]
                   ((OR (EQ 0 D)
                        (IGREATERP X D))
                    (SETQ X (ADD1 X))
                    (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y)
                                            2)
                                   4))
                    (SETQ Y (SUB1 Y)))
                   (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2))
                                     3))
                      (SETQ Y (SUB1 Y]
                (COND
                   [(EQ Y 0)
                    (COND
                       (USERFN (APPLY* USERFN (IPLUS CX X)
                                      CY DISPLAYSTREAM)
                              (APPLY* USERFN (IDIFFERENCE CX X)
                                     CY DISPLAYSTREAM))
                       (T (DRAWPOINT (IPLUS CX X)
                                 CY BRUSH DISPLAYSTREAM)
                          (DRAWPOINT (IDIFFERENCE CX X)
                                 CY BRUSH DISPLAYSTREAM]
                   (T (COND
                         (USERFN (APPLY* USERFN (IPLUS CX X)
                                        (IPLUS CY Y)
                                        DISPLAYSTREAM)
                                (APPLY* USERFN (IDIFFERENCE CX X)
                                       (IPLUS CY Y)
                                       DISPLAYSTREAM)
                                (APPLY* USERFN (IPLUS CX X)
                                       (IDIFFERENCE CY Y)
                                       DISPLAYSTREAM)
                                (APPLY* USERFN (IDIFFERENCE CX X)
                                       (IDIFFERENCE CY Y)
                                       DISPLAYSTREAM))
                         (T (DRAWPOINT (IPLUS CX X)
                                   (IPLUS CY Y)
                                   BRUSH DISPLAYSTREAM)
                            (DRAWPOINT (IDIFFERENCE CX X)
                                   (IPLUS CY Y)
                                   BRUSH DISPLAYSTREAM)
                            (DRAWPOINT (IPLUS CX X)
                                   (IDIFFERENCE CY Y)
                                   BRUSH DISPLAYSTREAM)
                            (DRAWPOINT (IDIFFERENCE CX X)
                                   (IDIFFERENCE CY Y)
                                   BRUSH DISPLAYSTREAM)))
                      (GO LP)))
                (MOVETO CENTERX CENTERY DISPLAYSTREAM)
                (RETURN NIL])

(\DRAWCURVE.XDISPLAY
  [LAMBDA (DISPLAYSTREAM KNOTS CLOSED BRUSH DASHING)   (* ; "Edited 16-Jul-91 17:04 by matsuda")
    (PROG ((DASHLST (\GOOD.DASHLST DASHING BRUSH)))
          (SELECTQ (LENGTH KNOTS)
              (0                                             (* ; 
                                                       "No knots => empty curve rather than error?")
                 NIL)
              (1                                             (* ; 
                                                           "only one knot, put down a brush shape")
                 (OR (type? POSITION (CAR KNOTS))
                     (ERROR "bad knot" (CAR KNOTS)))
                 (\DRAWPOINT.DISPLAY DISPLAYSTREAM (fetch XCOORD of (CAR KNOTS))
                        (fetch YCOORD of (CAR KNOTS))
                        BRUSH))
              (2 (OR (type? POSITION (CAR KNOTS))
                     (ERROR "bad knot" (CAR KNOTS)))
                 (OR (type? POSITION (CADR KNOTS))
                     (ERROR "bad knot" (CADR KNOTS)))
                 (\XLINEWITHBRUSH (fetch XCOORD of (CAR KNOTS))
                        (fetch YCOORD of (CAR KNOTS))
                        (fetch XCOORD of (CADR KNOTS))
                        (fetch YCOORD of (CADR KNOTS))
                        BRUSH DASHLST DISPLAYSTREAM))
              (\XCURVE2 (PARAMETRICSPLINE KNOTS CLOSED)
                     BRUSH DASHLST DISPLAYSTREAM))
          (RETURN DISPLAYSTREAM])

(\XCURVE2
  [LAMBDA (SPLINE BRUSH DASHLST DISPLAYSTREAM)
    (DECLARE (SPECVARS . T))                       (* ; "Edited 16-Jul-91 17:16 by matsuda")
    (PROG (BRUSHBM DestinationBitMap OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE BRUSHRASTERWIDTH LEFT
                 RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH
                 RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS \CURX \CURY 
                 \OLDX \OLDY \OLDERX \OLDERY LKNOT (DASHON T)
                 (DASHTAIL DASHLST)
                 (DASHCNT (CAR DASHLST))
                 NPOINTS NSEGS POINTSPERSEG DX D2X D3X DY D2Y D3Y D1 D2 D3 X0 Y0 X1 Y1 DX DDX DDDX DY
                 DDY DDDY (XPOLY (create POLYNOMIAL))
                 (X/PRIME/POLY (create POLYNOMIAL))
                 (YPOLY (create POLYNOMIAL))
                 (Y/PRIME/POLY (create POLYNOMIAL))
                 (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))
                 (USERFN (AND (LITATOM BRUSH)
                              BRUSH)))
          (SETQ BRUSHBM (\GETBRUSH BRUSH))
          (\CURVESTART (ELT (fetch (SPLINE SPLINEX) of SPLINE)
                            1)
                 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
                      1))
          [bind PERSEG for KNOT from 1 to (SUB1 (fetch %#KNOTS of SPLINE))
             when (PROGN 
                             (* ;; 
                           "Loop thru the segments of the spline curve, drawing each in turn.")

                             (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
                                           KNOT))
                             (SETQ Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
                                           KNOT))
                             (SETQ X1 (ELT (fetch (SPLINE SPLINEX) of SPLINE)
                                           (ADD1 KNOT)))
                             (SETQ Y1 (ELT (fetch (SPLINE SPLINEY) of SPLINE)
                                           (ADD1 KNOT)))
                             (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of SPLINE)
                                           KNOT))
                             (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of SPLINE)
                                           KNOT))
                             (SETQ DDX (ELT (fetch SPLINEDDX of SPLINE)
                                            KNOT))
                             (SETQ DDY (ELT (fetch SPLINEDDY of SPLINE)
                                            KNOT))
                             (SETQ DDDX (ELT (fetch SPLINEDDDX of SPLINE)
                                             KNOT))
                             (SETQ DDDY (ELT (fetch SPLINEDDDY of SPLINE)
                                             KNOT))
                             (SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0))
                                                                 (IABS (IDIFFERENCE Y1 Y0)))
                                                          3)
                                                  2))
                             (NOT (ZEROP NPOINTS)))
             do [COND
                       ((ILEQ NPOINTS 64)
                        (SETQ NSEGS 1)
                        (SETQ POINTSPERSEG NPOINTS))
                       (T (SETQ NSEGS (FOLDLO NPOINTS 64))
                          (SETQ POINTSPERSEG 64)
                          (SETQ NPOINTS (UNFOLD NSEGS 64]
                   (SETQ D1 (FQUOTIENT 1.0 NPOINTS))
                   (SETQ D2 (FTIMES D1 D1))
                   (SETQ D3 (FTIMES D2 D1))
                   (SETQ D3X (FTIMES D3 DDDX))
                   (SETQ D3Y (FTIMES D3 DDDY))
                   (COND
                      [(EQ NSEGS 1)
                       [SETQ DX (FPLUS (FTIMES D1 DX)
                                       (FTIMES DDX D2 0.5)
                                       (FTIMES DDDX D3 (CONSTANT (FQUOTIENT 1.0 6.0]
                       (SETQ D2X (FPLUS (FTIMES D2 DDX)
                                        (FTIMES D3 DDDX)))
                       [SETQ DY (FPLUS (FTIMES D1 DY)
                                       (FTIMES D2 DDY 0.5)
                                       (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0]
                       (SETQ D2Y (FPLUS (FTIMES D2 DDY)
                                        (FTIMES D3 DDDY)))
                       (COND
                          (USERFN (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM 
                                         DISPLAYDATA NIL NIL USERFN DISPLAYSTREAM))
                          (T (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM 
                                    DISPLAYDATA NIL NIL NIL DISPLAYSTREAM]
                      (T (SETQ PERSEG (FQUOTIENT 1.0 NSEGS))
                         (LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0)
                         (LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0)
                         (bind (TT _ 0.0)
                                (DDDX/PER/SEG _ (FTIMES DDDX PERSEG))
                                (DDDY/PER/SEG _ (FTIMES DDDY PERSEG))
                                [D3XFACTOR _ (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0]
                                [D3YFACTOR _ (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0]
                            for I from 0 to (SUB1 NSEGS)
                            do (SETQ TT (FPLUS TT PERSEG))
                                  (SETQ X1 (POLYEVAL TT XPOLY 3))
                                  (SETQ Y1 (POLYEVAL TT YPOLY 3))
                                  (SETQ DX (FPLUS (FTIMES D1 DX)
                                                  (FTIMES D2 DDX 0.5)
                                                  D3XFACTOR))
                                  (SETQ D2X (FPLUS (FTIMES D2 DDX)
                                                   (FTIMES D3 DDDX)))
                                  (SETQ DY (FPLUS (FTIMES D1 DY)
                                                  (FTIMES D2 DDY 0.5)
                                                  D3YFACTOR))
                                  (SETQ D2Y (FPLUS (FTIMES D2 DDY)
                                                   (FTIMES D3 DDDY)))
                                  (COND
                                     (USERFN (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 
                                                    BRUSHBM DISPLAYDATA NIL NIL USERFN DISPLAYSTREAM)
                                            )
                                     (T (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM 
                                               DISPLAYDATA NIL NIL NIL DISPLAYSTREAM)))
                                  (SETQ X0 X1)
                                  (SETQ Y0 Y1)
                                  (SETQ DDX (FPLUS DDX DDDX/PER/SEG))
                                  (SETQ DDY (FPLUS DDY DDDY/PER/SEG))
                                  (SETQ DX (POLYEVAL TT X/PRIME/POLY 2))
                                  (SETQ DY (POLYEVAL TT Y/PRIME/POLY 2]
          (COND
             (USERFN (\XCURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA NIL T USERFN 
                            DISPLAYSTREAM))
             (T (\XCURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA NIL T NIL DISPLAYSTREAM])

(\XCURVE
  [LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM DISPLAYDATA BBT ENDING USERFN DISPLAYSTREAM)
    (DECLARE (LOCALVARS . T))                      (* ; "Edited 16-Jul-91 16:57 by matsuda")
    (PROG (OLDX X Y OLDY DELTAX DELTAY DELTA TX TY OOLDX OOLDY)
          [COND
             ((NEQ N 0)
              (SETQ OLDX X0)
              (SETQ OLDY Y0)
              (\XCURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM)
              (SETQ X (\CONVERTTOFRACTION (FPLUS OLDX 0.49)))
              (SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY 0.49)))
              (SETQ DX (\CONVERTTOFRACTION DX))
              (SETQ DY (\CONVERTTOFRACTION DY))
              (SETQ DDX (\CONVERTTOFRACTION DDX))
              (SETQ DDY (\CONVERTTOFRACTION DDY))
              (SETQ DDDX (\CONVERTTOFRACTION DDDX))
              (SETQ DDDY (\CONVERTTOFRACTION DDDY))
              [for I from 1 to N do (\BOXIPLUS X DX)
                                                   (\BOXIPLUS DX DDX)
                                                   (\BOXIPLUS DDX DDDX)
                                                   (\BOXIPLUS Y DY)
                                                   (\BOXIPLUS DY DDY)
                                                   (\BOXIPLUS DDY DDDY)
                                                   (SETQ OOLDX OLDX)
                                                   (SETQ OOLDY OLDY)
                                                   (SETQ DELTAX (IDIFFERENCE (SETQ OLDX (
                                                                                      \GETINTEGERPART
                                                                                         X))
                                                                       OOLDX))
                                                   (SETQ DELTAY (IDIFFERENCE (SETQ OLDY (
                                                                                      \GETINTEGERPART
                                                                                         Y))
                                                                       OOLDY))
                                                   (SETQ DELTA (IMAX (IABS DELTAX)
                                                                     (IABS DELTAY)))
                                                   (COND
                                                      ((EQ DELTA 1)
                                                       (\XCURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM)
                                                       ))
                                                   (COND
                                                      ((IGREATERP DELTA 1)
                                                       (SETQ DELTAX (\CONVERTTOFRACTION (FQUOTIENT
                                                                                         DELTAX DELTA
                                                                                         )))
                                                       (SETQ DELTAY (\CONVERTTOFRACTION (FQUOTIENT
                                                                                         DELTAY DELTA
                                                                                         )))
                                                       (SETQ TX (\CONVERTTOFRACTION OOLDX))
                                                       (SETQ TY (\CONVERTTOFRACTION OOLDY))
                                                       (for I from 0 to DELTA
                                                          do (\XCURVESMOOTH (\GETINTEGERPART
                                                                                 TX)
                                                                        (\GETINTEGERPART TY)
                                                                        USERFN DISPLAYSTREAM)
                                                                (\BOXIPLUS TX DELTAX)
                                                                (\BOXIPLUS TY DELTAY]
              (COND
                 (USERFN (\XCURVESMOOTH X1 Y1 USERFN DISPLAYSTREAM))
                 (T (\XCURVESMOOTH X1 Y1 NIL DISPLAYSTREAM)))
              (AND DISPLAYSTREAM (MOVETO X1 Y1 DISPLAYSTREAM]
          (COND
             (ENDING (\XCURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX))
                            (IPLUS \CURY \CURY (IMINUS \OLDY))
                            USERFN DISPLAYSTREAM)
                    (\XCURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX))
                           (IPLUS \CURY \CURY (IMINUS \OLDY))
                           USERFN DISPLAYSTREAM)))
          (RETURN NIL])
)
(DEFINEQ

(BITBLT
  [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
                 SOURCETYPE OPERATION TEXTURE CLIPPINGREGION)
                                                           (* ; "Edited 17-Jul-91 08:49 by matsuda")
    (DECLARE (LOCALVARS . T))

    (* ;; "IRM defined defaults")

    (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0))
    (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0))
    (COND
       [(EQ SOURCETYPE 'TEXTURE)
        (COND
           ((type? BITMAP DESTINATION)
            (\BLTSHADE.BITMAP TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT 
                   OPERATION CLIPPINGREGION))
           ((XLIB:DRAWABLE-P DESTINATION)
            (\XBLTSHADE.PIXMAP TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
                   OPERATION CLIPPINGREGION))
           (T (PROG ((STREAM (\OUTSTREAMARG DESTINATION)))
                    (RETURN (IMAGEOP 'IMBLTSHADE STREAM TEXTURE STREAM DESTINATIONLEFT 
                                   DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION]
       (T (PROG (SOURCEDD SOURCEBM CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM)
                [COND
                   [(OR (type? BITMAP SOURCE)
                        (XLIB:DRAWABLE-P SOURCE))
                    (OR SOURCELEFT (SETQ SOURCELEFT 0))
                    (OR SOURCEBOTTOM (SETQ SOURCEBOTTOM 0))
                    (SETQ SOURCEBM SOURCE)
                    (SETQ CLIPPEDSOURCELEFT SOURCELEFT)
                    (SETQ CLIPPEDSOURCEBOTTOM SOURCEBOTTOM)  (* ; 
                                                   "limit the WIDTH and HEIGHT to the source size.")
                    [SETQ WIDTH (COND
                                   (WIDTH (IMIN WIDTH (IDIFFERENCE (BITMAPWIDTH SOURCE)
                                                             SOURCELEFT)))
                                   (T (BITMAPWIDTH SOURCE]
                    (SETQ HEIGHT (COND
                                    (HEIGHT (IMIN HEIGHT (IDIFFERENCE (BITMAPHEIGHT SOURCE)
                                                                SOURCEBOTTOM)))
                                    (T (BITMAPHEIGHT SOURCE]
                   ((SETQ SOURCEDD (\GETDISPLAYDATA SOURCE))
                    [OR SOURCELEFT (SETQ SOURCELEFT (fetch (REGION LEFT)
                                                       of (ffetch (\DISPLAYDATA 
                                                                                 DDClippingRegion)
                                                                 of SOURCEDD]
                    [OR SOURCEBOTTOM (SETQ SOURCEBOTTOM (fetch (REGION BOTTOM)
                                                           of (ffetch (\DISPLAYDATA 
                                                                                     DDClippingRegion
                                                                                     ) of 
                                                                                             SOURCEDD
                                                                         ]
                                                             (* ; 
                                                          "do transformations coming out of source")
                    (SETQ SOURCEBM (fetch (\DISPLAYDATA DDDestination) of SOURCEDD))
                    (SETQ CLIPPEDSOURCELEFT (IMAX (SETQ SOURCELEFT (\DSPTRANSFORMX SOURCELEFT 
                                                                          SOURCEDD))
                                                  (fetch (\DISPLAYDATA DDClippingLeft)
                                                     of SOURCEDD)))
                    (SETQ CLIPPEDSOURCEBOTTOM (IMAX (SETQ SOURCEBOTTOM (\DSPTRANSFORMY SOURCEBOTTOM 
                                                                              SOURCEDD))
                                                    (fetch (\DISPLAYDATA DDClippingBottom)
                                                       of SOURCEDD)))
                                                             (* ; 
                                             "limit the WIDTH and HEIGHT by the source dimensions.")
                    [SETQ WIDTH (COND
                                   (WIDTH (IMIN WIDTH (IDIFFERENCE (fetch (\DISPLAYDATA 
                                                                                     DDClippingRight)
                                                                      of SOURCEDD)
                                                             CLIPPEDSOURCELEFT)))
                                   (T (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight)
                                                      of SOURCEDD)
                                             CLIPPEDSOURCELEFT]
                    [SETQ HEIGHT (COND
                                    (HEIGHT (IMIN HEIGHT (IDIFFERENCE (fetch (\DISPLAYDATA 
                                                                                        DDClippingTop
                                                                                        )
                                                                         of SOURCEDD)
                                                                CLIPPEDSOURCEBOTTOM)))
                                    (T (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingTop)
                                                       of SOURCEDD)
                                              CLIPPEDSOURCEBOTTOM]
                                                             (* ; 
                                               "if texture is not given, use the display stream's.")
                    (OR TEXTURE (SETQ TEXTURE (ffetch (\DISPLAYDATA DDTexture) of SOURCEDD]
                (COND
                   ((OR (IGEQ 0 WIDTH)
                        (IGEQ 0 HEIGHT))                     (* ; 
                                               "if either width or height is 0, don't do anything.")
                    (RETURN)))
                (RETURN (COND
                           [(type? BITMAP DESTINATION)
                            (COND
                               ((WINDOWP SOURCE)

                                (* ;; "bring source window to the top.  Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.")

                                (.WHILE.TOP.DS. (\OUTSTREAMARG SOURCE)
                                       (\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION 
                                              DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT 
                                              SOURCETYPE OPERATION TEXTURE CLIPPINGREGION 
                                              CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM)))
                               (T (\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION 
                                         DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE 
                                         OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
                                         CLIPPEDSOURCEBOTTOM]
                           ((XLIB:DRAWABLE-P DESTINATION)
                            (\XBITBLT.PIXMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION 
                                   DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE 
                                   OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
                                   CLIPPEDSOURCEBOTTOM))
                           (T (PROG (STREAM)
                                    (SETQ STREAM (\OUTSTREAMARG DESTINATION))
                                    (COND
                                       ((AND (NEQ SOURCE DESTINATION)
                                             (WINDOWP SOURCE))

                                 (* ;; "both source and destination are windows, see if they overlap and use an intermediate bitmap.  Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.")

                                        [COND
                                           ((WINDOWP DESTINATION)
                                            (COND
                                               ((WOVERLAPP SOURCE DESTINATION)
                                                (RETURN (PROG (SCRATCHBM)
                                                              (.WHILE.TOP.DS. (\OUTSTREAMARG SOURCE)
                                                                     (BITBLT SOURCEBM SOURCELEFT
                                                                            SOURCEBOTTOM
                                                                            (SETQ SCRATCHBM
                                                                             (BITMAPCREATE WIDTH 
                                                                                    HEIGHT))
                                                                            0 0 WIDTH HEIGHT
                                                                            'INPUT
                                                                            'REPLACE))
                                                              (RETURN (BITBLT SCRATCHBM 0 0 
                                                                             STREAM DESTINATIONLEFT 
                                                                             DESTINATIONBOTTOM WIDTH
                                                                             HEIGHT SOURCETYPE 
                                                                             OPERATION TEXTURE 
                                                                             CLIPPINGREGION]
                                                             (* ; 
    "bring the source to the top.  this should be done uninterruptably but is better than nothing.")
                                        (TOTOPW SOURCE)))
                                    (IMAGEOP 'IMBITBLT STREAM SOURCEBM SOURCELEFT SOURCEBOTTOM STREAM
                                           DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE
                                           OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT 
                                           CLIPPEDSOURCEBOTTOM])
)
(DEFINEQ

(XCREATEWFROMPIXMAP
  [LAMBDA (PIXMAP SCREEN)                              (* ; "Edited  7-Mar-91 16:39 by matsuda")
    (PROG (WINDOW WIDTH HEIGHT)
          (SETQ WINDOW (XCREATEW (create SCREENREGION
                                            SCREEN _ (\INSURESCREEN SCREEN)
                                            LEFT _ 0
                                            BOTTOM _ 0
                                            WIDTH _ (SETQ WIDTH (PIXMAPWIDTH PIXMAP))
                                            HEIGHT _ (SETQ HEIGHT (PIXMAPHEIGHT PIXMAP)))
                              NIL 0 T))
          (WINDOWPROP WINDOW 'MINSIZE (CONS (IMIN MinWindowWidth WIDTH)
                                            (IMIN MinWindowWidth HEIGHT)))
          (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*)
                 CL:BOOLE-1)
          (XLIB:COPY-AREA PIXMAP XLIB::*GC* 0 0 WIDTH HEIGHT (fetch (WINDOW SAVE) of WINDOW)
                 0 0)
          (RETURN WINDOW])

(PIXMAPCREATE
  [LAMBDA (WIDTH HEIGHT BITSPERPIXEL)                  (* ; "Edited  6-Mar-91 17:25 by matsuda")
    (PROG NIL
          (SETQ BITSPERPIXEL (\INSUREBITSPERPIXEL BITSPERPIXEL))
          (RETURN (XLIB:CREATE-PIXMAP :WIDTH WIDTH :HEIGHT HEIGHT :DEPTH BITSPERPIXEL :DRAWABLE 
                         XLIB::*ROOT*])

(PIXMAPWIDTH
  [LAMBDA (PIXMAP)                                     (* ; "Edited  6-Mar-91 16:34 by matsuda")
    (COND
       ((XLIB:DRAWABLE-P PIXMAP)
        (XLIB:DRAWABLE-WIDTH PIXMAP))
       ((type? WINDOW PIXMAP)
        (WINDOWPROP PIXMAP 'WIDTH))
       (T (\ILLEGAL.ARG PIXMAP])

(PIXMAPHEIGHT
  [LAMBDA (PIXMAP)                                     (* ; "Edited  6-Mar-91 16:37 by matsuda")
    (COND
       ((XLIB:DRAWABLE-P PIXMAP)
        (XLIB:DRAWABLE-HEIGHT PIXMAP))
       ((type? WINDOW PIXMAP)
        (WINDOWPROP PIXMAP 'HEIGHT))
       (T (\ILLEGAL.ARG PIXMAP])
)
(DEFINEQ

(XCREATEW
  [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG)          (* ; "Edited 10-Apr-91 14:02 by matsuda")

    (* ;; "creates and returns a window.")

    (PROG (SCREEN REG DSP DISPLAYDATA TITLEHEIGHT WINDOW WBORDER)
          (SETQ WBORDER (COND
                           ((NUMBERP BORDERSIZE)
                            (ABS BORDERSIZE))
                           ((NUMBERP WBorder)
                            (ABS WBorder))
                           (T 2)))
          (COND
             ((type? REGION REGION)
              (SETQ SCREEN \XSCREEN)                         (* ; 
                                                   "Protect against user smashing REGION later on.")
              (SETQ REG (COPY REGION)))
             [(type? SCREENREGION REGION)
              (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION))
              (SETQ REG (COPY (fetch (SCREENREGION REGION) of REGION]
             (T (ERROR "Not a region" REG)))
          [COND
             ((NULL DSP)                                     (* ; 
                                          "Don't have a DSP yet.  User passed some kind of region.")
              (SETQ DSP (XDSPCREATE (fetch (XSCREEN SCDESTINATION) of SCREEN)))
              (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DSP]
          (COND
             ((NOT (IGREATERP (IMIN (fetch (REGION WIDTH) of REG)
                                    (fetch (REGION HEIGHT) of REG))
                          (UNFOLD WBORDER 2)))
              (ERROR "Region too small to use as a window" REG)))
          (SETQ WINDOW
           (create WINDOW
                  DSP _ DSP
                  REG _ REG
                  SAVE _ NIL
                  WTITLE _ TITLE
                  WBORDER _ WBORDER
                  NEXTW _ 'CLOSED
                  SCREEN _ SCREEN
                  BUTTONEVENTFN _ NIL))
          (replace (\DISPLAYDATA XWINDOWHINT) of DISPLAYDATA with WINDOW)
          (XSHOWWFRAME WINDOW)
          (DSPDESTINATION (fetch (WINDOW SAVE) of WINDOW)
                 DSP)
          (ADVISEXWDS WINDOW)                            (* ; 
                                       "make the display stream and window agree about dimensions.")
          (MOVETOUPPERLEFT WINDOW)
          (AND TITLE (XLIB:SET-STANDARD-PROPERTIES (fetch (WINDOW SAVE) of WINDOW)
                            :NAME TITLE))
          (COND
             ((NOT NOOPENFLG)
              (XOPENW WINDOW)))
          (RETURN WINDOW])

(ADVISEXWDS
  [LAMBDA (WINDOW OLDREG MOVEONLYFLG)
    (DECLARE (LOCALVARS . T))                      (* ; "Edited 25-Feb-91 18:26 by matsuda")
    (PROG (R D WBORDERSIZE CLIPREG TWICEBORDER PROC OFFSET)
          (SETQ R (fetch (WINDOW REG) of WINDOW))
          (SETQ D (fetch (WINDOW DSP) of WINDOW))
          (SETQ WBORDERSIZE (fetch (WINDOW WBORDER) of WINDOW))
          (SETQ TWICEBORDER (UNFOLD WBORDERSIZE 2))
          (COND
             (OLDREG (OR MOVEONLYFLG (DSPCLIPPINGREGION
                                      [create REGION
                                             LEFT _ 0
                                             BOTTOM _ 0
                                             WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH)
                                                                     of R)
                                                            TWICEBORDER)
                                             HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT)
                                                                             of R)
                                                                    TWICEBORDER)
                                                             (COND
                                                                [(fetch (WINDOW WTITLE)
                                                                    of WINDOW)
                                                                 (DSPLINEFEED
                                                                  NIL
                                                                  (fetch (XSCREEN SCTITLEDS)
                                                                     of (fetch (WINDOW SCREEN
                                                                                              )
                                                                               of WINDOW]
                                                                (T 0]
                                      D)))
             (T (SETQ OFFSET (IMAX (FOLDHI WBORDERSIZE 2)
                                   (IDIFFERENCE WBORDERSIZE 2)))
                (DSPXOFFSET OFFSET D)
                (DSPYOFFSET OFFSET D)
                (DSPCLIPPINGREGION [create REGION
                                          LEFT _ 0
                                          BOTTOM _ 0
                                          WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of
                                                                                         R)
                                                         TWICEBORDER)
                                          HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT)
                                                                          of R)
                                                                 TWICEBORDER)
                                                          (COND
                                                             [(fetch (WINDOW WTITLE) of
                                                                                         WINDOW)
                                                              (DSPLINEFEED NIL
                                                                     (fetch (XSCREEN SCTITLEDS)
                                                                        of (fetch
                                                                                (WINDOW SCREEN)
                                                                                  of WINDOW]
                                                             (T 0]
                       D)))
          [COND
             ((NULL MOVEONLYFLG)                             (* ; 
                                         "if the previous right margin was the default, change it.")
              (AND (OR (NOT OLDREG)
                       (EQ (DSPRIGHTMARGIN NIL D)
                           (IDIFFERENCE (fetch (REGION WIDTH) of OLDREG)
                                  TWICEBORDER)))
                   (DSPRIGHTMARGIN (IDIFFERENCE (fetch (REGION WIDTH) of R)
                                          TWICEBORDER)
                          D))
              (COND
                 ((AND (SETQ PROC (WINDOWPROP WINDOW 'PROCESS))
                       (EQ D (PROCESS.TTY PROC)))            (* ; 
                                             "if the window changing is a tty, set its linelength.")
                  [PROCESS.EVAL PROC (LIST (FUNCTION PAGEHEIGHT)
                                           (IQUOTIENT (fetch (REGION HEIGHT)
                                                         of (SETQ CLIPREG (DSPCLIPPINGREGION
                                                                               NIL D)))
                                                  (IMINUS (DSPLINEFEED NIL D]
                  (PROCESS.EVAL PROC '(SETLINELENGTH))
                  (IF NIL
                      THEN                               (* ; "try it without this.")
                            (COND
                               ((EQ (PROCESSPROP PROC 'NAME)
                                    'EXEC)

                                (* ;; "in the exec process, make sure the current position is inside the new shape.  reuse variables R and TWICEBORDER to save binding.")

                                (COND
                                   ((ILESSP (SETQ R (DSPYPOSITION NIL D))
                                           (SETQ TWICEBORDER (fetch (REGION BOTTOM) of 
                                                                                              CLIPREG
                                                                    )))
                                    (DSPYPOSITION TWICEBORDER D))
                                   ((IGREATERP R (SETQ TWICEBORDER (IPLUS (fetch (REGION HEIGHT)
                                                                             of CLIPREG)
                                                                          TWICEBORDER)))
                                    (DSPYPOSITION (IDIFFERENCE TWICEBORDER (FONTPROP D 'ASCENT))
                                           D]
          (UPDATE/SCROLL/REG WINDOW))
    WINDOW])

(XOPENW
  [LAMBDA (WINDOW)                                     (* ; "Edited 31-Jan-91 15:28 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (COND
       ((OPENWP WINDOW)                                      (* ; 
                    "used to bring the window to top but doesn't since TOTOPW has been documented.")
        NIL)
       (T (PROG [(USEROPENFN (WINDOWPROP WINDOW 'OPENFN]
                (COND
                   ((\USERFNISDON'T USEROPENFN)              (* ; "one of the OPENFNs is DON'T")
                    NIL)
                   (T                                        (* ; 
                                            "open it by putting it on top and swapping its bits in")
                                                             (* \OPENW1 WINDOW)
                                                             (* ; 
                                               "call the openfns after the window has been opened.")
                      (\XOPENW1 WINDOW)
                      (DOUSERFNS USEROPENFN WINDOW)
                      (RETURN WINDOW])

(\XOPENW1
  [LAMBDA (WINDOW)                                     (* ; "Edited  1-Feb-91 15:50 by matsuda")
    (if (EQ (fetch (WINDOW NEXTW) of WINDOW)
                'CLOSED)
        then (PROG ((BASEW (WINDOWPROP WINDOW 'XBASEW))
                        XWIN REG BORDER XTITLEW TOP (SCREEN (fetch (WINDOW SCREEN) of WINDOW)
                                                           )
                        DD)
                       (if BASEW
                           then (XLIB:MAP-WINDOW BASEW)
                         else (WINDOWPROP WINDOW 'XBASEW (SETQ BASEW (\XCREATEBASEW WINDOW)))
                               [AND (WINDOWPROP WINDOW 'TITLE)
                                    (SETQ XTITLEW (WINDOWPROP WINDOW 'XTITLEW]
                               (SETQ XWIN (fetch (WINDOW SAVE) of WINDOW))
                               (SETQ BORDER (XLIB:DRAWABLE-BORDER-WIDTH XWIN))
                               (SETQ TOP 0)
                               [COND
                                  (XTITLEW (XLIB:REPARENT-WINDOW XTITLEW BASEW 0 0)
                                         (SETQ TOP (XLIB:DRAWABLE-HEIGHT XTITLEW]
                               (XLIB:REPARENT-WINDOW XWIN BASEW 0 TOP)
                               (XLIB:MAP-SUBWINDOWS BASEW)
                               (XLIB:MAP-WINDOW BASEW))
                       (UNINTERRUPTABLY
                           (XLIB:MAP-WINDOW (fetch (WINDOW SAVE) of WINDOW))
                           (replace (WINDOW NEXTW) of WINDOW with (fetch (XSCREEN
                                                                                          SCTOPW)
                                                                                 of SCREEN))
                           (replace (XSCREEN SCTOPW) of SCREEN with WINDOW))])

(XCLOSEW
  [LAMBDA (WINDOW)                                     (* ; "Edited 31-Jan-91 16:12 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (COND
       ((OPENWP WINDOW)
        (COND
           ((\OKTOCLOSEW WINDOW)
            (AND (OPENWP WINDOW)
                 (\XCLOSEW1 WINDOW))
            T])

(\XCLOSEW1
  [LAMBDA (WINDOW)                                     (* ; "Edited  1-Feb-91 15:07 by matsuda")
    (LET (SCREEN NEXTW SAVE)
         (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW))
         (SETQ NEXTW (fetch (XSCREEN SCTOPW) of SCREEN))
         (COND
            ((NULL NEXTW)
             NIL)
            ((EQ NEXTW WINDOW)
             (UNINTERRUPTABLY
                 (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW))
                 (replace (XSCREEN SCTOPW) of SCREEN with (fetch (WINDOW NEXTW)
                                                                         of NEXTW))
                 (replace (WINDOW NEXTW) of WINDOW with 'CLOSED))
             T)
            (T (PROG NIL
                     (SETQ SAVE NEXTW)
                     (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE))
                 LOOP
                     (COND
                        (NEXTW (COND
                                  [(EQ NEXTW WINDOW)
                                   (UNINTERRUPTABLY
                                       (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW))
                                       (replace (WINDOW NEXTW) of SAVE
                                          with (fetch (WINDOW NEXTW) of NEXTW))
                                       (replace (WINDOW NEXTW) of NEXTW with 'CLOSED))]
                                  (T (SETQ SAVE NEXTW)
                                     (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE))
                                     (GO LOOP])

(\XSFFixClippingRegion
  [LAMBDA (DISPLAYDATA)                                (* ; "Edited 25-Feb-91 18:43 by matsuda")

    (* ;; "compute the top, bottom, left and right edges of the clipping region in destination coordinates to save computation every BltChar and coordinate transformation taking into account the size of the bit map as well as the clipping region.")

    (PROG ((CLIPREG (ffetch (\DISPLAYDATA DDClippingRegion) of DISPLAYDATA))
           (BM (ffetch (\DISPLAYDATA DDDestination) of DISPLAYDATA))
           (GC (ffetch (\DISPLAYDATA DDPILOTBBT) of DISPLAYDATA)))
          (freplace (\DISPLAYDATA DDClippingRight) of DISPLAYDATA
             with (IMAX 0 (\DSPTRANSFORMX (IPLUS (ffetch (REGION LEFT) of CLIPREG)
                                                     (ffetch (REGION WIDTH) of CLIPREG))
                                     DISPLAYDATA)))
          (freplace (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA
             with (IMIN (IMAX (\DSPTRANSFORMX (ffetch (REGION LEFT) of CLIPREG)
                                         DISPLAYDATA)
                                  0)
                            MAX.SMALL.INTEGER))
          (freplace (\DISPLAYDATA DDClippingTop) of DISPLAYDATA
             with (IMAX 0 (\DSPTRANSFORMY (IPLUS (ffetch (REGION BOTTOM) of CLIPREG)
                                                     (ffetch (REGION HEIGHT) of CLIPREG))
                                     DISPLAYDATA)))
          (freplace (\DISPLAYDATA DDClippingBottom) of DISPLAYDATA
             with (IMIN (IMAX (\DSPTRANSFORMY (ffetch (REGION BOTTOM) of CLIPREG)
                                         DISPLAYDATA)
                                  0)
                            MAX.SMALL.INTEGER))
          (CL:SETF (XLIB:GCONTEXT-CLIP-MASK GC)
                 (LIST (fetch (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA)
                       (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT BM)
                              (fetch (\DISPLAYDATA DDClippingTop) of DISPLAYDATA))
                       (fetch (REGION WIDTH) of CLIPREG)
                       (fetch (REGION HEIGHT) of CLIPREG])

(XSHOWWFRAME
  [LAMBDA (WIN)                                        (* ; "Edited 27-Feb-91 17:38 by matsuda")

    (* ;; "Displays the border and title in the save image of a window")

    [PROG ((TITLE (fetch (WINDOW WTITLE) of WIN))
           (BORDER (fetch (WINDOW WBORDER) of WIN))
           (SAVEIMAGE (fetch (WINDOW SAVE) of WIN))
           (SCREEN (fetch (WINDOW SCREEN) of WIN))
           (REG (fetch (WINDOW REG) of WIN))
           BLACKPART
           (TITLE-H 0))                                      (* ; "make most of the border black")
          (SETQ BLACKPART (IMAX (FOLDHI BORDER 2)
                                (IDIFFERENCE BORDER 2)))
          (XSHOWWTITLE TITLE SAVEIMAGE BORDER NIL WIN)
          [AND TITLE (SETQ TITLE-H (XLIB:DRAWABLE-HEIGHT (WINDOWPROP WIN 'XTITLEW]
          (if SAVEIMAGE
              then (CL:SETF (XLIB:DRAWABLE-Y SAVEIMAGE)
                              TITLE-H)
                    (CL:SETF (XLIB:DRAWABLE-X SAVEIMAGE)
                           0)
                    (CL:SETF (XLIB:DRAWABLE-WIDTH SAVEIMAGE)
                           (IDIFFERENCE (fetch (REGION WIDTH) of REG)
                                  (ITIMES BLACKPART 2)))
                    [CL:SETF (XLIB:DRAWABLE-HEIGHT SAVEIMAGE)
                           (IDIFFERENCE (fetch (REGION HEIGHT) of REG)
                                  (IPLUS TITLE-H (ITIMES BLACKPART 2]
            else (replace SAVE of WIN
                        with (SETQ SAVEIMAGE (XLIB:CREATE-WINDOW
                                                  :PARENT
                                                  (fetch (XSCREEN SCDESTINATION) of SCREEN)
                                                  :X
                                                  (fetch (REGION LEFT) of REG)
                                                  :Y
                                                  (IDIFFERENCE (fetch (XSCREEN SCHEIGHT)
                                                                  of SCREEN)
                                                         (IDIFFERENCE (fetch (REGION TOP)
                                                                         of REG)
                                                                (IPLUS TITLE-H BLACKPART)))
                                                  :WIDTH
                                                  (IDIFFERENCE (fetch (REGION WIDTH) of
                                                                                         REG)
                                                         (ITIMES BLACKPART 2))
                                                  :HEIGHT
                                                  (IDIFFERENCE (fetch (REGION HEIGHT)
                                                                  of REG)
                                                         (IPLUS TITLE-H (ITIMES BLACKPART 2)))
                                                  :BORDER-WIDTH BLACKPART :BACKGROUND XLIB::*WHITE* 
                                                  :BIT-GRAVITY :NORTH-WEST :BACKING-STORE :ALWAYS]
    WIN])

(XSHOWWTITLE
  [LAMBDA (TITLE BM BORDER CENTERFLG WINDOW)           (* ; "Edited 27-Feb-91 16:51 by matsuda")
    (PROG ((XTITLEW (WINDOWPROP WINDOW 'XTITLEW))
           (XBASEW (WINDOWPROP WINDOW 'XBASEW))
           FONT HEIGHT ASCENT (REG (fetch (WINDOW REG) of WINDOW)))
          (if TITLE
              then (SETQ HEIGHT (IPLUS (SETQ ASCENT (XLIB:FONT-ASCENT XLIB::*DEFAULTFONT*))
                                           (XLIB:FONT-DESCENT XLIB::*DEFAULTFONT*)))
                    (if XTITLEW
                        then (CL:SETF (XLIB:DRAWABLE-WIDTH XTITLEW)
                                        (fetch (REGION WIDTH) of REG))
                      else (SETQ XTITLEW (XLIB:CREATE-WINDOW :PARENT (OR XBASEW XLIB::*ROOT*)
                                                    :X 0 :Y 0 :WIDTH
                                                    (IPLUS (fetch (REGION WIDTH) of REG)
                                                           (IMAX (ITIMES (- BORDER 2)
                                                                        2)
                                                                 0))
                                                    :HEIGHT
                                                    (IPLUS HEIGHT 2)
                                                    :BORDER-WIDTH 0 :BACKGROUND XLIB::*BLACK* 
                                                    :BACKING-STORE :ALWAYS :BIT-GRAVITY :NORTH-WEST))
                           )
                    (if XBASEW
                        then (XLIB:MAP-WINDOW XTITLEW))
                    (CL:SETF (XLIB:GCONTEXT-FONT XLIB::*GC*)
                           XLIB::*DEFAULTFONT*)
                    (CL:SETF (XLIB:GCONTEXT-FOREGROUND XLIB::*GC*)
                           XLIB::*WHITE*)
                    (CL:SETF (XLIB:GCONTEXT-BACKGROUND XLIB::*GC*)
                           XLIB::*BLACK*)
                    (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*)
                           CL:BOOLE-1)
                    (XLIB:CLEAR-AREA XTITLEW)
                    (XLIB:DRAW-IMAGE-GLYPHS XTITLEW XLIB::*GC* BORDER (ADD1 ASCENT)
                           TITLE)
            else (AND XTITLEW (XLIB:DESTROY-WINDOW XTITLEW))
                  (SETQ XTITLEW NIL))
          (WINDOWPROP WINDOW 'XTITLEW XTITLEW)
          (RETURN XTITLEW])

(\XCREATEBASEW
  [LAMBDA (WINDOW)                                     (* ; "Edited 11-Jul-91 14:07 by matsuda")
    (PROG ((XWIN (fetch (WINDOW SAVE) of WINDOW))
           (XTITLEW (WINDOWPROP WINDOW 'XTITLEW))
           (REG (fetch (WINDOW REG)
                       WINDOW))
           (XCURSOR (XCURSORFROMCURSOR DEFAULTCURSOR))
           WIDTH HEIGHT XBORDER BASEW TITLE)
          [SETQ WIDTH (IPLUS (XLIB:DRAWABLE-WIDTH XWIN)
                             (SETQ XBORDER (ITIMES (XLIB:DRAWABLE-BORDER-WIDTH XWIN)
                                                  2]
          (SETQ HEIGHT (IPLUS (XLIB:DRAWABLE-HEIGHT XWIN)
                              XBORDER))
          [COND
             (XTITLEW (SETQ HEIGHT (IPLUS HEIGHT (XLIB:DRAWABLE-HEIGHT XTITLEW]
          (SETQ BASEW (XLIB:CREATE-WINDOW :PARENT XLIB::*ROOT* :X (fetch (REGION LEFT)
                                                                     of REG)
                             :Y
                             (fetch (REGION TOP) of REG)
                             :WIDTH WIDTH :HEIGHT HEIGHT :BORDER-WIDTH 0 :BACKGROUND XLIB::*WHITE* 
                             :GRAVITY :NORTH-WEST :CURSOR XCURSOR :EVENT-MASK
                             (XLIB:MAKE-EVENT-MASK :STRUCTURE-NOTIFY :KEY-PRESS :KEY-RELEASE 
                                    :BUTTON-PRESS :BUTTON-RELEASE :POINTER-MOTION :ENTER-WINDOW 
                                    :LEAVE-WINDOW)))
          (WINDOWPROP WINDOW 'XCURSOR XCURSOR)
          (AND (SETQ TITLE (WINDOWPROP WINDOW 'TITLE))
               (XLIB:SET-STANDARD-PROPERTIES BASEW :NAME TITLE :INPUT :ON))
          (RETURN BASEW])

(\DSPCLIPPINGREGION.XDISPLAY
  [LAMBDA (DISPLAYSTREAM REGION)                       (* ; "Edited  1-Feb-91 10:01 by matsuda")

    (* ;; "sets the clipping region of a display stream.")

    (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
          (RETURN (PROG1 (ffetch DDClippingRegion of DD)
                      [COND
                         (REGION (OR (type? REGION REGION)
                                     (ERROR REGION " is not a REGION."))
                                (UNINTERRUPTABLY
                                    (freplace DDClippingRegion of DD with REGION)
                                    (\XSFFixClippingRegion DD)
                                    (\INVALIDATEDISPLAYCACHE DD))])])
)
(DEFINEQ

(\XDSPPRINTCHAR
  [LAMBDA (STREAM CHARCODE)                            (* ; "Edited 15-Feb-91 17:37 by matsuda")
    (PROG ((DD (ffetch (STREAM IMAGEDATA) of STREAM)))
                                                             (* \CHECKCARET STREAM)
          (\MAYBE-DRIBBLE-CHAR STREAM CHARCODE)              (* ; "if dribbling, dribble.")
          (SELECTC (ffetch (TERMCODE CCECHO) of (\SYNCODE \PRIMTERMSA CHARCODE))
              (REAL.CCE 
                        (* ;; "All fat characters are defined as REAL according to \SYNCODE, so we don't have worry about any of the special cases")

                        [COND
                           ((IGREATERP CHARCODE (CONSTANT (IMAX (CHARCODE EOL)
                                                                (CHARCODE CR)
                                                                (CHARCODE LF)
                                                                ERASECHARCODE)))
                                                             (* ; 
                                    "This is for sure a printing character; take the fast way out.")
                            (\XBLTCHAR CHARCODE STREAM DD)
                            (add (ffetch (STREAM CHARPOSITION) of STREAM)
                                   1))
                           (T                                (* ; "Take the slow check.")
                              (SELECTC CHARCODE
                                  ((CHARCODE (EOL CR LF)) 
                                       (\XDSPPRINTCR/LF CHARCODE STREAM)
                                       (freplace (STREAM CHARPOSITION) of STREAM with
                                                                                         0))
                                  (ERASECHARCODE (DSPBACKUP (CHARWIDTH (CHARCODE A)
                                                                   STREAM)
                                                        STREAM)
                                                             (* ; 
                       "line buffering routines have already taken care of backing up the position")
                                                 0)
                                  (PROGN (\XBLTCHAR CHARCODE STREAM DD)
                                         (add (ffetch (STREAM CHARPOSITION) of STREAM)
                                                1])
              (INDICATE.CCE                                  (* ; 
     "Make sure that all the chars in the indicate-string fit on the line or wrap-around together.")
                            (PROG (STR)
                                  (SETQ STR (\INDICATESTRING CHARCODE))
                                                             (* ; "This isn't right for rotated fonts.  But then there should probably be a separate rotated outcharfn")
                                  [COND
                                     ((IGREATERP (\STRINGWIDTH.DISPLAY STREAM STR)
                                             (IDIFFERENCE (ffetch (\DISPLAYDATA DDRightMargin)
                                                             of DD)
                                                    (ffetch (\DISPLAYDATA DDXPOSITION)
                                                       of DD)))
                                      (\XDSPPRINTCR/LF (CHARCODE EOL)
                                             STREAM)
                                      (freplace (STREAM CHARPOSITION) of STREAM
                                         with (NCHARS STR)))
                                     (T (add (ffetch (STREAM CHARPOSITION) of STREAM)
                                               (NCHARS STR]
                                  (for I from 1 do (\XBLTCHAR (OR (NTHCHARCODE STR I)
                                                                                  (RETURN))
                                                                      STREAM DD))))
              (SIMULATE.CCE (SELCHARQ CHARCODE
                                 ((EOL CR LF) 
                                      (\XDSPPRINTCR/LF CHARCODE STREAM)
                                      (freplace (STREAM CHARPOSITION) of STREAM with
                                                                                        0))
                                 (ESCAPE (\XBLTCHAR (CHARCODE $)
                                                STREAM DD)
                                         (add (ffetch (STREAM CHARPOSITION) of STREAM)
                                                1))
                                 (BELL                       (* ; 
                     "make switching of bits uninterruptable but allow interrupts between flashes.")
                                       (SELECTC \MACHINETYPE
                                           ((LIST \DANDELION \DAYBREAK \MAIKO) 
                                                [PLAYTUNE '((880 . 2500])
                                           (FLASHWINDOW (WFROMDS STREAM))))
                                 (TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE)
                                                                         STREAM)))
                                            (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
                                            (COND
                                               ((IGREATERP
                                                 (\DISPLAYSTREAMINCRXPOSITION
                                                  (SETQ TABWIDTH
                                                   (IDIFFERENCE TABWIDTH
                                                          (MOD (IDIFFERENCE (ffetch (\DISPLAYDATA
                                                                                         DDXPOSITION)
                                                                               of DD)
                                                                      (ffetch (\DISPLAYDATA
                                                                                   DDLeftMargin)
                                                                         of DD))
                                                               TABWIDTH)))
                                                  DD)
                                                 (ffetch (\DISPLAYDATA DDRightMargin)
                                                    of DD))
                                                             (* ; 
                                                           "tab was past rightmargin, force cr.")
                                                (\XDSPPRINTCR/LF (CHARCODE EOL)
                                                       STREAM)))
                                                             (* ; 
                                                           "return the number of spaces taken.")
                                            (add (ffetch (STREAM CHARPOSITION) of STREAM)
                                                   (IQUOTIENT TABWIDTH SPACEWIDTH))))
                                 (PROGN                      (* ; 
                                                           "this case was copied from \DSCCOUT.")
                                        (\XBLTCHAR CHARCODE STREAM DD)
                                        (add (ffetch (STREAM CHARPOSITION) of STREAM)
                                               1))))
              (IGNORE.CCE)
              (SHOULDNT])

(\XBLTCHAR
  [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA)
    (DECLARE (LOCALVARS . T))                        (* ; "Edited  1-Oct-91 13:38 by jn")
    (PROG (LOCAL1 RIGHT LEFT CURX CURY CHAR8CODE DESTINATION)
          (SETQ CHAR8CODE (\CHAR8CODE CHARCODE))
      CRLP
          [COND
             ((NOT (EQ (ffetch (\DISPLAYDATA DDCHARSET) of DISPLAYDATA)
                       (\CHARSET CHARCODE)))
              (\CHANGECHARSET.XDISPLAY DISPLAYDATA (\CHARSET CHARCODE]
          (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA))
          (SETQ RIGHT (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DISPLAYDATA)))
          [COND
             ((IGREATERP RIGHT (ffetch (\DISPLAYDATA DDRightMargin) of DISPLAYDATA))
                                                             (* ; 
                                                           "would go past right margin, force a cr")
              (COND
                 ((IGREATERP CURX (ffetch (\DISPLAYDATA DDLeftMargin) of DISPLAYDATA))
                                                             (* ; 
       "don't bother CR if position is at left margin anyway.  This also serves to break the loop.")
                  (\XDSPPRINTCR/LF (CHARCODE EOL)
                         DISPLAYSTREAM)                      (* ; 
                       "reuse the code in the test of this conditional rather than repeat it here.")
                  (GO CRLP]                                  (* ; 
                                                           "update the display stream x position.")
          (freplace (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA with (IPLUS CURX
                                                                                      (
                                                                                     \DSPGETCHARWIDTH
                                                                                       CHAR8CODE 
                                                                                       DISPLAYDATA)))
                                                             (* ; 
                                      "transforms an x coordinate into the destination coordinate.")
          (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDXOFFSET) of DISPLAYDATA))
          (SETQ CURX (IPLUS CURX LOCAL1))
          (SETQ CURY (IPLUS (ffetch (\DISPLAYDATA DDYPOSITION) of DISPLAYDATA)
                            (ffetch (\DISPLAYDATA DDXOFFSET) of DISPLAYDATA)))
          (XLIB:DRAW-IMAGE-GLYPH (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination)
                                                      of DISPLAYDATA))
                 (fetch (\DISPLAYDATA DDPILOTBBT) of DISPLAYDATA)
                 CURX
                 (IDIFFERENCE (\GETWINDOWHEIGHT          (* ; 
      "No roundtrip needed BUT: we have to remember to keep the height in sync with reality. /jarl")
                                     (WFROMDS DISPLAYSTREAM))
                        CURY)
                 CHAR8CODE)
          (RETURN T])

(\XDSPPRINTCR/LF
  [LAMBDA (CHARCODE DISPLAY-STREAM)                    (* ; "Edited 28-Feb-91 12:05 by matsuda")
    (COND
       ((EQ DISPLAY-STREAM (TTYDISPLAYSTREAM))
        (\STOPSCROLL?)                                       (* ; 
                                                        "\STOPSCROLL may have turned on the caret.")
                                                             (* \CHECKCARET DISPLAY-STREAM)
        ))
    (PROG (BTM AMOUNT/BELOW Y ROTATION FONT (DD (fetch (STREAM IMAGEDATA) of DISPLAY-STREAM))
               )
          (COND
             ((EQ CHARCODE (CHARCODE EOL))                   (* ; "on LF, no change in X")
              (COND
                 ((SETQ Y (fetch (\DISPLAYDATA DDEOLFN) of DD))
                                                             (* ; "call the eol function for ds.")
                  (APPLY* Y DISPLAY-STREAM)))
              (DSPXPOSITION (ffetch (\DISPLAYDATA DDLeftMargin) of DD)
                     DISPLAY-STREAM)))
          (SETQ Y (IPLUS (ffetch (\DISPLAYDATA DDYPOSITION) of DD)
                         (ffetch (\DISPLAYDATA DDLINEFEED) of DD)))
          [COND
             ((AND (fetch (\DISPLAYDATA DDScroll) of DD)
                   (IGREATERP (SETQ AMOUNT/BELOW (IDIFFERENCE (IPLUS (SETQ BTM (fetch
                                                                                (\DISPLAYDATA 
                                                                                     DDClippingBottom
                                                                                       ) of
                                                                                         DD))
                                                                     (fetch (FONTDESCRIPTOR
                                                                                 \SFDescent)
                                                                        of (fetch
                                                                                (\DISPLAYDATA DDFONT)
                                                                                  of DD)))
                                                        (\DSPTRANSFORMY Y DD)))
                          0))

              (* ;; "automatically scroll up enough to make the entire next character visible.  Descent check is so that the bottoms of characters will be printed also.")

              [PROG (LFT WDTH BKGRND DBITMAP HGHT H)
                    (SETQ LFT (fetch (\DISPLAYDATA DDClippingLeft) of DD))
                    (SETQ DBITMAP (fetch (\DISPLAYDATA DDDestination) of DD))
                    (SETQ HGHT (IDIFFERENCE (ffetch (\DISPLAYDATA DDClippingTop) of DD)
                                      BTM))
                    (SETQ WDTH (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of DD)
                                      LFT))
                    (SETQ BKGRND (ffetch (\DISPLAYDATA DDTexture) of DD))
                    (COND
                       ((IGREATERP AMOUNT/BELOW HGHT)        (* ; 
                                       "scrolling more than the window size, use different method.")
                                                             (* ; 
                                                           "clear the window with background.")
                        (BLTSHADE BKGRND DISPLAY-STREAM LFT BTM WDTH HGHT 'REPLACE))
                       (T (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*)
                                 CL:BOOLE-1)
                          (XLIB:COPY-AREA DBITMAP XLIB::*GC* LFT [IDIFFERENCE (SETQ H (
                                                                                 XLIB:DRAWABLE-HEIGHT
                                                                                       DBITMAP))
                                                                        (IPLUS BTM (SETQ HGHT
                                                                                    (IDIFFERENCE
                                                                                     HGHT 
                                                                                     AMOUNT/BELOW]
                                 WDTH HGHT DBITMAP LFT (IDIFFERENCE H (IPLUS (IPLUS BTM AMOUNT/BELOW)
                                                                             HGHT)))
                          (BLTSHADE BKGRND DISPLAY-STREAM LFT BTM WDTH AMOUNT/BELOW 'REPLACE]
              (SETQ Y (IPLUS Y AMOUNT/BELOW]
          (DSPYPOSITION Y DISPLAY-STREAM])
)
(DEFINEQ

(OPENWINDOWS
  [LAMBDA (SCREEN)                                     (* ; "Edited 15-Feb-91 16:24 by matsuda")

    (* ;; "returns a list of all open windows")

    (PROG (WINDOW WINDOWS)
          (COND
             ((EQ SCREEN T)                                  (* ; "Return all open windows.")
              (SETQ WINDOWS (for SCREEN in \SCREENS join (OPENWINDOWS SCREEN)))
              (RETURN WINDOWS)))
          (SETQ SCREEN (\INSURESCREEN SCREEN))
          [SETQ WINDOW (COND
                          ((type? SCREEN SCREEN)
                           (fetch (SCREEN SCTOPW) of SCREEN))
                          ((type? XSCREEN SCREEN)
                           (fetch (XSCREEN SCTOPW) of SCREEN]
          (while WINDOW do (SETQ WINDOWS (CONS WINDOW WINDOWS))
                                  (SETQ WINDOW (fetch (WINDOW NEXTW) of WINDOW)))
          (SETQ WINDOWS (DREVERSE WINDOWS))
          (RETURN WINDOWS])

(\INSURESCREEN
  [LAMBDA (SCREEN)                                     (* ; "Edited 15-Feb-91 16:22 by matsuda")
    (COND
       ((type? SCREEN SCREEN)
        SCREEN)
       ((type? XSCREEN SCREEN)
        SCREEN)
       ((NULL SCREEN)
        \CURSORSCREEN)
       (T (\ILLEGAL.ARG SCREEN])

(DSPSOURCETYPE
  [LAMBDA (SOURCETYPE DISPLAYSTREAM)                   (* ; "Edited 15-Feb-91 13:02 by matsuda")

    (* ;; "sets the operation field of a display stream")

    (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))
           PBT)
          (RETURN (PROG1 (fetch DDSOURCETYPE of DD)
                      [COND
                         (SOURCETYPE (OR (FMEMB SOURCETYPE '(INPUT INVERT))
                                         (LISPERROR "ILLEGAL ARG" SOURCETYPE))
                                (UNINTERRUPTABLY
                                    (freplace DDSOURCETYPE of DD with SOURCETYPE)
                                                             (* ; 
                                                    "update other fields that depend on operation.")
                                    [COND
                                       ((type? PILOTBBT (SETQ PBT (fetch DDPILOTBBT
                                                                         of DD)))
                                        (\SETPBTFUNCTION PBT SOURCETYPE (fetch DDOPERATION
                                                                           of DD)))
                                       ((XLIB:GCONTEXT-P PBT)
                                        (\SETGCFUNCTION PBT SOURCETYPE (fetch DDOPERATION
                                                                              of DD])])])

(PUTWINDOWPROP
  [LAMBDA (WINDOW PROP VALUE)                          (* ; "Edited 27-Feb-91 16:46 by matsuda")
    [OR (type? WINDOW WINDOW)
        (COND
           ((DISPLAYSTREAMP (\OUTSTREAMARG WINDOW))
            (SETQ WINDOW (WFROMDS WINDOW)))
           (T (\ILLEGAL.ARG WINDOW]
    (SELECTQ PROP
        (RIGHTBUTTONFN (PROG1 (fetch (WINDOW RIGHTBUTTONFN) of WINDOW)
                           (replace (WINDOW RIGHTBUTTONFN) of WINDOW with VALUE)))
        (BUTTONEVENTFN (PROG1 (fetch (WINDOW BUTTONEVENTFN) of WINDOW)
                           (replace (WINDOW BUTTONEVENTFN) of WINDOW with VALUE)))
        (CLOSEFN (PROG1 (fetch (WINDOW CLOSEFN) of WINDOW)
                     (replace (WINDOW CLOSEFN) of WINDOW with VALUE)))
        (MOVEFN (PROG1 (fetch (WINDOW MOVEFN) of WINDOW)
                    (replace (WINDOW MOVEFN) of WINDOW with VALUE)))
        (CURSORINFN (PROG1 (fetch (WINDOW CURSORINFN) of WINDOW)
                        (replace (WINDOW CURSORINFN) of WINDOW with VALUE)))
        (CURSOROUTFN (PROG1 (fetch (WINDOW CURSOROUTFN) of WINDOW)
                         (replace (WINDOW CURSOROUTFN) of WINDOW with VALUE)))
        (CURSORMOVEDFN (PROG1 (fetch (WINDOW CURSORMOVEDFN) of WINDOW)
                           (replace (WINDOW CURSORMOVEDFN) of WINDOW with VALUE)))
        (DSP (ERROR "Can't change DSP of a window" WINDOW))
        (SCREEN (ERROR "Can't change SCREEN  of a window" WINDOW))
        (RESHAPEFN (PROG1 (fetch (WINDOW RESHAPEFN) of WINDOW)
                       (replace (WINDOW RESHAPEFN) of WINDOW with VALUE)))
        (REPAINTFN (PROG1 (fetch (WINDOW REPAINTFN) of WINDOW)
                       (replace (WINDOW REPAINTFN) of WINDOW with VALUE)))
        (EXTENT (PROG1 (fetch (WINDOW EXTENT) of WINDOW)
                    (OR (NULL VALUE)
                        (REGIONP VALUE)
                        (\ILLEGAL.ARG VALUE))
                    (replace (WINDOW EXTENT) of WINDOW with VALUE)))
        (SCROLLFN (PROG1 (fetch (WINDOW SCROLLFN) of WINDOW)
                      (replace (WINDOW SCROLLFN) of WINDOW with VALUE)
                      (UPDATE/SCROLL/REG WINDOW)))
        (IMAGECOVERED (ERROR "Not implemented to change IMAGECOVERED property." WINDOW))
        (HEIGHT (ERROR "Not implemented to change HEIGHT as property." WINDOW))
        (WIDTH (ERROR "Not implemented to change WIDTH as property." WINDOW))
        (REGION [PROG (CURREGION)
                      (SETQ CURREGION (WINDOWPROP WINDOW 'REGION))
                      (COND
                         ((NOT (REGIONP VALUE))
                          (\ILLEGAL.ARG VALUE)))

                 (* ;; "there is no check for where the new region is nor how big it is;  this is left to MOVEW and RESHAPEW.")

                      (COND
                         ((AND (EQ (fetch (REGION WIDTH) of CURREGION)
                                   (fetch (REGION WIDTH) of VALUE))
                               (EQ (fetch (REGION HEIGHT) of CURREGION)
                                   (fetch (REGION HEIGHT) of VALUE)))
                                                             (* ; 
                                                   "width and height are the same, move the window")
                          (MOVEW WINDOW (fetch (REGION LEFT) of VALUE)
                                 (fetch (REGION BOTTOM) of VALUE)))
                         (T                                  (* ; "dimensions changed, reshape it.")
                            (SHAPEW WINDOW VALUE])
        (NEWREGIONFN (PROG1 (fetch (WINDOW NEWREGIONFN) of WINDOW)
                         (replace (WINDOW NEWREGIONFN) of WINDOW with VALUE)))
        (TITLE (PROG1 (fetch (WINDOW WTITLE) of WINDOW)
                   (COND
                      ((type? SCREEN (fetch (WINDOW SCREEN) of WINDOW))
                       (RESHOWTITLE VALUE WINDOW))
                      ((type? XSCREEN (fetch (WINDOW SCREEN) of WINDOW))
                       (replace (WINDOW WTITLE) of WINDOW with VALUE)
                       (XSHOWWTITLE VALUE NIL (fetch (WINDOW WBORDER) of WINDOW)
                              NIL WINDOW)))))
        (BORDER (PROG1 (fetch (WINDOW WBORDER) of WINDOW)
                    (COND
                       ((NUMBERP VALUE)
                        (RESHOWBORDER VALUE WINDOW))
                       (T (\ILLEGAL.ARG VALUE)))))
        (PROCESS (PROG1 (fetch (WINDOW PROCESS) of WINDOW)
                     (replace (WINDOW PROCESS) of WINDOW with VALUE)))
        (WINDOWENTRYFN (PROG1 (fetch (WINDOW WINDOWENTRYFN) of WINDOW)
                           (replace (WINDOW WINDOWENTRYFN) of WINDOW with VALUE)))
        (PROG (OLDDATA OLDVALUE)
              (SETQ OLDDATA (fetch (WINDOW USERDATA) of WINDOW))
              (RETURN (PROG1 (COND
                                (OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP))
                                       [COND
                                          (VALUE (LISTPUT OLDDATA PROP VALUE))
                                          (OLDVALUE          (* Remove the property)
                                                 (COND
                                                    ((EQ (CAR OLDDATA)
                                                         PROP)
                                                     (replace (WINDOW USERDATA) of WINDOW
                                                        with (CDDR OLDDATA)))
                                                    (T (for TAIL on (CDR OLDDATA)
                                                          by (CDDR TAIL)
                                                          when (EQ (CADR TAIL)
                                                                       PROP)
                                                          do (FRPLACD TAIL (CDDDR TAIL))
                                                                (RETURN]
                                       OLDVALUE)
                                (VALUE (replace (WINDOW USERDATA) of WINDOW
                                          with (LIST PROP VALUE))
                                                             (* know old value is NIL)
                                       NIL))
                          (COND
                             ((AND (fetch (WINDOW WTITLE) of WINDOW)
                                   (EQ PROP 'WINDOWTITLESHADE))
                                                             (* change windowtitleshade.)
                              (RESHOWTITLE (fetch (WINDOW WTITLE) of WINDOW)
                                     WINDOW T))))])

(RESHOWBORDER
  [LAMBDA (BORDER WINDOW)                              (* ; "Edited 27-Feb-91 17:15 by matsuda")

    (* ;; "updates a windows display with a new border")
                                                             (* ; 
                                                "if the border is the same, don't change anything.")
    (OR (EQ BORDER (fetch (WINDOW WBORDER) of WINDOW))
        (COND
           ((type? SCREEN (fetch (WINDOW SCREEN) of WINDOW))
            (\RESHOWBORDER1 BORDER (fetch (WINDOW WBORDER) of WINDOW)
                   WINDOW))
           ((type? XSCREEN (fetch (WINDOW SCREEN) of WINDOW))
            (\XRESHOWBORDER1 BORDER (fetch (WINDOW WBORDER) of WINDOW)
                   WINDOW])

(\XRESHOWBORDER1
  [LAMBDA (NEWBORDER OLDBORDER WINDOW)                 (* ; "Edited 27-Feb-91 17:45 by matsuda")
    (PROG ((REGION (fetch (WINDOW REG) of WINDOW))
           (OLDSAVE (fetch (WINDOW SAVE) of WINDOW))
           DELTA NUWIDTH NUHEIGHT XBASEW)
          (SETQ DELTA (IDIFFERENCE NEWBORDER OLDBORDER))
          (SETQ NUWIDTH (IPLUS (fetch (REGION WIDTH) of REGION)
                               (ITIMES DELTA 2)))
          [SETQ NUHEIGHT (IDIFFERENCE (IPLUS (fetch (REGION HEIGHT)
                                                of (DSPCLIPPINGREGION NIL (fetch (WINDOW
                                                                                          DSP)
                                                                                 of WINDOW)))
                                             (ITIMES NEWBORDER 2))
                                (COND
                                   [(fetch (WINDOW WTITLE) of WINDOW)
                                    (DSPLINEFEED NIL (fetch (XSCREEN SCTITLEDS)
                                                        of (fetch (WINDOW SCREEN)
                                                                  of WINDOW]
                                   (T 0]
          (replace (WINDOW WBORDER) of WINDOW with NEWBORDER)
          (CL:SETF (XLIB:DRAWABLE-BORDER-WIDTH OLDSAVE)
                 (IMAX (FOLDHI NEWBORDER 2)
                       (IDIFFERENCE NEWBORDER 2)))
          (replace (WINDOW REG) of WINDOW with (create REGION
                                                                  LEFT _ (IDIFFERENCE
                                                                          (fetch (REGION LEFT)
                                                                             of REGION)
                                                                          DELTA)
                                                                  BOTTOM _ (IDIFFERENCE
                                                                            (fetch (REGION BOTTOM
                                                                                              )
                                                                               of REGION)
                                                                            DELTA)
                                                                  WIDTH _ NUWIDTH
                                                                  HEIGHT _ NUHEIGHT))
          (SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW))
          (if (SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW))
              then (CL:SETF (XLIB:DRAWABLE-WIDTH XBASEW)
                              NUWIDTH)
                    (CL:SETF (XLIB:DRAWABLE-HEIGHT XBASEW)
                           NUHEIGHT))
          (UPDATE/SCROLL/REG WINDOW)
          (XSHOWWFRAME WINDOW])

(\GETWINDOWHEIGHT
  [LAMBDA (WINDOW)                                     (* ; "Edited 27-Feb-91 16:24 by matsuda")

    (* ;; "calculate the height from the REGION in case user has changed the clipping region.  This won't work if the height of the title display stream has changed.")

    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (DIFFERENCE (fetch (REGION HEIGHT) of (fetch (WINDOW REG) of WINDOW))
           (DIFFERENCE (ITIMES 2 (fetch (WINDOW WBORDER) of WINDOW))
                  (COND
                     [(fetch (WINDOW WTITLE) of WINDOW)
                      (DSPLINEFEED NIL (COND
                                          ((type? SCREEN (fetch (WINDOW SCREEN) of WINDOW
                                                                    ))
                                           (fetch (SCREEN SCTITLEDS) of (fetch
                                                                                 (WINDOW SCREEN)
                                                                                   of WINDOW)))
                                          ((TYPE? XSCREEN (fetch (WINDOW SCREEN) of
                                                                                         WINDOW))
                                           (fetch (XSCREEN SCTITLEDS) of (fetch
                                                                                  (WINDOW SCREEN)
                                                                                    of WINDOW]
                     (T 0])
)
(DEFINEQ

(XWHICHW
  [LAMBDA NIL                                          (* ; "Edited 10-Apr-91 14:11 by matsuda")
    XLASTWINDOW])
)
(DEFINEQ

(TOTOPW
  [LAMBDA (WINDOW NOCALLTOTOPFNFLG)                      (* ; "Edited  2-Oct-91 15:13 by jn")

    (* ;; "user entry to bring a window to the top.  Unless NOCALLTOTOPFNFLG is non-NIL, it will call the windows TOTOPFN")

    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (COND
       [(type? XSCREEN (fetch (WINDOW SCREEN) of WINDOW))
        (XLIB:CIRCULATE-WINDOW-UP (WINDOWPROP WINDOW 'XBASEW]
       ((EQ WINDOW (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WINDOW)))
        (PROGN                                               (* (SETQ \TOPWDS (fetch
                                                           (WINDOW DSP) of WINDOW)))
               NIL))
       ((OPENWP WINDOW)
        (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN)
                                    WINDOW))
        (\INTERNALTOTOPW WINDOW))
       ((OPENW WINDOW)                                       (* ; 
                                             "if it is not open, open it and then call the TOTOPFN")
        (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN)
                                    WINDOW)))
       (T                                                    (* ; 
                                               "window won't open probably because of DON'T OPENFN")
          (ERROR "Window won't open; Can't be brought to top." WINDOW)))
    WINDOW])
)
(DEFINEQ

(XSHAPEW1
  [LAMBDA (WINDOW REGION)
    (DECLARE (LOCALVARS . T))                      (* ; "Edited 16-Feb-91 16:14 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (OR (REGIONP REGION)
        (\ILLEGAL.ARG REGION))
    (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW))
           (OLDCLIPREG (DSPCLIPPINGREGION NIL (fetch (WINDOW DSP) of WINDOW)))
           (WBORDER (fetch (WINDOW WBORDER) of WINDOW))
           SCREEN NUSAV NOWOPEN?)
          (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW))
          (UNINTERRUPTABLY
                                                             (* ; "Save window image")
              (replace (WINDOW REG) of WINDOW with REGION)
              (ADVISEXWDS WINDOW OLDREGION)
              (XSHOWWFRAME WINDOW))                      (* ; " (DOUSERFNS2 (OR (fetch (WINDOW RESHAPEFN) of WINDOW) (FUNCTION RESHAPEBYREPAINTFN)) WINDOW NUSAV (create REGION LEFT _ WBORDER BOTTOM _ WBORDER WIDTH _ (fetch (REGION WIDTH) of OLDCLIPREG) HEIGHT _ (fetch (REGION HEIGHT) of OLDCLIPREG)) OLDREGION)")
          (RETURN WINDOW])

(XMOVEW
  [LAMBDA (WINDOW POSorX Y)                            (* ; "Edited  7-Mar-91 14:24 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW))
           (USERMOVEFN (fetch (WINDOW MOVEFN) of WINDOW))
           POS NEWREGION OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT XBASEW)
          (COND
             ([COND
                 ((LISTP USERMOVEFN)
                  (FMEMB 'DON'T USERMOVEFN))
                 (T (EQ USERMOVEFN 'DON'T]
              (PROMPTPRINT "This window cannot be moved.")
              (RETURN)))
          (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION))
          (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION))
          (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION))
          (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION))
          (COND
             [(AND POSorX (SETQ POS (COND
                                       ((POSITIONP POSorX)
                                        POSorX)
                                       [(NUMBERP POSorX)
                                        (COND
                                           ((NUMBERP Y)
                                            (create POSITION
                                                   XCOORD _ POSorX
                                                   YCOORD _ Y))
                                           (T (\ILLEGAL.ARG Y]
                                       ((REGIONP POSorX)
                                        (create POSITION
                                               XCOORD _ (fetch (REGION LEFT) of POSorX)
                                               YCOORD _ (fetch (REGION BOTTOM) of POSorX)))
                                       (T (\ILLEGAL.ARG POSorX]
             (T (\ILLEGAL.ARG POSorX)))
          [COND
             ((AND (LISTP USERMOVEFN)
                   (NOT (FMEMB (CAR USERMOVEFN)
                               LAMBDASPLST)))
              (AND (EQ [for MFN in USERMOVEFN do (SETQ NEWREGION (APPLY* MFN WINDOW POS))
                                                            (COND
                                                               ((EQ NEWREGION 'DON'T)
                                                                (RETURN 'DON'T))
                                                               ((POSITIONP NEWREGION)
                                                                (SETQ POS NEWREGION]
                       'DON'T)
                   (RETURN)))
             (USERMOVEFN (SETQ NEWREGION (APPLY* USERMOVEFN WINDOW POS))
                    (COND
                       ((EQ NEWREGION 'DON'T)
                        (RETURN))
                       ((POSITIONP NEWREGION)
                        (SETQ POS NEWREGION]
          (COND
             ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS)
                           OLDLEFT))
                  (NOT (EQ (fetch (POSITION YCOORD) of POS)
                           OLDBOTTOM)))
              (SETQ NEWREGION (create REGION
                                     LEFT _ (ffetch (POSITION XCOORD) of POS)
                                     BOTTOM _ (ffetch (POSITION YCOORD) of POS)
                                     WIDTH _ OLDWIDTH
                                     HEIGHT _ OLDHEIGHT))
              (UNINTERRUPTABLY
                  [COND
                     ((SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW))
                      (XLIB:WITH-STATE (XBASEW)
                             (CL:SETF (XLIB:DRAWABLE-Y XBASEW)
                                    (IDIFFERENCE (fetch (XSCREEN SCHEIGHT) of \XSCREEN)
                                           (fetch (REGION TOP) of NEWREGION)))
                             (CL:SETF (XLIB:DRAWABLE-X XBASEW)
                                    (fetch (REGION LEFT) of NEWREGION]
                  (replace (WINDOW REG) of WINDOW with NEWREGION)
                  (ADVISEXWDS WINDOW OLDREGION T))
              (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN)
                     WINDOW)))
          (RETURN POS])

(XMOVEW1
  [LAMBDA (WINDOW POSorX Y)                            (* ; "Edited 16-Feb-91 18:04 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW))
           OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT POS NEWREGION REG)
          (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION))
          (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION))
          (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION))
          (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION))
          [AND POSorX (SETQ POS (COND
                                   ((POSITIONP POSorX)
                                    POSorX)
                                   [(NUMBERP POSorX)
                                    (COND
                                       ((NUMBERP Y)
                                        (create POSITION
                                               XCOORD _ POSorX
                                               YCOORD _ Y))
                                       (T (\ILLEGAL.ARG Y]
                                   ((REGIONP POSorX)
                                    (create POSITION
                                           XCOORD _ (fetch (REGION LEFT) of POSorX)
                                           YCOORD _ (fetch (REGION BOTTOM) of POSorX)))
                                   (T (\ILLEGAL.ARG POSorX]
          (COND
             ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS)
                           OLDLEFT))
                  (NOT (EQ (ffetch (POSITION YCOORD) of POS)
                           OLDBOTTOM)))
              (SETQ NEWREGION (create REGION
                                     LEFT _ (ffetch (POSITION XCOORD) of POS)
                                     BOTTOM _ (ffetch (POSITION YCOORD) of POS)
                                     WIDTH _ OLDWIDTH
                                     HEIGHT _ OLDHEIGHT))
              (UNINTERRUPTABLY
                  (replace (WINDOW REG) of WINDOW with NEWREGION)
                  (ADVISEXWDS WINDOW OLDREGION T))
              (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN)
                     WINDOW])

(XMOVEORRESIZED.WINDOW
  [LAMBDA (WINDOW X Y WIDTH HEIGHT)                    (* ; "Edited 11-Apr-91 09:37 by matsuda")
    (PROG ((NEXTW (fetch (XSCREEN SCTOPW) of \XSCREEN))
           XBASEW OLDREG NEWREG)
      LOOP
          (COND
             (NEXTW (SETQ XBASEW (WINDOWPROP NEXTW 'XBASEW))
                    (COND
                       [(EQ WINDOW XBASEW)
                        (SETQ OLDREG (fetch (WINDOW REG)
                                            NEXTW))
                        (SETQ NEWREG (create REGION
                                            LEFT _ X
                                            BOTTOM _ (IDIFFERENCE (fetch (XSCREEN SCHEIGHT)
                                                                     of \XSCREEN)
                                                            (IPLUS Y HEIGHT))
                                            WIDTH _ WIDTH
                                            HEIGHT _ HEIGHT))
                        (COND
                           ((AND (EQ (fetch (REGION WIDTH) of OLDREG)
                                     WIDTH)
                                 (EQ (fetch (REGION HEIGHT) of OLDREG)
                                     HEIGHT))
                            (XMOVEW1 NEXTW (fetch (REGION LEFT) of NEWREG)
                                   (fetch (REGION BOTTOM) of NEWREG)))
                           (T (XSHAPEW1 NEXTW NEWREG]
                       (T (SETQ NEXTW (fetch (WINDOW NEXTW) of NEXTW))
                          (GO LOOP])

(XMOVED.WINDOW
  [LAMBDA (WINDOW)                                     (* ; "Edited  1-Feb-91 16:48 by matsuda")
    NIL])
)

(RPAQ? \XSCREEN NIL)

(ADDTOVAR \DISPLAYSTREAMTYPES XDISPLAY)

(ADDTOVAR IMAGESTREAMTYPES (XDISPLAY (OPENSTREAM NILL)
                                      (FONTCREATE \CREATEXDISPLAYFONT)
                                      (FONTSAVAILABLE NILL)
                                      (CREATECHARSET NILL)))

(FILESLOAD XLLKEY XLLBITMAP XLLCURSOR XLLMOUSE XLLFONT XSERVER XWATCHER)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA XLIB::SETUP-CLX)
)
(PUTPROPS XMAS COPYRIGHT ("Venue" 1991))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (11150 12401 (XLIB::SETUP-CLX 11160 . 12399)) (12402 80675 (\XDISPLAYINIT 12412 . 17445)
 (CREATEXSCREEN 17447 . 19460) (BITSPERPIXEL 19462 . 20487) (BITMAPHEIGHT 20489 . 20949) (BITMAPWIDTH 
20951 . 21406) (DSPDESTINATION 21408 . 25038) (XDSPCREATE 25040 . 26540) (\DSPOPERATION.XDISPLAY 26542
 . 27406) (\DSPRESET.XDISPLAY 27408 . 29848) (\BLTSHADE.XDISPLAY 29850 . 35267) (\BITBLT.XDISPLAY 
35269 . 40602) (\XBITBLTSUB 40604 . 42083) (\XBLTSHADE.PIXMAP 42085 . 45581) (\XBITBLT.PIXMAP 45583 . 
49709) (\DRAWPOINT.XDISPLAY 49711 . 50368) (\DRAWLINE.XDISPLAY 50370 . 53414) (\XLINEWITHBRUSH 53416
 . 61792) (\DRAWCIRCLE.XDISPLAY 61794 . 66819) (\DRAWCURVE.XDISPLAY 66821 . 68378) (\XCURVE2 68380 . 
75910) (\XCURVE 75912 . 80673)) (80676 91382 (BITBLT 80686 . 91380)) (91383 93367 (XCREATEWFROMPIXMAP 
91393 . 92408) (PIXMAPCREATE 92410 . 92748) (PIXMAPWIDTH 92750 . 93055) (PIXMAPHEIGHT 93057 . 93365)) 
(93368 117849 (XCREATEW 93378 . 95995) (ADVISEXWDS 95997 . 102452) (XOPENW 102454 . 103586) (\XOPENW1 
103588 . 105484) (XCLOSEW 105486 . 105815) (\XCLOSEW1 105817 . 107434) (\XSFFixClippingRegion 107436
 . 109725) (XSHOWWFRAME 109727 . 112983) (XSHOWWTITLE 112985 . 115389) (\XCREATEBASEW 115391 . 117085)
 (\DSPCLIPPINGREGION.XDISPLAY 117087 . 117847)) (117850 133562 (\XDSPPRINTCHAR 117860 . 125664) (
\XBLTCHAR 125666 . 128836) (\XDSPPRINTCR/LF 128838 . 133560)) (133563 148886 (OPENWINDOWS 133573 . 
134579) (\INSURESCREEN 134581 . 134893) (DSPSOURCETYPE 134895 . 136365) (PUTWINDOWPROP 136367 . 143483
) (RESHOWBORDER 143485 . 144286) (\XRESHOWBORDER1 144288 . 147269) (\GETWINDOWHEIGHT 147271 . 148884))
 (148887 149034 (XWHICHW 148897 . 149032)) (149035 150494 (TOTOPW 149045 . 150492)) (150495 159902 (
XSHAPEW1 150505 . 151645) (XMOVEW 151647 . 155883) (XMOVEW1 155885 . 158159) (XMOVEORRESIZED.WINDOW 
158161 . 159765) (XMOVED.WINDOW 159767 . 159900)))))
STOP
\ No newline at end of file
diff --git a/obsolete/sources/XMAS2 b/obsolete/sources/XMAS2
deleted file mode 100644
index 42ada05c..00000000
--- a/obsolete/sources/XMAS2
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Oct-91 17:03:36" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>XMAS2.;1| 62023  

      changes to%:  (FNS XSHOWWFRAME)

      previous date%: "22-Oct-91 16:41:50" {DSK}<users>nilsson>xmas-split>xmas2.;5)


(* ; "
Copyright (c) 1991 by Fuji Xerox Co., Ltd.  All rights reserved.
")

(PRETTYCOMPRINT XMAS2COMS)

(RPAQQ XMAS2COMS
       ((RECORDS WINDOWOPS)
        (FNS CREATESCREEN DSPCREATE CREATEW.NEW OPENW.NEW CLOSEW.NEW MOVEW.NEW SHAPEW.NEW SHRINKW.NEW
             EXPANDW.NEW)
        (FNS CREATEW.XDISPLAY OPENW.XDISPLAY CLOSEW.XDISPLAY MOVEW.XDISPLAY SHAPEW.XDISPLAY 
             SHRINKW.XDISPLAY EXPANDW.XDISPLAY TOTOPW.XDISPLAY BURYW.XDISPLAY)
        (FNS \XOPENW1 XSHOWWFRAME ADVISEXWDS XMOVEORRESIZED.WINDOW \XMOUSELEFT \XMOUSEMOVED 
             \FINDWINDOW \XMOUSEENTERED XMOVEW \XCLOSEW1 XSHAPEW \XSHAPEW1 XCREATEWFROMPIXMAP 
             XCLOSEMAINWINDOW \XINTERNALTOTOPW)
        (FNS ISXWINDOW?)
        (FNS INIT.XMAS2)
        (VARS XMAS2COMS)))
(DECLARE%: EVAL@COMPILE

(DATATYPE WINDOWOPS (CREATEW OPENW CLOSEW MOVEW SHAPEW SHRINKW EXPANDW)
                        CREATEW _ (FUNCTION NILL)
                        OPENW _ (FUNCTION NILL)
                        CLOSEW _ (FUNCTION NILL)
                        MOVEW _ (FUNCTION NILL)
                        SHAPEW _ (FUNCTION NILL)
                        SHRINKW _ (FUNCTION NILL)
                        EXPANDW _ (FUNCTION NILL))
)

(/DECLAREDATATYPE 'WINDOWOPS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER)
       '((WINDOWOPS 0 POINTER)
         (WINDOWOPS 2 POINTER)
         (WINDOWOPS 4 POINTER)
         (WINDOWOPS 6 POINTER)
         (WINDOWOPS 8 POINTER)
         (WINDOWOPS 10 POINTER)
         (WINDOWOPS 12 POINTER))
       '14)
(DEFINEQ

(CREATESCREEN
  [LAMBDA (DESTINATION)                                (* ; "Edited  5-Sep-91 15:20 by matsuda")

(* ;;; "destination is the framebuffer for the screen you want created.e.g.  (SCREENBITMAP)")

    (PROG (TITLEDS SCREEN)
          (COND
             ((OR (NULL DESTINATION)
                  (TYPE? BITMAP DESTINATION))
              (SETQ TITLEDS (DSPCREATE DESTINATION))     (* ; "Create TITLEDS. ")
              (DSPOPERATION 'INVERT TITLEDS)
              (DSPFONT WINDOWTITLEFONT TITLEDS)
              (DSPRIGHTMARGIN MAX.SMALLP TITLEDS)            (* ; 
                                                       "Set right margin so title doesn't autoCR. ")

              (* ;; "now create SCREEN. ")

              (SETQ SCREEN (create SCREEN
                                  SCONOFF _ 'OFF
                                  SCDESTINATION _ DESTINATION
                                  SCWIDTH _ (BITMAPWIDTH DESTINATION)
                                  SCHEIGHT _ (BITMAPHEIGHT DESTINATION)
                                  SCTOPW _ NIL
                                  SCTITLEDS _ TITLEDS))
              (RETURN SCREEN))
             ((XLIB:DRAWABLE-P DESTINATION)
              (SETQ TITLEDS (XDSPCREATE DESTINATION))        (* ; "Create TITLEDS. ")
              (DSPOPERATION 'INVERT TITLEDS)
              (DSPFONT XWINDOWTITLEFONT TITLEDS)
              (DSPRIGHTMARGIN MAX.SMALLP TITLEDS)            (* ; 
                                                       "Set right margin so title doesn't autoCR. ")

              (* ;; "now create SCREEN. ")

              (SETQ SCREEN (create SCREEN
                                  SCONOFF _ 'OFF
                                  SCDESTINATION _ DESTINATION
                                  SCWIDTH _ (BITMAPWIDTH DESTINATION)
                                  SCHEIGHT _ (BITMAPHEIGHT DESTINATION)
                                  SCTOPW _ NIL
                                  SCTITLEDS _ TITLEDS))
              (RETURN SCREEN])

(DSPCREATE
  [LAMBDA (DESTINATION)                                (* ; "Edited  5-Sep-91 15:34 by matsuda")

    (* ;; "Creates a stream-of-type-display on the DESTINATION bitmap or display device")

    (LET (DSTRM)
         (OR DESTINATION (SETQ DESTINATION ScreenBitMap))    (* ; "")
                                                             (* ; 
                                     "(COND ((NULL DESTINATION)) (T (\DTEST DESTINATION 'BITMAP)))")
         (COND
            ((type? BITMAP DESTINATION)
             (SETQ DSTRM (create STREAM
                                USERCLOSEABLE _ NIL
                                OUTCHARFN _ (FUNCTION \DSPPRINTCHAR)
                                IMAGEDATA _ (create \DISPLAYDATA)
                                IMAGEOPS _ \DISPLAYIMAGEOPS
                                DEVICE _ DisplayFDEV
                                ACCESS _ 'OUTPUT))           (* ; 
                                        "initial x and y positions are 0 when the data is created.")
             (DSPFONT DEFAULTFONT DSTRM)                     (* ; 
                    "dspfont can win since the (default) display imageops are filled in the stream")
             (DSPDESTINATION DESTINATION DSTRM)              (* ; 
                         "dspdestination calls \SFFixFont, which presumes there is a font present.")
             (DSPFONT DEFAULTFONT DSTRM)

             (* ;; "the reference to SCREENWIDTH here is for historic reasons: until 3-feb-86 the default right margin was always SCREENWIDTH.  It should be the width of the destination and for any destination larger than the screen this is a serious bug and was fixed.  The MAX of the right value and SCREENWIDTH was left in because existing code might be assumine a large right margin for small bitmaps and auto-CR in without it.  rrb")

             (DSPRIGHTMARGIN (MAX SCREENWIDTH (fetch (BITMAP BITMAPWIDTH) of DESTINATION))
                    DSTRM)
             (DSPSOURCETYPE 'INPUT DSTRM)
             (DSPOPERATION 'REPLACE DSTRM)                   (* ; 
            "called to cause the updating of the bitblt table from the fields initialized earlier.")
             )
            ((XLIB:DRAWABLE-P DESTINATION)
             (SETQ DSTRM (create STREAM
                                USERCLOSEABLE _ NIL
                                OUTCHARFN _ (FUNCTION \XDSPPRINTCHAR)
                                IMAGEDATA _ (create \DISPLAYDATA)
                                IMAGEOPS _ \XDISPLAYIMAGEOPS
                                DEVICE _ XDisplayFDEV
                                ACCESS _ 'OUTPUT))
             (replace (\DISPLAYDATA DDPILOTBBT) of (fetch (STREAM IMAGEDATA) of
                                                                                         DSTRM)
                with (SETQ GC (XLIB:CREATE-GCONTEXT :DRAWABLE DESTINATION)))
             (CL:SETF (XLIB:GCONTEXT-FOREGROUND GC)
                    XLIB::*BLACK*)                           (* ; "temp foreground color ")
             (CL:SETF (XLIB:GCONTEXT-BACKGROUND GC)
                    XLIB::*WHITE*)                           (* ; "temp background color")
             (DSPFONT XDEFAULTFONT DSTRM)
             (DSPDESTINATION DESTINATION DSTRM)
             (DSPRIGHTMARGIN (MAX SCREENWIDTH (XLIB:DRAWABLE-WIDTH DESTINATION))
                    DSTRM)
             (DSPSOURCETYPE 'INPUT DSTRM)
             (DSPOPERATION 'REPLACE DSTRM)))
         DSTRM])

(CREATEW.NEW
  [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG)            (* ; "Edited 20-Oct-91 10:53 by jn")

    (* ;; "creates and returns a window.")

    (PROG (SCREEN)
          (COND
             ((AND (BOUNDP '\SCREEN)
                   \SCREEN)
              (SETQ SCREEN \SCREEN))
             ((type? SCREENREGION REGION)
              (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION)))
             (T (SETQ SCREEN \MAINSCREEN)                    (* ; "Default screen is \MAINSCREEN.")
                ))
          (RETURN (APPLY* (fetch (WINDOWOPS CREATEW) of (fetch (SCREEN SCDATA)
                                                                   of SCREEN))
                         REGION TITLE BORDERSIZE NOOPENFLG])

(OPENW.NEW
  [LAMBDA (WINDOW)                                     (* ; "Edited  9-Sep-91 18:05 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (APPLY* (fetch (WINDOWOPS OPENW) of (fetch (SCREEN SCDATA) of (fetch
                                                                                   (WINDOW SCREEN)
                                                                                     of WINDOW)))
           WINDOW])

(CLOSEW.NEW
  [LAMBDA (WINDOW)                                     (* ; "Edited  9-Sep-91 18:01 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (APPLY* (fetch (WINDOWOPS CLOSEW) of (fetch (SCREEN SCDATA)
                                                    of (fetch (WINDOW SCREEN) of WINDOW))
                   )
           WINDOW])

(MOVEW.NEW
  [LAMBDA (WINDOW POSorX Y)                            (* ; "Edited 10-Sep-91 15:55 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (APPLY* (fetch (WINDOWOPS MOVEW) of (fetch (SCREEN SCDATA) of (fetch
                                                                                   (WINDOW SCREEN)
                                                                                     of WINDOW)))
           WINDOW POSorX Y])

(SHAPEW.NEW
  [LAMBDA (WINDOW NEWREGION)                           (* ; "Edited 13-Sep-91 14:09 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (APPLY* (fetch (WINDOWOPS SHAPEW) of (fetch (SCREEN SCDATA)
                                                    of (fetch (WINDOW SCREEN) of WINDOW))
                   )
           WINDOW NEWREGION])

(SHRINKW.NEW
  [LAMBDA (WINDOW TOWHAT ICONPOSITION EXPANDFN)        (* ; "Edited 13-Sep-91 16:39 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (APPLY* (fetch (WINDOWOPS SHRINKW) of (fetch (SCREEN SCDATA)
                                                     of (fetch (WINDOW SCREEN) of WINDOW)
                                                         ))
           WINDOW TOWHAT ICONPOSITION EXPANDFN])

(EXPANDW.NEW
  [LAMBDA (ICONW)                                      (* ; "Edited 13-Sep-91 16:07 by matsuda")
    (SETQ ICONW (\INSUREWINDOW ICONW))
    (APPLY* (fetch (WINDOWOPS EXPANDW) of (fetch (SCREEN SCDATA)
                                                     of (fetch (WINDOW SCREEN) of ICONW))
                   )
           ICONW])
)
(DEFINEQ

(CREATEW.XDISPLAY
  [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG)          (* ; "Edited  9-Sep-91 17:03 by matsuda")

    (* ;; "creates and returns a window.")

    (PROG (SCREEN REG DSP DISPLAYDATA TITLEHEIGHT WINDOW WBORDER)
          (SETQ WBORDER (COND
                           ((NUMBERP BORDERSIZE)
                            (ABS BORDERSIZE))
                           ((NUMBERP WBorder)
                            (ABS WBorder))
                           (T 2)))
          (COND
             ((type? REGION REGION)
              (SETQ SCREEN \XSCREEN)                         (* ; 
                                                   "Protect against user smashing REGION later on.")
              (SETQ REG (COPY REGION)))
             [(type? SCREENREGION REGION)
              (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION))
              (SETQ REG (COPY (fetch (SCREENREGION REGION) of REGION]
             (T (ERROR "Not a region" REG)))
          [COND
             ((NULL DSP)                                     (* ; 
                                          "Don't have a DSP yet.  User passed some kind of region.")
              (SETQ DSP (DSPCREATE (fetch (SCREEN SCDESTINATION) of SCREEN)))
              (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DSP]
          (COND
             ((NOT (IGREATERP (IMIN (fetch (REGION WIDTH) of REG)
                                    (fetch (REGION HEIGHT) of REG))
                          (UNFOLD WBORDER 2)))
              (ERROR "Region too small to use as a window" REG)))
          (SETQ WINDOW
           (create WINDOW
                  DSP _ DSP
                  REG _ REG
                  SAVE _ NIL
                  WTITLE _ TITLE
                  WBORDER _ WBORDER
                  NEXTW _ 'CLOSED
                  SCREEN _ SCREEN
                  BUTTONEVENTFN _ NIL))
          (replace (\DISPLAYDATA XWINDOWHINT) of DISPLAYDATA with WINDOW)
          (XSHOWWFRAME WINDOW)
          (DSPDESTINATION (fetch (WINDOW SAVE) of WINDOW)
                 DSP)
          (ADVISEXWDS WINDOW)                            (* ; 
                                       "make the display stream and window agree about dimensions.")
          (MOVETOUPPERLEFT WINDOW)
          (COND
             ((NOT NOOPENFLG)
              (XOPENW WINDOW)))
          (RETURN WINDOW])

(OPENW.XDISPLAY
  [LAMBDA (WINDOW)                                     (* ; "Edited 10-Sep-91 15:59 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (COND
       ((OPENWP WINDOW)
        NIL)
       (T (PROG [(USEROPENFN (WINDOWPROP WINDOW 'OPENFN]
                (COND
                   ((\USERFNISDON'T USEROPENFN)
                    NIL)
                   (T (\XOPENW1 WINDOW)
                      (DOUSERFNS USEROPENFN WINDOW)
                      (RETURN WINDOW])

(CLOSEW.XDISPLAY
  [LAMBDA (WINDOW)                                     (* ; "Edited  9-Sep-91 17:44 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (COND
       ((OPENWP WINDOW)
        (COND
           ((\OKTOCLOSEW WINDOW)
            (AND (OPENWP WINDOW)
                 (\XCLOSEW1 WINDOW))
            T])

(MOVEW.XDISPLAY
  [LAMBDA (WINDOW POSorX Y)                            (* ; "Edited 10-Sep-91 16:04 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW))
           (USERMOVEFN (fetch (WINDOW MOVEFN) of WINDOW))
           POS NEWREGION OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT XBASEW)
          (COND
             ([COND
                 ((LISTP USERMOVEFN)
                  (FMEMB 'DON'T USERMOVEFN))
                 (T (EQ USERMOVEFN 'DON'T]
              (PROMPTPRINT "This window cannot be moved.")
              (RETURN)))
          (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION))
          (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION))
          (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION))
          (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION))
          (COND
             [(AND POSorX (SETQ POS (COND
                                       ((POSITIONP POSorX)
                                        POSorX)
                                       [(NUMBERP POSorX)
                                        (COND
                                           ((NUMBERP Y)
                                            (create POSITION
                                                   XCOORD _ POSorX
                                                   YCOORD _ Y))
                                           (T (\ILLEGAL.ARG Y]
                                       ((REGIONP POSorX)
                                        (create POSITION
                                               XCOORD _ (fetch (REGION LEFT) of POSorX)
                                               YCOORD _ (fetch (REGION BOTTOM) of POSorX)))
                                       (T (\ILLEGAL.ARG POSorX]
             (T (\ILLEGAL.ARG POSorX)))
          [COND
             ((AND (LISTP USERMOVEFN)
                   (NOT (FMEMB (CAR USERMOVEFN)
                               LAMBDASPLST)))
              (AND (EQ [for MFN in USERMOVEFN do (SETQ NEWREGION (APPLY* MFN WINDOW POS))
                                                            (COND
                                                               ((EQ NEWREGION 'DON'T)
                                                                (RETURN 'DON'T))
                                                               ((POSITIONP NEWREGION)
                                                                (SETQ POS NEWREGION]
                       'DON'T)
                   (RETURN)))
             (USERMOVEFN (SETQ NEWREGION (APPLY* USERMOVEFN WINDOW POS))
                    (COND
                       ((EQ NEWREGION 'DON'T)
                        (RETURN))
                       ((POSITIONP NEWREGION)
                        (SETQ POS NEWREGION]
          (COND
             ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS)
                           OLDLEFT))
                  (NOT (EQ (fetch (POSITION YCOORD) of POS)
                           OLDBOTTOM)))
              (SETQ NEWREGION (create REGION
                                     LEFT _ (ffetch (POSITION XCOORD) of POS)
                                     BOTTOM _ (ffetch (POSITION YCOORD) of POS)
                                     WIDTH _ OLDWIDTH
                                     HEIGHT _ OLDHEIGHT))
              (UNINTERRUPTABLY
                  [COND
                     ((SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW))
                      (XLIB:WITH-STATE (XBASEW)
                             (CL:SETF (XLIB:DRAWABLE-Y XBASEW)
                                    (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN)
                                           (fetch (REGION TOP) of NEWREGION)))
                             (CL:SETF (XLIB:DRAWABLE-X XBASEW)
                                    (fetch (REGION LEFT) of NEWREGION]
                  (replace (WINDOW REG) of WINDOW with NEWREGION)
                  (ADVISEXWDS WINDOW OLDREGION T))
              (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN)
                     WINDOW)))
          (RETURN POS])

(SHAPEW.XDISPLAY
  [LAMBDA (WINDOW NEWREGION)                           (* ; "Edited 13-Sep-91 14:11 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (PROG ((OLDSIZE (WINDOWPROP WINDOW 'REGION))
           NEWSIZE)
          (COND
             ((\USERFNISDON'T (fetch (WINDOW RESHAPEFN) of WINDOW))
                                                             (* ; 
                                                           "don't allow the window to be reshaped.")
              (PROMPTPRINT "This window cannot be reshaped.")
              (RETURN NIL)))
          (SETQ NEWSIZE (MINIMUMWINDOWSIZE WINDOW))
          [SETQ NEWSIZE (COND
                           (NEWREGION                        (* ; 
                                 "An explicit new region was specified; make sure it's big enough.")
                                  (COND
                                     [(OR (LESSP (fetch (REGION WIDTH) of NEWREGION)
                                                 (CAR NEWSIZE))
                                          (LESSP (fetch (REGION HEIGHT) of NEWREGION)
                                                 (CDR NEWSIZE)))
                                                             (* ; 
         "given a region that is too small, so expand the width and height to at least the minima.")
                                      (CREATEREGION (fetch (REGION LEFT) of NEWREGION)
                                             (fetch (REGION BOTTOM) of NEWREGION)
                                             (IMAX (CAR NEWSIZE)
                                                   (fetch (REGION WIDTH) of NEWREGION))
                                             (IMAX (CDR NEWSIZE)
                                                   (fetch (REGION HEIGHT) of NEWREGION]
                                     (T NEWREGION)))
                           (T (ERROR "NEWREGION must be specified."]
          (RETURN (if (EQUAL NEWSIZE OLDSIZE)
                      then 

                            (* ;; "if same size and place as before, do nothing")

                            NIL
                    elseif (AND (EQ (fetch (REGION WIDTH) of NEWSIZE)
                                        (fetch (REGION WIDTH) of OLDSIZE))
                                    (EQ (fetch (REGION HEIGHT) of NEWSIZE)
                                        (fetch (REGION HEIGHT) of OLDSIZE)))
                      then 

                            (* ;; "if same width and height, then optimize to a move")

                            (MOVEW.XDISPLAY WINDOW (fetch (REGION LEFT) of NEWSIZE)
                                   (fetch (REGION BOTTOM) of NEWSIZE))
                    else 

                          (* ;; "do the shape, checking for a doshapefn")

                          (APPLY* (OR (WINDOWPROP WINDOW 'DOSHAPEFN)
                                      '\XSHAPEW1)
                                 WINDOW
                                 (COPYALL NEWSIZE])

(SHRINKW.XDISPLAY
  [LAMBDA (WINDOW TOWHAT ICONPOSITION EXPANDFN)        (* ; "Edited 11-Sep-91 15:59 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (COND
       ((NOT (OPENWP WINDOW))
        NIL)
       ((WINDOWPROP WINDOW 'ICONFOR)
        NIL)
       ((EQ (DOUSERFNS (WINDOWPROP WINDOW 'SHRINKFN)
                   WINDOW T)
            'DON'T)
        NIL)
       (T (LET (TITLE ICONW FN ICONISBITMAP ICONISPIXMAP)
               [SETQ ICONW (COND
                              ((type? BITMAP TOWHAT)
                               [SETQ ICONISPIXMAP (PIXMAPFROMBITMAP TOWHAT
                                                         (BITSPERPIXEL (fetch (SCREEN 
                                                                                        SCDESTINATION
                                                                                         )
                                                                          of (fetch
                                                                                  (WINDOW SCREEN)
                                                                                    of WINDOW]
                               [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (XCREATEWFROMPIXMAP
                                                                      ICONISPIXMAP
                                                                      (fetch (WINDOW SCREEN)
                                                                         of WINDOW]
                               (XLIB:FREE-PIXMAP ICONISPIXMAP)
                               TOWHAT)
                              ((XLIB:DRAWABLE-P TOWHAT)
                               [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (XCREATEWFROMPIXMAP
                                                                      TOWHAT
                                                                      (fetch (WINDOW SCREEN)
                                                                         of WINDOW]
                               TOWHAT)
                              ((ISXWINDOW? TOWHAT)
                               (WINDOWPROP WINDOW 'ICON TOWHAT)
                               TOWHAT)
                              ((STRINGP TOWHAT)
                               [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (\DTEST (APPLY* DEFAULTICONFN 
                                                                                    WINDOW TOWHAT)
                                                                            'WINDOW]
                               TOWHAT)
                              (T [SETQ TOWHAT (COND
                                                 ((SETQ FN (WINDOWPROP WINDOW 'ICONFN))
                                                             (* ; 
                                              "User fn to create an icon.  Can return cached value")
                                                  (APPLY* FN WINDOW (WINDOWPROP WINDOW 'ICONWINDOW)
                                                         (POSITIONP ICONPOSITION)))
                                                 (T (WINDOWPROP WINDOW 'ICON]
                                 (COND
                                    ((ISXWINDOW? TOWHAT)
                                     TOWHAT)
                                    ((type? BITMAP TOWHAT)
                                     [SETQ ICONISPIXMAP (PIXMAPFROMBITMAP
                                                         TOWHAT
                                                         (BITSPERPIXEL (fetch (SCREEN 
                                                                                        SCDESTINATION
                                                                                         )
                                                                          of (fetch
                                                                                  (WINDOW SCREEN)
                                                                                    of WINDOW]
                                     (XCREATEWFROMPIXMAP ICONISPIXMAP (fetch (WINDOW SCREEN)
                                                                             of WINDOW))
                                     (XLIB:FREE-PIXMAP ICONISPIXMAP))
                                    ((XLIB:DRAWABLE-P TOWHAT)
                                     (XCREATEWFROMPIXMAP TOWHAT (fetch (WINDOW SCREEN)
                                                                       of WINDOW)))
                                    (T (\DTEST (APPLY* XDEFAULTICONFN WINDOW TOWHAT)
                                              'WINDOW]
               (WINDOWPROP WINDOW 'ICONWINDOW ICONW)
               (WINDOWPROP ICONW 'ICONFOR WINDOW)
               (WINDOWADDFNPROP ICONW 'CLOSEFN (FUNCTION XCLOSEMAINWINDOW))
                                                             (* ; "(COND ((EQ (WINDOWPROP ICONW 'BUTTONEVENTFN) 'TOTOPW) (WINDOWPROP ICONW 'BUTTONEVENTFN (FUNCTION ICONBUTTONEVENTFN))))")
               (WINDOWADDFNPROP WINDOW 'OPENFN (FUNCTION CLOSEICONWINDOW))
               (WINDOWADDFNPROP ICONW 'MOVEFN (FUNCTION \NOTENEWICONPOSITION))
               (AND EXPANDFN (WINDOWADDFNPROP WINDOW 'EXPANDFN EXPANDFN))
                                                             (* ; 
                                     "(WINDOWPROP ICONW 'DOWINDOWCOMFN (FUNCTION DOICONWINDOWCOM))")
               [COND
                  [(AND (NEQ ICONPOSITION 'SAME)
                        (OR ICONISBITMAP (POSITIONP ICONPOSITION)))
                   (MOVEW ICONW (COND
                                   ((POSITIONP ICONPOSITION)
                                    ICONPOSITION)
                                   ((PROG1 [POSITIONP (SETQ ICONPOSITION (WINDOWPROP WINDOW
                                                                                'ICONPOSITION]
                                                             (* ; 
                                                           "leave it in its current location.")
                                           ))
                                   (T (SETQ ICONPOSITION (ICONPOSITION.FROM.WINDOW
                                                          WINDOW
                                                          (WINDOWPROP ICONW 'REGION]
                  (T (SETQ ICONPOSITION (LET [(REG (WINDOWPROP ICONW 'REGION]
                                             (create POSITION
                                                    XCOORD _ (fetch (REGION LEFT) of REG)
                                                    YCOORD _ (fetch (REGION BOTTOM) of REG]
               (WINDOWPROP WINDOW 'ICONPOSITION ICONPOSITION)(* ; "(TOTOPW WINDOW T)")
               (\XCLOSEW1 WINDOW)
               (OPENW ICONW)
               ICONW])

(EXPANDW.XDISPLAY
  [LAMBDA (ICONW)                                      (* ; "Edited 11-Sep-91 16:58 by matsuda")
    (PROG ((IW ICONW)
           MAINWINDOW USEREXPANDFN EXPANDREGION)
          [COND
             [(SETQ MAINWINDOW (WINDOWPROP IW 'ICONFOR]
             ((SETQ IW (WINDOWPROP IW 'ICONWINDOW))
              (COND
                 ((OPENWP (SETQ MAINWINDOW ICONW))
                  (RETURN ICONW]
          (COND
             ([AND MAINWINDOW (NULL (\USERFNISDON'T (SETQ USEREXPANDFN (WINDOWPROP MAINWINDOW
                                                                              'EXPANDFN]
              (if (AND (WINDOWPROP MAINWINDOW 'EXPANDREGIONFN)
                           (SETQ EXPANDREGION (APPLY* (WINDOWPROP MAINWINDOW 'EXPANDREGIONFN)
                                                     MAINWINDOW)))
                  then (\XSHAPEW1 MAINWINDOW EXPANDREGION)
                else (\XOPENW1 MAINWINDOW))
              (\XCLOSEW1 IW)
              (WINDOWDELPROP MAINWINDOW 'OPENFN 'CLOSEICONWINDOW)
              (WINDOWDELPROP IW 'CLOSEFN 'CLOSEMAINWINDOW)
              (DOUSERFNS USEREXPANDFN MAINWINDOW)
              (RETURN (WINDOWPROP IW 'ICONFOR NIL])

(TOTOPW.XDISPLAY
  [LAMBDA (WINDOW NOCALLTOTOPFNFLG)                    (* ; "Edited 13-Sep-91 16:51 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (COND
       ((OPENWP WINDOW)
        (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN)
                                    WINDOW))
        (\XINTERNALTOTOPW WINDOW))
       ((OPENW WINDOW)
        (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN)
                                    WINDOW)))
       (T                                                    (* ; 
                                               "window won't open probably because of DON'T OPENFN")
          (ERROR "Window won't open; Can't be bring to top." WINDOW)))
    WINDOW])

(BURYW.XDISPLAY
  [LAMBDA (WINDOW)                                     (* ; "Edited 13-Sep-91 18:02 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (PROG [(BASEW (WINDOWPROP WINDOW 'XBASEW]
          (AND BASEW (XLIB::SET-WINDOW-PRIORITY :BELOW BASEW])
)
(DEFINEQ

(\XOPENW1
  [LAMBDA (WINDOW)                                     (* ; "Edited  6-Sep-91 15:22 by matsuda")
    (if (EQ (fetch (WINDOW NEXTW) of WINDOW)
                'CLOSED)
        then (PROG ((BASEW (WINDOWPROP WINDOW 'XBASEW))
                        XWIN REG BORDER XTITLEW TOP (SCREEN (fetch (WINDOW SCREEN) of WINDOW)
                                                           )
                        DD)
                       (if BASEW
                           then (XLIB:MAP-WINDOW BASEW)
                         else (WINDOWPROP WINDOW 'XBASEW (SETQ BASEW (\XCREATEBASEW WINDOW)))
                               [AND (WINDOWPROP WINDOW 'TITLE)
                                    (SETQ XTITLEW (WINDOWPROP WINDOW 'XTITLEW]
                               (SETQ XWIN (fetch (WINDOW SAVE) of WINDOW))
                               (SETQ BORDER (XLIB:DRAWABLE-BORDER-WIDTH XWIN))
                               (SETQ TOP 0)
                               [COND
                                  (XTITLEW (XLIB:REPARENT-WINDOW XTITLEW BASEW 0 0)
                                         (SETQ TOP (XLIB:DRAWABLE-HEIGHT XTITLEW]
                               (XLIB:REPARENT-WINDOW XWIN BASEW 0 TOP)
                               (XLIB:MAP-SUBWINDOWS BASEW)
                               (CL:SETF (XLIB:TRANSIENT-FOR BASEW)
                                      BASEW)
                               (XLIB:MAP-WINDOW BASEW))
                       (UNINTERRUPTABLY
                           (XLIB:MAP-WINDOW (fetch (WINDOW SAVE) of WINDOW))
                           (replace (WINDOW NEXTW) of WINDOW with (fetch (SCREEN
                                                                                          SCTOPW)
                                                                                 of SCREEN))
                           (replace (SCREEN SCTOPW) of SCREEN with WINDOW))])

(XSHOWWFRAME
  [LAMBDA (WIN)                                          (* ; "Edited 22-Oct-91 17:03 by jn")

    (* ;; "Displays the border and title in the save image of a window ")

    [PROG ((TITLE (fetch (WINDOW WTITLE) of WIN))
           (BORDER (fetch (WINDOW WBORDER) of WIN))
           (SAVEIMAGE (fetch (WINDOW SAVE) of WIN))
           (SCREEN (fetch (WINDOW SCREEN) of WIN))
           (REG (fetch (WINDOW REG) of WIN))
           BLACKPART FOOT (TITLE-H 0))                       (* ; "make most of the border black")
          (SETQ BLACKPART (IMAX (FOLDHI BORDER 2)
                                (IDIFFERENCE BORDER 2)))
          (XSHOWWTITLE TITLE SAVEIMAGE BORDER NIL WIN)
          [AND TITLE (SETQ TITLE-H (XLIB:DRAWABLE-HEIGHT (WINDOWPROP WIN 'XTITLEW]
          (if SAVEIMAGE
              then [XLIB:WITH-STATE (SAVEIMAGE)
                              (CL:SETF (XLIB:DRAWABLE-Y SAVEIMAGE)
                                     TITLE-H)
                              (CL:SETF (XLIB:DRAWABLE-X SAVEIMAGE)
                                     0)
                              (CL:SETF (XLIB:DRAWABLE-WIDTH SAVEIMAGE)
                                     (IDIFFERENCE (fetch (REGION WIDTH) of REG)
                                            (ITIMES BLACKPART 2)))
                              (CL:SETF (XLIB:DRAWABLE-HEIGHT SAVEIMAGE)
                                     (IDIFFERENCE (fetch (REGION HEIGHT) of REG)
                                            (IPLUS TITLE-H (ITIMES BLACKPART 2]
            else (replace SAVE of WIN
                        with (SETQ SAVEIMAGE (XLIB:CREATE-WINDOW
                                                  :PARENT
                                                  (fetch (SCREEN SCDESTINATION) of SCREEN)
                                                  :X
                                                  (fetch (REGION LEFT) of REG)
                                                  :Y
                                                  (IDIFFERENCE (fetch (SCREEN SCHEIGHT)
                                                                  of SCREEN)
                                                         (IDIFFERENCE (fetch (REGION TOP)
                                                                         of REG)
                                                                (IPLUS TITLE-H BLACKPART)))
                                                  :WIDTH
                                                  (IDIFFERENCE (fetch (REGION WIDTH) of
                                                                                         REG)
                                                         (ITIMES BLACKPART 2))
                                                  :HEIGHT
                                                  (IDIFFERENCE (fetch (REGION HEIGHT)
                                                                  of REG)
                                                         (IPLUS TITLE-H (ITIMES BLACKPART 2)))
                                                  :BORDER-WIDTH BLACKPART :BACKGROUND XLIB::*WHITE* 
                                                  :BIT-GRAVITY :NORTH-WEST :BACKING-STORE :ALWAYS]
    WIN])

(ADVISEXWDS
  [LAMBDA (WINDOW OLDREG MOVEONLYFLG)
    (DECLARE (LOCALVARS . T))                      (* ; "Edited  5-Sep-91 16:23 by matsuda")
    (PROG (R D WBORDERSIZE CLIPREG TWICEBORDER PROC OFFSET)
          (SETQ R (fetch (WINDOW REG) of WINDOW))
          (SETQ D (fetch (WINDOW DSP) of WINDOW))
          (SETQ WBORDERSIZE (fetch (WINDOW WBORDER) of WINDOW))
          (SETQ TWICEBORDER (UNFOLD WBORDERSIZE 2))
          (COND
             (OLDREG (OR MOVEONLYFLG (DSPCLIPPINGREGION
                                      [create REGION
                                             LEFT _ 0
                                             BOTTOM _ 0
                                             WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH)
                                                                     of R)
                                                            TWICEBORDER)
                                             HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT)
                                                                             of R)
                                                                    TWICEBORDER)
                                                             (COND
                                                                [(fetch (WINDOW WTITLE)
                                                                    of WINDOW)
                                                                 (DSPLINEFEED
                                                                  NIL
                                                                  (fetch (SCREEN SCTITLEDS)
                                                                     of (fetch (WINDOW SCREEN
                                                                                              )
                                                                               of WINDOW]
                                                                (T 0]
                                      D)))
             (T (SETQ OFFSET (IMAX (FOLDHI WBORDERSIZE 2)
                                   (IDIFFERENCE WBORDERSIZE 2)))
                (DSPXOFFSET OFFSET D)
                (DSPYOFFSET OFFSET D)
                (DSPCLIPPINGREGION [create REGION
                                          LEFT _ 0
                                          BOTTOM _ 0
                                          WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of
                                                                                         R)
                                                         TWICEBORDER)
                                          HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT)
                                                                          of R)
                                                                 TWICEBORDER)
                                                          (COND
                                                             [(fetch (WINDOW WTITLE) of
                                                                                         WINDOW)
                                                              (DSPLINEFEED NIL
                                                                     (fetch (SCREEN SCTITLEDS)
                                                                        of (fetch
                                                                                (WINDOW SCREEN)
                                                                                  of WINDOW]
                                                             (T 0]
                       D)))
          [COND
             ((NULL MOVEONLYFLG)                             (* ; 
                                         "if the previous right margin was the default, change it.")
              (AND (OR (NOT OLDREG)
                       (EQ (DSPRIGHTMARGIN NIL D)
                           (IDIFFERENCE (fetch (REGION WIDTH) of OLDREG)
                                  TWICEBORDER)))
                   (DSPRIGHTMARGIN (IDIFFERENCE (fetch (REGION WIDTH) of R)
                                          TWICEBORDER)
                          D))
              (COND
                 ((AND (SETQ PROC (WINDOWPROP WINDOW 'PROCESS))
                       (EQ D (PROCESS.TTY PROC)))            (* ; 
                                             "if the window changing is a tty, set its linelength.")
                  [PROCESS.EVAL PROC (LIST (FUNCTION PAGEHEIGHT)
                                           (IQUOTIENT (fetch (REGION HEIGHT)
                                                         of (SETQ CLIPREG (DSPCLIPPINGREGION
                                                                               NIL D)))
                                                  (IMINUS (DSPLINEFEED NIL D]
                  (PROCESS.EVAL PROC '(SETLINELENGTH))
                  (IF NIL
                      THEN                               (* ; "try it without this.")
                            (COND
                               ((EQ (PROCESSPROP PROC 'NAME)
                                    'EXEC)

                                (* ;; "in the exec process, make sure the current position is inside the new shape.  reuse variables R and TWICEBORDER to save binding.")

                                (COND
                                   ((ILESSP (SETQ R (DSPYPOSITION NIL D))
                                           (SETQ TWICEBORDER (fetch (REGION BOTTOM) of 
                                                                                              CLIPREG
                                                                    )))
                                    (DSPYPOSITION TWICEBORDER D))
                                   ((IGREATERP R (SETQ TWICEBORDER (IPLUS (fetch (REGION HEIGHT)
                                                                             of CLIPREG)
                                                                          TWICEBORDER)))
                                    (DSPYPOSITION (IDIFFERENCE TWICEBORDER (FONTPROP D 'ASCENT))
                                           D]
          (UPDATE/SCROLL/REG WINDOW))
    WINDOW])

(XMOVEORRESIZED.WINDOW
  [LAMBDA (WINDOW X Y WIDTH HEIGHT)                    (* ; "Edited  5-Sep-91 16:57 by matsuda")
    (PROG ((NEXTW (fetch (SCREEN SCTOPW) of \XSCREEN))
           XBASEW OLDREG NEWREG)
      LOOP
          (COND
             (NEXTW (SETQ XBASEW (WINDOWPROP NEXTW 'XBASEW))
                    (COND
                       [(EQ WINDOW XBASEW)
                        (SETQ OLDREG (fetch (WINDOW REG)
                                            NEXTW))
                        (SETQ NEWREG (create REGION
                                            LEFT _ X
                                            BOTTOM _ (IDIFFERENCE (fetch (SCREEN SCHEIGHT)
                                                                     of \XSCREEN)
                                                            (IPLUS Y HEIGHT))
                                            WIDTH _ WIDTH
                                            HEIGHT _ HEIGHT))
                        (COND
                           ((AND (EQ (fetch (REGION WIDTH) of OLDREG)
                                     WIDTH)
                                 (EQ (fetch (REGION HEIGHT) of OLDREG)
                                     HEIGHT))
                            (XMOVEW1 NEXTW (fetch (REGION LEFT) of NEWREG)
                                   (fetch (REGION BOTTOM) of NEWREG)))
                           (T (XSHAPEW1 NEXTW NEWREG]
                       (T (SETQ NEXTW (fetch (WINDOW NEXTW) of NEXTW))
                          (GO LOOP])

(\XMOUSELEFT
  [LAMBDA (WINDOW X Y)                                 (* ; "Edited  5-Sep-91 16:56 by matsuda")
    (SETQ XLASTMOUSEX X)
    (SETQ XLASTMOUSEY (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN)
                             Y))
    (COND
       ((EQ XLASTWINDOW (\FINDWINDOW WINDOW)
            XLASTWINDOW)
        (DOUSERFNS (fetch (WINDOW CURSORINFN) of XLASTWINDOW)
               XLASTWINDOW)))
    (SETQ XLASTWINDOW NIL])

(\XMOUSEMOVED
  [LAMBDA (WINDOW X Y)                                 (* ; "Edited  5-Sep-91 16:55 by matsuda")
    (SETQ XLASTMOUSEX X)
    (SETQ XLASTMOUSEY (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN)
                             Y))
    (SETQ XLASTWINDOW (\FINDWINDOW WINDOW))
    (DOUSERFNS (fetch (WINDOW CURSORMOVEDFN) of XLASTWINDOW)
           XLASTWINDOW])

(\FINDWINDOW
  [LAMBDA (WINDOW)                                     (* ; "Edited  5-Sep-91 16:51 by matsuda")
    (PROG ((NEXTW (fetch (SCREEN SCTOPW) of \XSCREEN))
           XBASEW)
      LOOP
          (COND
             (NEXTW (SETQ XBASEW (WINDOWPROP NEXTW 'XBASEW))
                    (COND
                       ((EQ WINDOW XBASEW)
                        (RETURN NEXTW))
                       (T (SETQ NEXTW (fetch (WINDOW NEXTW) of NEXTW))
                          (GO LOOP])

(\XMOUSEENTERED
  [LAMBDA (WINDOW X Y)                                 (* ; "Edited  5-Sep-91 17:13 by matsuda")
    (SETQ XLASTMOUSEX X)
    (SETQ XLASTMOUSEY (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN)
                             Y))
    (SETQ XLASTWINDOW (\FINDWINDOW WINDOW))
    (DOUSERFNS (fetch (WINDOW CURSORINFN) of XLASTWINDOW)
           XLASTWINDOW])

(XMOVEW
  [LAMBDA (WINDOW POSorX Y)                            (* ; "Edited  7-Mar-91 14:24 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW))
           (USERMOVEFN (fetch (WINDOW MOVEFN) of WINDOW))
           POS NEWREGION OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT XBASEW)
          (COND
             ([COND
                 ((LISTP USERMOVEFN)
                  (FMEMB 'DON'T USERMOVEFN))
                 (T (EQ USERMOVEFN 'DON'T]
              (PROMPTPRINT "This window cannot be moved.")
              (RETURN)))
          (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION))
          (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION))
          (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION))
          (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION))
          (COND
             [(AND POSorX (SETQ POS (COND
                                       ((POSITIONP POSorX)
                                        POSorX)
                                       [(NUMBERP POSorX)
                                        (COND
                                           ((NUMBERP Y)
                                            (create POSITION
                                                   XCOORD _ POSorX
                                                   YCOORD _ Y))
                                           (T (\ILLEGAL.ARG Y]
                                       ((REGIONP POSorX)
                                        (create POSITION
                                               XCOORD _ (fetch (REGION LEFT) of POSorX)
                                               YCOORD _ (fetch (REGION BOTTOM) of POSorX)))
                                       (T (\ILLEGAL.ARG POSorX]
             (T (\ILLEGAL.ARG POSorX)))
          [COND
             ((AND (LISTP USERMOVEFN)
                   (NOT (FMEMB (CAR USERMOVEFN)
                               LAMBDASPLST)))
              (AND (EQ [for MFN in USERMOVEFN do (SETQ NEWREGION (APPLY* MFN WINDOW POS))
                                                            (COND
                                                               ((EQ NEWREGION 'DON'T)
                                                                (RETURN 'DON'T))
                                                               ((POSITIONP NEWREGION)
                                                                (SETQ POS NEWREGION]
                       'DON'T)
                   (RETURN)))
             (USERMOVEFN (SETQ NEWREGION (APPLY* USERMOVEFN WINDOW POS))
                    (COND
                       ((EQ NEWREGION 'DON'T)
                        (RETURN))
                       ((POSITIONP NEWREGION)
                        (SETQ POS NEWREGION]
          (COND
             ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS)
                           OLDLEFT))
                  (NOT (EQ (fetch (POSITION YCOORD) of POS)
                           OLDBOTTOM)))
              (SETQ NEWREGION (create REGION
                                     LEFT _ (ffetch (POSITION XCOORD) of POS)
                                     BOTTOM _ (ffetch (POSITION YCOORD) of POS)
                                     WIDTH _ OLDWIDTH
                                     HEIGHT _ OLDHEIGHT))
              (UNINTERRUPTABLY
                  [COND
                     ((SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW))
                      (XLIB:WITH-STATE (XBASEW)
                             (CL:SETF (XLIB:DRAWABLE-Y XBASEW)
                                    (IDIFFERENCE (fetch (XSCREEN SCHEIGHT) of \XSCREEN)
                                           (fetch (REGION TOP) of NEWREGION)))
                             (CL:SETF (XLIB:DRAWABLE-X XBASEW)
                                    (fetch (REGION LEFT) of NEWREGION]
                  (replace (WINDOW REG) of WINDOW with NEWREGION)
                  (ADVISEXWDS WINDOW OLDREGION T))
              (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN)
                     WINDOW)))
          (RETURN POS])

(\XCLOSEW1
  [LAMBDA (WINDOW)                                     (* ; "Edited 10-Sep-91 17:31 by matsuda")
    (LET (SCREEN NEXTW SAVE)
         (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW))
         (SETQ NEXTW (fetch (SCREEN SCTOPW) of SCREEN))
         (COND
            ((NULL NEXTW)
             NIL)
            ((EQ NEXTW WINDOW)
             (UNINTERRUPTABLY
                 (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW))
                 (replace (SCREEN SCTOPW) of SCREEN with (fetch (WINDOW NEXTW)
                                                                        of NEXTW))
                 (replace (WINDOW NEXTW) of WINDOW with 'CLOSED))
             T)
            (T (PROG NIL
                     (SETQ SAVE NEXTW)
                     (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE))
                 LOOP
                     (COND
                        (NEXTW (COND
                                  [(EQ NEXTW WINDOW)
                                   (UNINTERRUPTABLY
                                       (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW))
                                       (replace (WINDOW NEXTW) of SAVE
                                          with (fetch (WINDOW NEXTW) of NEXTW))
                                       (replace (WINDOW NEXTW) of NEXTW with 'CLOSED))]
                                  (T (SETQ SAVE NEXTW)
                                     (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE))
                                     (GO LOOP])

(XSHAPEW
  [LAMBDA (WINDOW NEWREGION)                           (* ; "Edited  6-Sep-91 17:49 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (PROG ((OLDSIZE (WINDOWPROP WINDOW 'REGION))
           NEWSIZE)
          (COND
             ((\USERFNISDON'T (fetch (WINDOW RESHAPEFN) of WINDOW))
                                                             (* ; 
                                                           "don't allow the window to be reshaped.")
              (PROMPTPRINT "This window cannot be reshaped.")
              (RETURN NIL)))
          (SETQ NEWSIZE (MINIMUMWINDOWSIZE WINDOW))
          [SETQ NEWSIZE (COND
                           (NEWREGION                        (* ; 
                                 "An explicit new region was specified; make sure it's big enough.")
                                  (COND
                                     [(OR (LESSP (fetch (REGION WIDTH) of NEWREGION)
                                                 (CAR NEWSIZE))
                                          (LESSP (fetch (REGION HEIGHT) of NEWREGION)
                                                 (CDR NEWSIZE)))
                                                             (* ; 
         "given a region that is too small, so expand the width and height to at least the minima.")
                                      (CREATEREGION (fetch (REGION LEFT) of NEWREGION)
                                             (fetch (REGION BOTTOM) of NEWREGION)
                                             (IMAX (CAR NEWSIZE)
                                                   (fetch (REGION WIDTH) of NEWREGION))
                                             (IMAX (CDR NEWSIZE)
                                                   (fetch (REGION HEIGHT) of NEWREGION]
                                     (T NEWREGION)))
                           (T (ERROR "NEWREGION must be specified."]
          (RETURN (if (EQUAL NEWSIZE OLDSIZE)
                      then 

                            (* ;; "if same size and place as before, do nothing")

                            NIL
                    elseif (AND (EQ (fetch (REGION WIDTH) of NEWSIZE)
                                        (fetch (REGION WIDTH) of OLDSIZE))
                                    (EQ (fetch (REGION HEIGHT) of NEWSIZE)
                                        (fetch (REGION HEIGHT) of OLDSIZE)))
                      then 

                            (* ;; "if same width and height, then optimize to a move")

                            (XMOVEW WINDOW (fetch (REGION LEFT) of NEWSIZE)
                                   (fetch (REGION BOTTOM) of NEWSIZE))
                    else 

                          (* ;; "do the shape, checking for a doshapefn")

                          (APPLY* (OR (WINDOWPROP WINDOW 'DOSHAPEFN)
                                      '\XSHAPEW1)
                                 WINDOW
                                 (COPYALL NEWSIZE])

(\XSHAPEW1
  [LAMBDA (WINDOW REGION)                              (* ; "Edited  6-Sep-91 18:05 by matsuda")
    (SETQ WINDOW (\INSUREWINDOW WINDOW))
    (OR (REGIONP REGION)
        (\ILLEGAL.ARG REGION))
    (PROG [(XBASEW (WINDOWPROP WINDOW 'XBASEW]
          (IF XBASEW
              THEN (XLIB:WITH-STATE (XBASEW)
                              (CL:SETF (XLIB:DRAWABLE-X XBASEW)
                                     (fetch (REGION LEFT) of REGION))
                              (CL:SETF (XLIB:DRAWABLE-Y XBASEW)
                                     (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT XLIB::*ROOT*)
                                            (fetch (REGION TOP) of REGION)))
                              (CL:SETF (XLIB:DRAWABLE-WIDTH XBASEW)
                                     (fetch (REGION WIDTH) of REGION))
                              (CL:SETF (XLIB:DRAWABLE-HEIGHT XBASEW)
                                     (fetch (REGION HEIGHT) of REGION])

(XCREATEWFROMPIXMAP
  [LAMBDA (PIXMAP SCREEN)                              (* ; "Edited 13-Sep-91 14:33 by matsuda")
    (PROG (WINDOW WIDTH HEIGHT)
          (SETQ WINDOW (CREATEW (create SCREENREGION
                                       SCREEN _ (\INSURESCREEN SCREEN)
                                       LEFT _ 0
                                       BOTTOM _ 0
                                       WIDTH _ (SETQ WIDTH (PIXMAPWIDTH PIXMAP))
                                       HEIGHT _ (SETQ HEIGHT (PIXMAPHEIGHT PIXMAP)))
                              NIL 0 T))
          (WINDOWPROP WINDOW 'MINSIZE (CONS (IMIN MinWindowWidth WIDTH)
                                            (IMIN MinWindowWidth HEIGHT)))
          (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*)
                 CL:BOOLE-1)
          (XLIB:COPY-AREA PIXMAP XLIB::*GC* 0 0 WIDTH HEIGHT (fetch (WINDOW SAVE) of WINDOW)
                 0 0)
          (RETURN WINDOW])

(XCLOSEMAINWINDOW
  [LAMBDA (ICONWIN)                                    (* ; "Edited 11-Sep-91 11:22 by matsuda")
    (PROG [(MAINWIN (WINDOWPROP ICONWIN 'ICONFOR]
          [COND
             (MAINWIN (COND
                         ((NULL (\OKTOCLOSEW MAINWIN))
                          (RETURN 'DON'T))
                         (T (AND (OPENWP MAINWIN)
                                 (\XCLOSEW1 MAINWIN]
          (WINDOWPROP ICONWIN 'ICONFOR NIL)
          (RETURN NIL])

(\XINTERNALTOTOPW
  [LAMBDA (WINDOW)                                     (* ; "Edited 13-Sep-91 18:02 by matsuda")
    (PROG [(BASEW (WINDOWPROP WINDOW 'XBASEW]
          (AND BASEW (XLIB::SET-WINDOW-PRIORITY :ABOVE BASEW])
)
(DEFINEQ

(ISXWINDOW?
  [LAMBDA (WINDOW)                                     (* ; "Edited 11-Sep-91 10:56 by matsuda")
    (AND (TYPE? WINDOW WINDOW)
         (XLIB:DRAWABLE-P (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN)
                                                                      of WINDOW)))
         WINDOW])
)
(DEFINEQ

(INIT.XMAS2
  [LAMBDA NIL                                            (* ; "Edited 20-Oct-91 10:55 by jn")
    (MOVD 'CREATEW 'CREATEW.DISPLAY)
    (MOVD 'CREATEW.NEW 'CREATEW)
    (MOVD 'CLOSEW 'CLOSEW.DISPLAY)
    (MOVD 'CLOSEW.NEW 'CLOSEW)
    (MOVD 'OPENW 'OPENW.DISPLAY)
    (MOVD 'OPENW.NEW 'OPENW)
    (MOVD 'MOVEW 'MOVEW.DISPLAY)
    (MOVD 'MOVEW.NEW 'MOVEW)
    (MOVD 'SHAPEW 'SHAPEW.DISPLAY)
    (MOVD 'SHAPEW.NEW 'SHAPEW)
    (MOVD 'SHRINKW 'SHRINKW.DISPLAY)
    (MOVD 'SHRINKW.NEW 'SHRINKW)
    (MOVD 'EXPANDW 'EXPANDW.DISPLAY)
    (MOVD 'EXPANDW.NEW 'EXPANDW)
    (SETQ \XSCREEN (CREATESCREEN XLIB::*ROOT*))
    [replace (SCREEN SCDATA) of \XSCREEN with (SETQ \XDisplayWindowOps
                                                           (CREATE WINDOWOPS
                                                                  CREATEW _ (FUNCTION 
                                                                             CREATEW.XDISPLAY)
                                                                  OPENW _ (FUNCTION OPENW.XDISPLAY)
                                                                  CLOSEW _ (FUNCTION CLOSEW.XDISPLAY)
                                                                  MOVEW _ (FUNCTION MOVEW.XDISPLAY)
                                                                  SHAPEW _ (FUNCTION SHAPEW.XDISPLAY)
                                                                  SHRINKW _ (FUNCTION 
                                                                             SHRINKW.XDISPLAY)
                                                                  EXPANDW _ (FUNCTION 
                                                                             EXPANDW.XDISPLAY]
    [replace (SCREEN SCDATA) of \MAINSCREEN with (SETQ \DisplayWindowOps
                                                              (CREATE WINDOWOPS
                                                                     CREATEW _ (FUNCTION 
                                                                                CREATEW.DISPLAY)
                                                                     OPENW _ (FUNCTION OPENW.DISPLAY)
                                                                     CLOSEW _ (FUNCTION 
                                                                               CLOSEW.DISPLAY)
                                                                     MOVEW _ (FUNCTION MOVEW.DISPLAY)
                                                                     SHAPEW _ (FUNCTION 
                                                                               SHAPEW.DISPLAY)
                                                                     SHRINKW _ (FUNCTION 
                                                                                SHRINKW.DISPLAY)
                                                                     EXPANDW _ (FUNCTION 
                                                                                EXPANDW.DISPLAY]
    (CL:PUSH \XSCREEN \SCREENS])
)

(RPAQQ XMAS2COMS
       ((RECORDS WINDOWOPS)
        (FNS CREATESCREEN DSPCREATE CREATEW.NEW OPENW.NEW CLOSEW.NEW MOVEW.NEW SHAPEW.NEW SHRINKW.NEW
             EXPANDW.NEW)
        (FNS CREATEW.XDISPLAY OPENW.XDISPLAY CLOSEW.XDISPLAY MOVEW.XDISPLAY SHAPEW.XDISPLAY 
             SHRINKW.XDISPLAY EXPANDW.XDISPLAY TOTOPW.XDISPLAY BURYW.XDISPLAY)
        (FNS \XOPENW1 XSHOWWFRAME ADVISEXWDS XMOVEORRESIZED.WINDOW \XMOUSELEFT \XMOUSEMOVED 
             \FINDWINDOW \XMOUSEENTERED XMOVEW \XCLOSEW1 XSHAPEW \XSHAPEW1 XCREATEWFROMPIXMAP 
             XCLOSEMAINWINDOW \XINTERNALTOTOPW)
        (FNS ISXWINDOW?)
        (FNS INIT.XMAS2)
        (VARS XMAS2COMS)))
(PUTPROPS XMAS2 COPYRIGHT ("Fuji Xerox Co., Ltd" 1991))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1816 10841 (CREATESCREEN 1826 . 3905) (DSPCREATE 3907 . 7484) (CREATEW.NEW 7486 . 8271)
 (OPENW.NEW 8273 . 8747) (CLOSEW.NEW 8749 . 9129) (MOVEW.NEW 9131 . 9614) (SHAPEW.NEW 9616 . 10006) (
SHRINKW.NEW 10008 . 10458) (EXPANDW.NEW 10460 . 10839)) (10842 30847 (CREATEW.XDISPLAY 10852 . 13334) 
(OPENW.XDISPLAY 13336 . 13835) (CLOSEW.XDISPLAY 13837 . 14174) (MOVEW.XDISPLAY 14176 . 18419) (
SHAPEW.XDISPLAY 18421 . 21590) (SHRINKW.XDISPLAY 21592 . 28583) (EXPANDW.XDISPLAY 28585 . 29816) (
TOTOPW.XDISPLAY 29818 . 30569) (BURYW.XDISPLAY 30571 . 30845)) (30848 57817 (\XOPENW1 30858 . 32860) (
XSHOWWFRAME 32862 . 36235) (ADVISEXWDS 36237 . 42690) (XMOVEORRESIZED.WINDOW 42692 . 44286) (
\XMOUSELEFT 44288 . 44760) (\XMOUSEMOVED 44762 . 45165) (\FINDWINDOW 45167 . 45683) (\XMOUSEENTERED 
45685 . 46087) (XMOVEW 46089 . 50325) (\XCLOSEW1 50327 . 51941) (XSHAPEW 51943 . 55096) (\XSHAPEW1 
55098 . 56108) (XCREATEWFROMPIXMAP 56110 . 57083) (XCLOSEMAINWINDOW 57085 . 57578) (\XINTERNALTOTOPW 
57580 . 57815)) (57818 58184 (ISXWINDOW? 57828 . 58182)) (58185 61281 (INIT.XMAS2 58195 . 61279)))))
STOP
\ No newline at end of file
diff --git a/obsolete/sources/new-edit-interface.tedit b/obsolete/sources/new-edit-interface.tedit
deleted file mode 100644
index 693420f8..00000000
Binary files a/obsolete/sources/new-edit-interface.tedit and /dev/null differ
diff --git a/obsolete/sources/subrs.h b/obsolete/sources/subrs.h
deleted file mode 100644
index 8f8dd528..00000000
--- a/obsolete/sources/subrs.h
+++ /dev/null
@@ -1,150 +0,0 @@
-/* This file written from LLSUBRS on 17-Mar-2021 11:14:28                      */
-/* Do not edit this file! Instead, edit the list \initsubrs */
-/* on the lisp file LLSUBRS and then call WRITECALLSUBRS to  */
-/* generate a new version.                                   */
-#ifndef SUBRS_H
-#define SUBRS_H 1
-#define sb_YIELD	0322
-#define sb_BACKGROUNDSUBR	06
-#define sb_CHECKBCPLPASSWORD	07
-#define sb_DISKPARTITION	010
-#define sb_DSPBOUT	011
-#define sb_DSPRATE	012
-#define sb_GATHERSTATS	013
-#define sb_GETPACKETBUFFER	014
-#define sb_LISPFINISH	015
-#define sb_MOREVMEMFILE	016
-#define sb_RAID	017
-#define sb_READRAWPBI	020
-#define sb_WRITERAWPBI	021
-#define sb_SETSCREENCOLOR	022
-#define sb_SHOWDISPLAY	023
-#define sb_PUPLEVEL1STATE	024
-#define sb_WRITESTATS	025
-#define sb_CONTEXTSWITCH	026
-#define sb_COPYSYS0SUBR	027
-#define sb_WRITEMAP	030
-#define sb_UFS_GETFILENAME	042
-#define sb_UFS_DELETEFILE	043
-#define sb_UFS_RENAMEFILE	044
-#define sb_COM_READPAGES	045
-#define sb_COM_WRITEPAGES	046
-#define sb_COM_TRUNCATEFILE	047
-#define sb_UFS_DIRECTORYNAMEP	051
-#define sb_COM_GETFREEBLOCK	055
-#define sb_SETUNIXTIME	060
-#define sb_GETUNIXTIME	061
-#define sb_COPYTIMESTATS	062
-#define sb_UNIX_USERNAME	063
-#define sb_UNIX_FULLNAME	064
-#define sb_UNIX_GETENV	065
-#define sb_UNIX_GETPARM	066
-#define sb_CHECK_SUM	067
-#define sb_ETHER_SUSPEND	070
-#define sb_ETHER_RESUME	071
-#define sb_ETHER_AVAILABLE	072
-#define sb_ETHER_RESET	073
-#define sb_ETHER_GET	074
-#define sb_ETHER_SEND	075
-#define sb_ETHER_SETFILTER	076
-#define sb_ETHER_CHECK	077
-#define sb_DSPCURSOR	0100
-#define sb_SETMOUSEXY	0101
-#define sb_DSP_VIDEOCOLOR	0102
-#define sb_DSP_SCREENWIDTH	0103
-#define sb_DSP_SCREENHEIGHT	0104
-#define sb_BITBLTSUB	0105
-#define sb_BLTCHAR	0106
-#define sb_TEDIT_BLTCHAR	0107
-#define sb_BITBLT_BITMAP	0110
-#define sb_BLTSHADE_BITMAP	0111
-#define sb_RS232C_CMD	0112
-#define sb_RS232C_READ_INIT	0113
-#define sb_RS232C_WRITE	0114
-#define sb_KEYBOARDBEEP	0120
-#define sb_KEYBOARDMAP	0121
-#define sb_KEYBOARDSTATE	0122
-#define sb_VMEMSAVE	0131
-#define sb_LISP_FINISH	0132
-#define sb_NEWPAGE	0133
-#define sb_DORECLAIM	0134
-#define sb_DUMMY_135Q	0135
-#define sb_NATIVE_MEMORY_REFERENCE	0136
-#define sb_OLD_COMPILE_LOAD_NATIVE	0137
-#define sb_DISABLEGC	0140
-#define sb_COM_SETFILEINFO	0147
-#define sb_COM_OPENFILE	0150
-#define sb_COM_CLOSEFILE	0151
-#define sb_DSK_GETFILENAME	0152
-#define sb_DSK_DELETEFILE	0153
-#define sb_DSK_RENAMEFILE	0154
-#define sb_COM_NEXT_FILE	0156
-#define sb_COM_FINISH_FINFO	0157
-#define sb_COM_GEN_FILES	0160
-#define sb_DSK_DIRECTORYNAMEP	0161
-#define sb_COM_GETFILEINFO	0162
-#define sb_COM_CHANGEDIR	0164
-#define sb_UNIX_HANDLECOMM	0165
-#define sb_RPC_CALL	0167
-#define sb_MESSAGE_READP	0170
-#define sb_MESSAGE_READ	0171
-#define sb_MONITOR_CONTROL	0200
-#define sb_GET_NATIVE_ADDR_FROM_LISP_PTR	0203
-#define sb_GET_LISP_PTR_FROM_NATIVE_ADDR	0204
-#define sb_LOAD_NATIVE_FILE	0205
-#define sb_SUSPEND_LISP	0206
-#define sb_NEW_BLTCHAR	0207
-#define sb_COLOR_INIT	0210
-#define sb_COLOR_SCREENMODE	0211
-#define sb_COLOR_MAP	0212
-#define sb_COLOR_BASE	0213
-#define sb_C_SlowBltChar	0214
-#define sb_UNCOLORIZE_BITMAP	0215
-#define sb_COLORIZE_BITMAP	0216
-#define sb_COLOR_8BPPDRAWLINE	0217
-#define sb_TCP_OP	0220
-#define sb_WITH_SYMBOL	0221
-#define sb_CAUSE_INTERRUPT	0222
-#define sb_OPEN_SOCKET	0240
-#define sb_CLOSE_SOCKET	0241
-#define sb_READ_SOCKET	0242
-#define sb_WRITE_SOCKET	0243
-#define sb_CALL_C_FUNCTION	0247
-#define sb_DLD_LINK	0250
-#define sb_DLD_UNLINK_BY_FILE	0251
-#define sb_DLD_UNLINK_BY_SYMBOL	0252
-#define sb_DLD_GET_SYMBOL	0253
-#define sb_DLD_GET_FUNC	0254
-#define sb_DLD_FUNCTION_EXECUTABLE_P	0255
-#define sb_DLD_LIST_UNDEFINED_SYMBOLS	0256
-#define sb_C_MALLOC	0257
-#define sb_C_FREE	0260
-#define sb_C_PUTBASEBYTE	0261
-#define sb_C_GETBASEBYTE	0262
-#define sb_CHAR_OPENFILE	0310
-#define sb_CHAR_BIN	0311
-#define sb_CHAR_BOUT	0312
-#define sb_CHAR_IOCTL	0313
-#define sb_CHAR_CLOSEFILE	0314
-#define sb_CHAR_EOFP	0315
-#define sb_CHAR_READP	0316
-#define sb_CHAR_BINS	0317
-#define sb_CHAR_BOUTS	0320
-#define sb_CHAR_FILLBUFFER	0321
-/* MISCN opcodes */
-#define miscn_USER_SUBR	00
-#define miscn_VALUES	01
-#define miscn_SXHASH	02
-#define miscn_EQLHASHBITSFN	03
-#define miscn_STRINGHASHBITS	04
-#define miscn_STRING_EQUAL_HASHBITS	05
-#define miscn_VALUES_LIST	06
-#define miscn_LCFetchMethod	07
-#define miscn_LCFetchMethodOrHelp	010
-#define miscn_LCFindVarIndex	011
-#define miscn_LCGetIVValue	012
-#define miscn_LCPutIVValue	013
-/* Assigned USER SUBR numbers */
-#define user_subr_DUMMY	012
-#define user_subr_SAMPLE_USER_SUBR	00
-#endif 
diff --git a/obsolete/sunloadup/FASTINIT b/obsolete/sunloadup/FASTINIT
deleted file mode 100644
index 9ca76db7..00000000
--- a/obsolete/sunloadup/FASTINIT
+++ /dev/null
@@ -1,82 +0,0 @@
-(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/obsolete/sunloadup/FASTINIT-2.0.DFASL b/obsolete/sunloadup/FASTINIT-2.0.DFASL
deleted file mode 100644
index 09dbca9e..00000000
Binary files a/obsolete/sunloadup/FASTINIT-2.0.DFASL and /dev/null differ
diff --git a/obsolete/sunloadup/FASTINIT.DFASL b/obsolete/sunloadup/FASTINIT.DFASL
deleted file mode 100644
index d58457d7..00000000
Binary files a/obsolete/sunloadup/FASTINIT.DFASL and /dev/null differ
diff --git a/obsolete/sunloadup/FILESETS b/obsolete/sunloadup/FILESETS
deleted file mode 100644
index fc1d0976..00000000
--- a/obsolete/sunloadup/FILESETS
+++ /dev/null
@@ -1,69 +0,0 @@
-(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/obsolete/sunloadup/FILESETS.NOETHER b/obsolete/sunloadup/FILESETS.NOETHER
deleted file mode 100644
index 5f3a9f88..00000000
--- a/obsolete/sunloadup/FILESETS.NOETHER
+++ /dev/null
@@ -1,175 +0,0 @@
-(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/obsolete/sunloadup/FILESETS.ORIG b/obsolete/sunloadup/FILESETS.ORIG
deleted file mode 100644
index ea51dea1..00000000
--- a/obsolete/sunloadup/FILESETS.ORIG
+++ /dev/null
@@ -1,168 +0,0 @@
-(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/obsolete/sunloadup/FILESETS.PUP b/obsolete/sunloadup/FILESETS.PUP
deleted file mode 100644
index cfc9462d..00000000
--- a/obsolete/sunloadup/FILESETS.PUP
+++ /dev/null
@@ -1,69 +0,0 @@
-(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/obsolete/sunloadup/HOWTO-LOADUP-SUNLISP.TXT b/obsolete/sunloadup/HOWTO-LOADUP-SUNLISP.TXT
deleted file mode 100644
index 9e250cf3..00000000
--- a/obsolete/sunloadup/HOWTO-LOADUP-SUNLISP.TXT
+++ /dev/null
@@ -1,173 +0,0 @@
-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/obsolete/sunloadup/HOWTO-MAKE-SYSOUT.TEDIT b/obsolete/sunloadup/HOWTO-MAKE-SYSOUT.TEDIT
deleted file mode 100644
index 400adf15..00000000
Binary files a/obsolete/sunloadup/HOWTO-MAKE-SYSOUT.TEDIT and /dev/null differ
diff --git a/obsolete/sunloadup/INIT.DO-TEST b/obsolete/sunloadup/INIT.DO-TEST
deleted file mode 100644
index 3a569f01..00000000
--- a/obsolete/sunloadup/INIT.DO-TEST
+++ /dev/null
@@ -1,55 +0,0 @@
-;; 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/obsolete/sunloadup/INIT.LOADFULL b/obsolete/sunloadup/INIT.LOADFULL
deleted file mode 100644
index 3bbaf7cf..00000000
--- a/obsolete/sunloadup/INIT.LOADFULL
+++ /dev/null
@@ -1,5 +0,0 @@
-"  
-SHH(LOAD '{DSK}~/SUNLOADUP/LOADFULL.LISP)
-SHH(MAKESYS '{DSK}~/FULL.SYSOUT]
-SHH(LOGOUT] "
-
diff --git a/obsolete/sunloadup/INIT.LOADFULLFROMLISP b/obsolete/sunloadup/INIT.LOADFULLFROMLISP
deleted file mode 100644
index 431211f1..00000000
--- a/obsolete/sunloadup/INIT.LOADFULLFROMLISP
+++ /dev/null
@@ -1,2 +0,0 @@
-(PROGN (ILLOAD '{dsk}SUNLOADUP/LOADFULL.LISP) (ILMAKESYS 'FULL.SYSOUT) (ILLOGOUT T))
-
diff --git a/obsolete/sunloadup/INIT.MAKEBIG b/obsolete/sunloadup/INIT.MAKEBIG
deleted file mode 100644
index c458e4a0..00000000
--- a/obsolete/sunloadup/INIT.MAKEBIG
+++ /dev/null
@@ -1,50 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKEBIGFULLFROMLISP b/obsolete/sunloadup/INIT.MAKEBIGFULLFROMLISP
deleted file mode 100644
index 5d36eae5..00000000
--- a/obsolete/sunloadup/INIT.MAKEBIGFULLFROMLISP
+++ /dev/null
@@ -1,13 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKEBIGSGI b/obsolete/sunloadup/INIT.MAKEBIGSGI
deleted file mode 100644
index 8e1ea878..00000000
--- a/obsolete/sunloadup/INIT.MAKEBIGSGI
+++ /dev/null
@@ -1,48 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKECLTL2SGI b/obsolete/sunloadup/INIT.MAKECLTL2SGI
deleted file mode 100644
index f023705b..00000000
--- a/obsolete/sunloadup/INIT.MAKECLTL2SGI
+++ /dev/null
@@ -1,51 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKEINIT b/obsolete/sunloadup/INIT.MAKEINIT
deleted file mode 100644
index f86fd79b..00000000
--- a/obsolete/sunloadup/INIT.MAKEINIT
+++ /dev/null
@@ -1,48 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKEINIT-3BYTE b/obsolete/sunloadup/INIT.MAKEINIT-3BYTE
deleted file mode 100644
index f86fd79b..00000000
--- a/obsolete/sunloadup/INIT.MAKEINIT-3BYTE
+++ /dev/null
@@ -1,48 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKEINIT-MAIN b/obsolete/sunloadup/INIT.MAKEINIT-MAIN
deleted file mode 100644
index 0e597456..00000000
--- a/obsolete/sunloadup/INIT.MAKEINIT-MAIN
+++ /dev/null
@@ -1,34 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKEINIT-NOETHER b/obsolete/sunloadup/INIT.MAKEINIT-NOETHER
deleted file mode 100644
index 733f821c..00000000
--- a/obsolete/sunloadup/INIT.MAKEINIT-NOETHER
+++ /dev/null
@@ -1,34 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKEINITDSK b/obsolete/sunloadup/INIT.MAKEINITDSK
deleted file mode 100644
index b65e9a20..00000000
--- a/obsolete/sunloadup/INIT.MAKEINITDSK
+++ /dev/null
@@ -1,48 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKEINITFULL b/obsolete/sunloadup/INIT.MAKEINITFULL
deleted file mode 100644
index 1c181619..00000000
--- a/obsolete/sunloadup/INIT.MAKEINITFULL
+++ /dev/null
@@ -1,41 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKEINITFULLFROMLISP b/obsolete/sunloadup/INIT.MAKEINITFULLFROMLISP
deleted file mode 100644
index 5d36eae5..00000000
--- a/obsolete/sunloadup/INIT.MAKEINITFULLFROMLISP
+++ /dev/null
@@ -1,13 +0,0 @@
-;
-;	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/obsolete/sunloadup/INIT.MAKEINITFULLSGI b/obsolete/sunloadup/INIT.MAKEINITFULLSGI
deleted file mode 100644
index 4bf11849..00000000
--- a/obsolete/sunloadup/INIT.MAKEINITFULLSGI
+++ /dev/null
@@ -1,40 +0,0 @@
-;
-;	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/obsolete/sunloadup/LOADBIGFULLFROMLISP-REM.CM b/obsolete/sunloadup/LOADBIGFULLFROMLISP-REM.CM
deleted file mode 100644
index 6955cd0f..00000000
--- a/obsolete/sunloadup/LOADBIGFULLFROMLISP-REM.CM
+++ /dev/null
@@ -1,5 +0,0 @@
-"
-SHH(PROGN (IL:LOAD '\"{dsk}SUNLOADUP/LOADFULL-BIG.LISP\") (IL:MAKESYS '\"{dsk}FULL.SYSOUT\") (IL:LOGOUT T))
-
-"
-
diff --git a/obsolete/sunloadup/LOADFULL-BIG.LISP b/obsolete/sunloadup/LOADFULL-BIG.LISP
deleted file mode 100644
index dc7d5412..00000000
--- a/obsolete/sunloadup/LOADFULL-BIG.LISP
+++ /dev/null
@@ -1,28 +0,0 @@
-(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/obsolete/sunloadup/LOADFULL-REM.CM b/obsolete/sunloadup/LOADFULL-REM.CM
deleted file mode 100644
index 4516887c..00000000
--- a/obsolete/sunloadup/LOADFULL-REM.CM
+++ /dev/null
@@ -1,7 +0,0 @@
-"
-(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/obsolete/sunloadup/LOADFULL.LISP b/obsolete/sunloadup/LOADFULL.LISP
deleted file mode 100644
index d7290d01..00000000
--- a/obsolete/sunloadup/LOADFULL.LISP
+++ /dev/null
@@ -1,29 +0,0 @@
-(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/obsolete/sunloadup/LOADFULLFROMLISP-REM.CM b/obsolete/sunloadup/LOADFULLFROMLISP-REM.CM
deleted file mode 100644
index 57b12cf8..00000000
--- a/obsolete/sunloadup/LOADFULLFROMLISP-REM.CM
+++ /dev/null
@@ -1,5 +0,0 @@
-"
-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/obsolete/sunloadup/LOADUP-BIG.LISP b/obsolete/sunloadup/LOADUP-BIG.LISP
deleted file mode 100644
index 602c01df..00000000
Binary files a/obsolete/sunloadup/LOADUP-BIG.LISP and /dev/null differ
diff --git a/obsolete/sunloadup/LOADUP-NOCOMPILER-REM.CM b/obsolete/sunloadup/LOADUP-NOCOMPILER-REM.CM
deleted file mode 100644
index 7aa27269..00000000
--- a/obsolete/sunloadup/LOADUP-NOCOMPILER-REM.CM
+++ /dev/null
@@ -1,6 +0,0 @@
-"
-(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/obsolete/sunloadup/LOADUP-NOCOMPILER.LISP b/obsolete/sunloadup/LOADUP-NOCOMPILER.LISP
deleted file mode 100644
index 1504bac7..00000000
--- a/obsolete/sunloadup/LOADUP-NOCOMPILER.LISP
+++ /dev/null
@@ -1,83 +0,0 @@
-(* " '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/obsolete/sunloadup/LOADUP-NODMACHINE-REM.CM b/obsolete/sunloadup/LOADUP-NODMACHINE-REM.CM
deleted file mode 100644
index d4e2e033..00000000
--- a/obsolete/sunloadup/LOADUP-NODMACHINE-REM.CM
+++ /dev/null
@@ -1,6 +0,0 @@
-"
-(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/obsolete/sunloadup/LOADUP-NODMACHINE.LISP b/obsolete/sunloadup/LOADUP-NODMACHINE.LISP
deleted file mode 100644
index 28949ec3..00000000
--- a/obsolete/sunloadup/LOADUP-NODMACHINE.LISP
+++ /dev/null
@@ -1,81 +0,0 @@
-(* " '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/obsolete/sunloadup/LOADUP-NOETHER-REM.CM b/obsolete/sunloadup/LOADUP-NOETHER-REM.CM
deleted file mode 100644
index cc898fd5..00000000
--- a/obsolete/sunloadup/LOADUP-NOETHER-REM.CM
+++ /dev/null
@@ -1,6 +0,0 @@
-"
-(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/obsolete/sunloadup/LOADUP-NOETHER.LISP b/obsolete/sunloadup/LOADUP-NOETHER.LISP
deleted file mode 100644
index 058c42fc..00000000
--- a/obsolete/sunloadup/LOADUP-NOETHER.LISP
+++ /dev/null
@@ -1,82 +0,0 @@
-(* "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/obsolete/sunloadup/LOADUP-NOXCLCOMPILER-REM.CM b/obsolete/sunloadup/LOADUP-NOXCLCOMPILER-REM.CM
deleted file mode 100644
index e774ccda..00000000
--- a/obsolete/sunloadup/LOADUP-NOXCLCOMPILER-REM.CM
+++ /dev/null
@@ -1,6 +0,0 @@
-"
-(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/obsolete/sunloadup/LOADUP-NOXCLCOMPILER.LISP b/obsolete/sunloadup/LOADUP-NOXCLCOMPILER.LISP
deleted file mode 100644
index 537ddd31..00000000
--- a/obsolete/sunloadup/LOADUP-NOXCLCOMPILER.LISP
+++ /dev/null
@@ -1,84 +0,0 @@
-(* " '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/obsolete/sunloadup/LOADUP-REM.CM b/obsolete/sunloadup/LOADUP-REM.CM
deleted file mode 100644
index 5da6248a..00000000
--- a/obsolete/sunloadup/LOADUP-REM.CM
+++ /dev/null
@@ -1,5 +0,0 @@
-"
-(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/obsolete/sunloadup/LOADUP.LISP b/obsolete/sunloadup/LOADUP.LISP
deleted file mode 100644
index 086575b2..00000000
--- a/obsolete/sunloadup/LOADUP.LISP
+++ /dev/null
@@ -1,96 +0,0 @@
-(* " (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/obsolete/sunloadup/LOADUP.LOG b/obsolete/sunloadup/LOADUP.LOG
deleted file mode 100644
index b6a48079..00000000
--- a/obsolete/sunloadup/LOADUP.LOG
+++ /dev/null
@@ -1 +0,0 @@
-
{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/obsolete/sunloadup/LispDlion.db b/obsolete/sunloadup/LispDlion.db
deleted file mode 100644
index caf1b2fc..00000000
Binary files a/obsolete/sunloadup/LispDlion.db and /dev/null differ
diff --git a/obsolete/sunloadup/LispDove.db b/obsolete/sunloadup/LispDove.db
deleted file mode 100644
index a2ca1ebd..00000000
Binary files a/obsolete/sunloadup/LispDove.db and /dev/null differ
diff --git a/obsolete/sunloadup/MAIKOINIT b/obsolete/sunloadup/MAIKOINIT
deleted file mode 100644
index a57ccc94..00000000
--- a/obsolete/sunloadup/MAIKOINIT
+++ /dev/null
@@ -1,7 +0,0 @@
-
-(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/obsolete/sunloadup/MAIKOLOADUPFNS b/obsolete/sunloadup/MAIKOLOADUPFNS
deleted file mode 100644
index 3a3e4a35..00000000
--- a/obsolete/sunloadup/MAIKOLOADUPFNS
+++ /dev/null
@@ -1,589 +0,0 @@
-(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/obsolete/sunloadup/MAIKOLOADUPFNS.LCOM b/obsolete/sunloadup/MAIKOLOADUPFNS.LCOM
deleted file mode 100644
index d1276f25..00000000
Binary files a/obsolete/sunloadup/MAIKOLOADUPFNS.LCOM and /dev/null differ
diff --git a/obsolete/sunloadup/MAKE-UTILS b/obsolete/sunloadup/MAKE-UTILS
deleted file mode 100644
index de61be92..00000000
--- a/obsolete/sunloadup/MAKE-UTILS
+++ /dev/null
@@ -1,24 +0,0 @@
-(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/obsolete/sunloadup/NLOCALFILE b/obsolete/sunloadup/NLOCALFILE
deleted file mode 100644
index 078bcd41..00000000
--- a/obsolete/sunloadup/NLOCALFILE
+++ /dev/null
@@ -1,47 +0,0 @@
-(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/obsolete/sunloadup/NLOCALFILE.LCOM b/obsolete/sunloadup/NLOCALFILE.LCOM
deleted file mode 100644
index 3ec1457d..00000000
Binary files a/obsolete/sunloadup/NLOCALFILE.LCOM and /dev/null differ
diff --git a/obsolete/sunloadup/POSTLOADUP b/obsolete/sunloadup/POSTLOADUP
deleted file mode 100644
index 20beb166..00000000
--- a/obsolete/sunloadup/POSTLOADUP
+++ /dev/null
@@ -1,41 +0,0 @@
-(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/obsolete/sunloadup/POSTLOADUP.LCOM b/obsolete/sunloadup/POSTLOADUP.LCOM
deleted file mode 100644
index 0eb848c6..00000000
--- a/obsolete/sunloadup/POSTLOADUP.LCOM
+++ /dev/null
@@ -1 +0,0 @@
-(FILECREATED "18-Jul-90 18:44:25" ("compiled on " {DSK}<users>sybalsky>SUNLOADUP>POSTLOADUP.;1) 
"18-Jul-90 17:36:59" bcompl'd in "Lispcore  3-Jul-90 ..." dated " 3-Jul-90 15:55:29")
(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)
(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)))))
(MOVD (QUOTE NILL) (QUOTE LOADUP2A))
(CHANGENAME (QUOTE LOADUP2) (QUOTE ASSOC) (QUOTE TRUE))
(PUTPROPS POSTLOADUP COPYRIGHTOWNER "Xerox Corporation")
(PUTPROPS POSTLOADUP COPYRIGHTYEARS 1981)
(PRINT (QUOTE (HI THERE)) T)
NIL
\ No newline at end of file
diff --git a/obsolete/sunloadup/REM.CM b/obsolete/sunloadup/REM.CM
deleted file mode 100644
index 0121925e..00000000
--- a/obsolete/sunloadup/REM.CM
+++ /dev/null
@@ -1,7 +0,0 @@
-"
-(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/obsolete/sunloadup/SUNFONT b/obsolete/sunloadup/SUNFONT
deleted file mode 100644
index c449f5e4..00000000
--- a/obsolete/sunloadup/SUNFONT
+++ /dev/null
@@ -1,32 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-(FILECREATED "28-Jan-98 10:46:39" |{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>SUNFONT.;2| 1164   
-
-      |changes| |to:|  (VARS DISPLAYFONTDIRECTORIES)
-
-      |previous| |date:| "24-Jan-90 15:53:22" 
-|{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>SUNFONT.;1|)
-
-
-; Copyright (c) 1990, 1998 by John Sybalsky.  All rights reserved.
-
-(PRETTYCOMPRINT SUNFONTCOMS)
-
-(RPAQQ SUNFONTCOMS ((VARS DISPLAYFONTDIRECTORIES)))
-
-(RPAQQ DISPLAYFONTDIRECTORIES (
-                              "{DSK}~/lispcore/fonts/display/presentation/"
-                                   
-                                "{DSK}~/lispcore/fonts/display/PRINTWHEEL/"
-                                   
-                                "{DSK}~/lispcore/fonts/display/publishing/"
-                                   
-                             "{DSK}~/lispcore/fonts/display/miscellaneous/"
-                                   ))
-(PUTPROPS SUNFONT COPYRIGHT ("John Sybalsky" 1990 1998))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL)))
-STOP
-
-
-
-
diff --git a/obsolete/sunloadup/SUNFONT.LCOM b/obsolete/sunloadup/SUNFONT.LCOM
deleted file mode 100644
index 60d6b9ef..00000000
--- a/obsolete/sunloadup/SUNFONT.LCOM
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "28-Jan-98 10:46:47" ("compiled on " 
|{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>SUNFONT.;2|) "30-Mar-95 20:33:04" |bcompl'd| |in|
 "Medley 14-Aug-95 ..." |dated| "14-Aug-95 15:27:48")
(FILECREATED "28-Jan-98 10:46:39" |{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>SUNFONT.;2| 
1164 |changes| |to:| (VARS DISPLAYFONTDIRECTORIES) |previous| |date:| "24-Jan-90 15:53:22" 
|{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>SUNFONT.;1|)
(PRETTYCOMPRINT SUNFONTCOMS)
(RPAQQ SUNFONTCOMS ((VARS DISPLAYFONTDIRECTORIES)))
(RPAQQ DISPLAYFONTDIRECTORIES ("{DSK}~/lispcore/fonts/display/presentation/"
 "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" 
"{DSK}~/lispcore/fonts/display/publishing/" 
"{DSK}~/lispcore/fonts/display/miscellaneous/"))
(PUTPROPS SUNFONT COPYRIGHT ("John Sybalsky" 1990 1998))
NIL
\ No newline at end of file
diff --git a/obsolete/sunloadup/XREM-NOETHER.CM b/obsolete/sunloadup/XREM-NOETHER.CM
deleted file mode 100644
index 19245020..00000000
--- a/obsolete/sunloadup/XREM-NOETHER.CM
+++ /dev/null
@@ -1,8 +0,0 @@
-"
-(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/obsolete/sunloadup/bigFASTINIT.DFASL b/obsolete/sunloadup/bigFASTINIT.DFASL
deleted file mode 100644
index 58354fec..00000000
Binary files a/obsolete/sunloadup/bigFASTINIT.DFASL and /dev/null differ
diff --git a/obsolete/sunloadup/runloadbig b/obsolete/sunloadup/runloadbig
deleted file mode 100644
index 4a4ef4d5..00000000
--- a/obsolete/sunloadup/runloadbig
+++ /dev/null
@@ -1,113 +0,0 @@
-#! /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/obsolete/sunloadup/runloadbig-sgi b/obsolete/sunloadup/runloadbig-sgi
deleted file mode 100644
index 1bbdc02d..00000000
--- a/obsolete/sunloadup/runloadbig-sgi
+++ /dev/null
@@ -1,43 +0,0 @@
-#! /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/obsolete/sunloadup/runloadcltl2-sgi b/obsolete/sunloadup/runloadcltl2-sgi
deleted file mode 100644
index 710d51a4..00000000
--- a/obsolete/sunloadup/runloadcltl2-sgi
+++ /dev/null
@@ -1,42 +0,0 @@
-#! /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/obsolete/sunloadup/runloadfull b/obsolete/sunloadup/runloadfull
deleted file mode 100644
index 16081558..00000000
--- a/obsolete/sunloadup/runloadfull
+++ /dev/null
@@ -1,44 +0,0 @@
-#! /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/obsolete/sunloadup/runloadfull-2nd b/obsolete/sunloadup/runloadfull-2nd
deleted file mode 100644
index 6b3ce2b5..00000000
--- a/obsolete/sunloadup/runloadfull-2nd
+++ /dev/null
@@ -1,38 +0,0 @@
-#! /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/obsolete/sunloadup/runloadfull-dsk b/obsolete/sunloadup/runloadfull-dsk
deleted file mode 100644
index 0c845ee1..00000000
--- a/obsolete/sunloadup/runloadfull-dsk
+++ /dev/null
@@ -1,47 +0,0 @@
-#! /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/obsolete/sunloadup/runloadfull-sgi b/obsolete/sunloadup/runloadfull-sgi
deleted file mode 100644
index 31e3ac6d..00000000
--- a/obsolete/sunloadup/runloadfull-sgi
+++ /dev/null
@@ -1,42 +0,0 @@
-#! /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/obsolete/sunloadup/runloadfullfromlisp b/obsolete/sunloadup/runloadfullfromlisp
deleted file mode 100644
index 67b677d9..00000000
--- a/obsolete/sunloadup/runloadfullfromlisp
+++ /dev/null
@@ -1,38 +0,0 @@
-#! /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/obsolete/sunloadup/runloadup b/obsolete/sunloadup/runloadup
deleted file mode 100644
index df736b39..00000000
--- a/obsolete/sunloadup/runloadup
+++ /dev/null
@@ -1,38 +0,0 @@
-#! /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/obsolete/sunloadup/runloadup-2nd b/obsolete/sunloadup/runloadup-2nd
deleted file mode 100644
index 2bb386bb..00000000
--- a/obsolete/sunloadup/runloadup-2nd
+++ /dev/null
@@ -1,31 +0,0 @@
-#! /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/obsolete/sunloadup/runloadup-2nd-sun3 b/obsolete/sunloadup/runloadup-2nd-sun3
deleted file mode 100644
index 686d5618..00000000
--- a/obsolete/sunloadup/runloadup-2nd-sun3
+++ /dev/null
@@ -1,31 +0,0 @@
-#! /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/obsolete/sunloadup/runloadup-main b/obsolete/sunloadup/runloadup-main
deleted file mode 100644
index e425fe9c..00000000
--- a/obsolete/sunloadup/runloadup-main
+++ /dev/null
@@ -1,34 +0,0 @@
-#! /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/obsolete/sunloadup/runloadup-nodmachine b/obsolete/sunloadup/runloadup-nodmachine
deleted file mode 100644
index ffdc9384..00000000
--- a/obsolete/sunloadup/runloadup-nodmachine
+++ /dev/null
@@ -1,35 +0,0 @@
-#! /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/obsolete/sunloadup/runloadup-noether b/obsolete/sunloadup/runloadup-noether
deleted file mode 100644
index 9835e7d4..00000000
--- a/obsolete/sunloadup/runloadup-noether
+++ /dev/null
@@ -1,35 +0,0 @@
-#! /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/obsolete/sunloadup/runloadup-nt b/obsolete/sunloadup/runloadup-nt
deleted file mode 100644
index d5c8151f..00000000
--- a/obsolete/sunloadup/runloadup-nt
+++ /dev/null
@@ -1,38 +0,0 @@
-#! /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/obsolete/sunloadup/runloadup-sun3 b/obsolete/sunloadup/runloadup-sun3
deleted file mode 100644
index 34b8c64c..00000000
--- a/obsolete/sunloadup/runloadup-sun3
+++ /dev/null
@@ -1,34 +0,0 @@
-#! /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/obsolete/sunloadup/xrem.cm b/obsolete/sunloadup/xrem.cm
deleted file mode 100644
index 82ea1e4d..00000000
--- a/obsolete/sunloadup/xrem.cm
+++ /dev/null
@@ -1 +0,0 @@
-"
(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
diff --git a/obsolete/tcp/TCP b/obsolete/tcp/TCP
deleted file mode 100644
index 49a212eb..00000000
--- a/obsolete/tcp/TCP
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Aug-90 12:01:50" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCP.;5 98103  

      changes to%:  (FILES TCPLLIP)
                    (FNS \TCP.DELETE.TCB)

      previous date%: "13-Feb-89 21:04:17" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCP.;3)


(* "
Copyright (c) 1983, 1984, 1985, 1986, 1901, 1900, 1987, 1988, 1989, 1990 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT TCPCOMS)

(RPAQQ TCPCOMS 
       [(COMS 
              (* ;; "Transmission Control Protocol.  RFC 793, September 1981")
)
        (COMS (DECLARE%: EVAL@LOAD (FILES (SYSLOAD)
                                          TCPLLIP))
              (GLOBALVARS \TCP.LOCK \TCP.CONTROL.BLOCKS \TCP.CHECKSUMS.ON \TCP.PSEUDOHEADER \TCP.MSL
                     \TCP.DEFAULT.USER.TIMEOUT \TCP.DEFAULT.RECEIVE.WINDOW \TCP.DEVICE 
                     \TCP.MASTER.SOCKET))
        (COMS 
              (* ;; "DoD Internet addresses")

              (FNS SET.IP.ADDRESS STRING.TO.IP.ADDRESS IP.ADDRESS.TO.STRING \LOCAL.IP.ADDRESS))
        [COMS 
              (* ;; "TCP segments")

              (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "control bits for TCP.CTRL field of TCP header")

                     (EXPORT (CONSTANTS \TCP.CTRL.ACK \TCP.CTRL.FIN \TCP.CTRL.PSH \TCP.CTRL.RST 
                                    \TCP.CTRL.SYN \TCP.CTRL.URG)
                            
                            (* ;; "option definitions")

                            (CONSTANTS \TCPOPT.END \TCPOPT.NOP \TCPOPT.MAXSEG)
                            
                            (* ;; "TCP protocol number for IP level dispatch")

                            (CONSTANTS \TCP.PROTOCOL)
                            
                            (* ;; "TCP header length in bytes (= 4 * min data offset)")

                            (CONSTANTS \TCP.HEADER.LENGTH)
                            
                            (* ;; 
                        "minimum offset of data from segment in 32-bit words (= header length / 4)")

                            (CONSTANTS \TCP.MIN.DATA.OFFSET)
                            
                            (* ;; "default maximum segment size")

                            (CONSTANTS \TCP.DEFAULT.MAXSEG)
                            
                            (* ;; "TCP segment")

                            (RECORDS TCPSEGMENT]
        (COMS 
              (* ;; "TCP sequence numbers")

              (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "macros for comparing TCP sequence numbers")

                     (MACROS \32BIT.EQ \32BIT.LT \32BIT.LEQ \32BIT.GT \32BIT.GEQ)
                     
                     (* ;; "fast multiply by 3 -- evaluates its argument twice")

                     (MACROS \3TIMES))
              (FNS \TCP.SELECT.ISS))
        (COMS 
              (* ;; "TCP control blocks")

              (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "TCP control block")

                     (EXPORT (RECORDS TCP.CONTROL.BLOCK TCPSTREAM))
                     
                     (* ;; "TCP stream")
)
              (INITRECORDS TCP.CONTROL.BLOCK TCPSTREAM)
              
              (* ;; "global lock for TCP-related mutual exclusion")

              (INITVARS (\TCP.LOCK (CREATE.MONITORLOCK)))
              
              (* ;; "list of TCP control blocks for connection lookup")

              (INITVARS (\TCP.CONTROL.BLOCKS NIL))
              (FNS \TCP.CREATE.TCB \TCP.SELECT.PORT \TCP.LOOKUP.TCB \TCP.DELETE.TCB \TCP.NOSOCKETFN 
                   \TCP.PORTCOMPARE))
        (COMS 
              (* ;; "TCP checksums")

              (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "pseudo-header for checksum calculation")

                     (RECORDS TCP.PSEUDOHEADER)
                     (CONSTANTS \TCP.PSEUDOHEADER.LENGTH)
                     (MACROS \16BIT.COMPLEMENT \16BIT.1C.PLUS))
              (INITRECORDS TCP.PSEUDOHEADER)
              (INITVARS (\TCP.PSEUDOHEADER NIL))
              
              (* ;; "this variable controls whether checksums are performed on incoming segments")

              (INITVARS (\TCP.CHECKSUMS.ON NIL))
              
              (* ;; "checksum routines")

              (FNS \COMPUTE.CHECKSUM \TCP.CHECKSUM.INCOMING \TCP.CHECKSUM.OUTGOING))
        (COMS (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "constants for retransmission timeout calculation")

                     
                     (* ;; "initial retransmission timeout")

                     (CONSTANTS \TCP.INITIAL.RTO)
                     
                     (* ;; "upper and lower bounds on retransmission timeout")

                     (CONSTANTS (\TCP.UBOUND 5000)
                            (\TCP.LBOUND 1000)))
              
              (* ;; "maximum segment lifetime")

              (INITVARS (\TCP.MSL 5000))
              (INITVARS (\TCP.DEFAULT.USER.TIMEOUT 60000)
                     (\TCP.DEFAULT.RECEIVE.WINDOW 4096)
                     (\TCP.DEVICE NIL))
              
              (* ;; "TCP protocol routines")

              (FNS \TCP.ACK# \TCP.PACKET.FILTER \TCP.SETUP.SEGMENT \TCP.RELEASE.SEGMENT 
                   \TCP.CONNECTION \TCP.FIX.INCOMING.SEGMENT \TCP.DATA.LENGTH \TCP.SYN.OR.FIN 
                   \TCP.INPUT \TCP.INPUT.INITIAL \TCP.INPUT.UNSYNC \TCP.INPUT.LISTEN 
                   \TCP.INPUT.SYN.SENT \TCP.CHECK.WINDOW \TCP.CHECK.RESET \TCP.CHECK.SECURITY 
                   \TCP.CHECK.NO.SYN \TCP.CHECK.ACK \TCP.HANDLE.ACK \TCP.HANDLE.URG \TCP.QUEUE.INPUT
                   \TCP.HANDLE.FIN \TCP.OUR.FIN.IS.ACKED \TCP.SIGNAL.URGENT.DATA \TCP.PROCESS 
                   \TCP.TEMPLATE \TCP.SETUP.SEGMENT.OPTIONS \TCP.SEND.CONTROL \TCP.SEND.ACK 
                   \TCP.SEND.RESET \TCP.FIX.OUTGOING.SEGMENT \TCP.SEND.DATA \TCP.SEND.SEGMENT 
                   \TCP.NEW.TEMPLATE \TCP.START.PROBE.TIMER \TCP.RETRANSMIT \TCP.START.TIME.WAIT 
                   \TCP.CONNECTION.DROPPED \TCP.CHECK.OPTIONS \TCP.PROCESS.OPTIONS))
        (COMS 
              (* ;; "support for ICMP messages that affect TCP connections")

              (DECLARE%: EVAL@COMPILE DONTCOPY 

                     (* ;; "ICMP protocol number for IP level dispatch")

                     (CONSTANTS \ICMP.PROTOCOL)
                     
                     (* ;; 
                   "number of 32 bit words in ICMP message before start of original datagram")

                     (CONSTANTS \ICMP.32BIT.WORDS)
                     
                     (* ;; "relevant ICMP message types")

                     (CONSTANTS \ICMP.DESTINATION.UNREACHABLE \ICMP.SOURCE.QUENCH))
              (FNS \TCP.HANDLE.ICMP))
        (COMS 
              (* ;; "TCP stream routines")

              (FNS TCP.OPEN TCP.OTHER.STREAM \TCP.BOUTS \TCP.OTHER.BIN \TCP.OTHER.BOUT \TCP.BIN 
                   \TCP.BACKFILEPTR \TCP.GETNEXTBUFFER \TCP.GET.SEGMENT \TCP.PEEKBIN \TCP.GETFILEPTR
                   \TCP.READP \TCP.EOFP TCP.URGENTP TCP.URGENT.EVENT \TCP.BOUT \TCP.FLUSH 
                   \TCP.FORCEOUTPUT TCP.URGENT.MARK \TCP.FILL.IN.SEGMENT \TCP.CLOSE \TCP.RESETCLOSE 
                   TCP.CLOSE.SENDER TCP.DESTADDRESS TCP.STOP))
        (COMS 
              (* ;; "well-known ports for network standard functions")

              (CONSTANTS * \TCP.ASSIGNED.PORTS))
        (COMS 
              (* ;; "Stub for debugging")

              (INITVARS (\TCP.DEBUGGABLE)
                     (TCPTRACEFLG))
              (GLOBALVARS \TCP.DEBUGGABLE TCPTRACEFLG)
              (FNS PPTCB \TCP.TRACE.SEGMENT \TCP.TRACE.TRANSITION))
        (COMS 
              (* ;; "TCP initialization")

              (FNS \TCP.INIT)
              (P (\TCP.INIT])



(* ;; "Transmission Control Protocol.  RFC 793, September 1981")

(DECLARE%: EVAL@LOAD 

(FILESLOAD (SYSLOAD)
       TCPLLIP)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCP.LOCK \TCP.CONTROL.BLOCKS \TCP.CHECKSUMS.ON \TCP.PSEUDOHEADER \TCP.MSL 
       \TCP.DEFAULT.USER.TIMEOUT \TCP.DEFAULT.RECEIVE.WINDOW \TCP.DEVICE \TCP.MASTER.SOCKET)
)



(* ;; "DoD Internet addresses")

(DEFINEQ

(SET.IP.ADDRESS
(LAMBDA NIL (* ejs%: "28-Dec-84 18:45") (* set local IP address manually) (PROG ((ADDR (\IP.READ.STRING.ADDRESS (PROMPTFORWORD "Enter IP address:" (\IP.ADDRESS.TO.STRING (OR (CAR \IP.LOCAL.ADDRESSES) 0)))))) (SETQ \IP.LOCAL.ADDRESSES (LIST ADDR))))
)

(STRING.TO.IP.ADDRESS
(LAMBDA (STR) (* ecc "14-May-84 15:01") (APPLY (FUNCTION IP\Make\Address) (to 4 bind (I _ 0) OFFSET collect (SETQ OFFSET (ADD1 I)) (MKATOM (SUBSTRING STR OFFSET (AND (SETQ I (STRPOS "." STR OFFSET)) (SUB1 I)))))))
)

(IP.ADDRESS.TO.STRING
(LAMBDA (IPADDR) (* ecc "14-May-84 14:32") (PROG ((A (LOADBYTE IPADDR 24 8)) (B (LOADBYTE IPADDR 16 8)) (C (LOADBYTE IPADDR 8 8)) (D (LOADBYTE IPADDR 0 8))) (RETURN (CONCAT A "." B "." C "." D))))
)

(\LOCAL.IP.ADDRESS
(LAMBDA NIL (* ejs%: "28-Dec-84 18:45") (* return our IP address (or the first if we're multi-homed)) (if (NULL \IP.LOCAL.ADDRESSES) then (ERROR "You must set \IP.LOCAL.ADDRESSES to a list of our local IP addresses")) (CAR \IP.LOCAL.ADDRESSES))
)
)



(* ;; "TCP segments")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.CTRL.ACK 16)

(RPAQQ \TCP.CTRL.FIN 1)

(RPAQQ \TCP.CTRL.PSH 8)

(RPAQQ \TCP.CTRL.RST 4)

(RPAQQ \TCP.CTRL.SYN 2)

(RPAQQ \TCP.CTRL.URG 32)


(CONSTANTS \TCP.CTRL.ACK \TCP.CTRL.FIN \TCP.CTRL.PSH \TCP.CTRL.RST \TCP.CTRL.SYN \TCP.CTRL.URG)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCPOPT.END 0)

(RPAQQ \TCPOPT.NOP 1)

(RPAQQ \TCPOPT.MAXSEG 2)


(CONSTANTS \TCPOPT.END \TCPOPT.NOP \TCPOPT.MAXSEG)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.PROTOCOL 6)


(CONSTANTS \TCP.PROTOCOL)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.HEADER.LENGTH 20)


(CONSTANTS \TCP.HEADER.LENGTH)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.MIN.DATA.OFFSET 5)


(CONSTANTS \TCP.MIN.DATA.OFFSET)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.DEFAULT.MAXSEG 536)


(CONSTANTS \TCP.DEFAULT.MAXSEG)
)
(DECLARE%: EVAL@COMPILE

(ACCESSFNS TCPSEGMENT ((TCPHEADER (\IPDATABASE DATUM)))
                          (BLOCKRECORD TCPHEADER ((TCP.SRC.PORT WORD)
                                                  (TCP.DST.PORT WORD)
                                                  (TCP.SEQ FIXP)
                                                  (TCP.ACK FIXP)
                                                  (TCP.DATA.OFFSET BITS 4)
                                                  (TCP.MBZ BITS 6)
                                                  (TCP.CTRL BITS 6)
                                                  (TCP.WINDOW WORD)
                                                  (TCP.CHECKSUM WORD)
                                                  (TCP.URG.PTR WORD)))
                          [ACCESSFNS TCPSEGMENT ((TCP.DATA.LENGTH (fetch (IP IPHEADERCHECKSUM)
                                                                     of DATUM)
                                                        (replace (IP IPHEADERCHECKSUM)
                                                           of DATUM with NEWVALUE))
                                                 (TCP.SRC.ADDR (fetch (IP IPSOURCEADDRESS)
                                                                  of DATUM)
                                                        (replace (IP IPSOURCEADDRESS)
                                                           of DATUM with NEWVALUE))
                                                 (TCP.DST.ADDR (fetch (IP IPDESTINATIONADDRESS)
                                                                  of DATUM)
                                                        (replace (IP IPDESTINATIONADDRESS)
                                                           of DATUM with NEWVALUE))
                                                 (TCP.HEADER.LENGTH (LLSH (fetch TCP.DATA.OFFSET
                                                                             of DATUM)
                                                                          2))
                                                 (TCP.CONTENTS (\ADDBASE (fetch TCPHEADER
                                                                            of DATUM)
                                                                      (UNFOLD (fetch 
                                                                                     TCP.DATA.OFFSET
                                                                                 of DATUM)
                                                                             WORDSPERCELL)))
                                                 (TCP.OPTIONS (\ADDBASE (fetch TCPHEADER
                                                                           of DATUM)
                                                                     (UNFOLD \TCP.MIN.DATA.OFFSET 
                                                                            WORDSPERCELL])
)

(* "END EXPORTED DEFINITIONS")

)



(* ;; "TCP sequence numbers")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \32BIT.EQ MACRO ((A B)
                           (IEQP A B)))

(PUTPROPS \32BIT.LT MACRO ((A B)
                           (ILESSP (IDIFFERENCE A B)
                                  0)))

(PUTPROPS \32BIT.LEQ MACRO ((A B)
                            (ILEQ (IDIFFERENCE A B)
                                  0)))

(PUTPROPS \32BIT.GT MACRO ((A B)
                           (IGREATERP (IDIFFERENCE A B)
                                  0)))

(PUTPROPS \32BIT.GEQ MACRO ((A B)
                            (IGEQ (IDIFFERENCE A B)
                                  0)))
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS \3TIMES MACRO ((N)
                         (IPLUS (LLSH N 1)
                                N)))
)
)
(DEFINEQ

(\TCP.SELECT.ISS
(LAMBDA NIL (* ecc "16-May-84 11:40") (* select an initial send sequence number -- use the time of day to make sure we won't repeat after a crash) (LOGAND (DAYTIME) 65535))
)
)



(* ;; "TCP control blocks")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(DATATYPE TCP.CONTROL.BLOCK ((TCB.LOCK POINTER)          (* monitor lock for synchronizing 
                                                           access)
                                 (TCB.STATE POINTER)         (* one of CLOSED LISTEN SYN.SENT 
                                                           SYN.RECEIVED ESTABLISHED FIN.WAIT.1 
                                                           FIN.WAIT.2 CLOSE.WAIT CLOSING 
                                                           LAST.ACK TIME.WAIT)
                                 (TCB.SND.STREAM POINTER)    (* user's send stream)
                                 (TCB.SND.SEGMENT POINTER)   (* current output packet being 
                                                           filled)
                                 (TCB.RCV.STREAM POINTER)    (* user's receive stream)
                                 (TCB.RCV.SEGMENT POINTER)   (* current input packet being read)
                                 (TCB.2MSL.TIMER POINTER)    (* 2*MSL quiet time)
                                 (TCB.MAXSEG POINTER)        (* maximum segment size)
                                 (TCB.CLOSEDFLG POINTER)     (* T if user has initiated close
                                                           (no more data to send))
                                 (TCB.FINSEQ POINTER)        (* one past the sequence number of 
                                                           the FIN we sent)
                                 (TCB.ACKFLG POINTER)        (* when to ACK peer%: NOW or LATER)
                                 (TCB.TEMPLATE POINTER)      (* TCP header template)
                                 (TCB.PH POINTER)            (* TCP pseudo-header for 
                                                           checksumming)
                                 (TCB.SRC.PORT WORD)         (* local port)
                                 (TCB.DST.PORT WORD)         (* remote port)
                                 (TCB.DST.HOST FIXP)         (* remote host address)
                                 (TCB.INPUT.QUEUE POINTER)   (* queue of received segments to be 
                                                           read)
                                 (TCB.REXMT.QUEUE POINTER)   (* queue of unacked segments to be 
                                                           retransmitted)
                                 (TCB.SND.UNA FIXP)          (* first unacknowledged sequence 
                                                           number)
                                 (TCB.SND.NXT FIXP)          (* next sequence number to be sent)
                                 (TCB.SND.UP FIXP)           (* send urgent pointer)
                                 (TCB.SND.WL1 FIXP)          (* segment sequence number used for 
                                                           last window update)
                                 (TCB.SND.WL2 FIXP)          (* segment acknowledgment number 
                                                           used for last window update)
                                 (TCB.ISS FIXP)              (* initial send sequence number)
                                 (TCB.SND.WND WORD)          (* send window)
                                 (TCB.RCV.WND WORD)          (* receive window)
                                 (TCB.RCV.NXT FIXP)          (* next sequence number expected)
                                 (TCB.RCV.UP FIXP)           (* receive urgent pointer)
                                 (TCB.IRS FIXP)              (* initial receive sequence number)
                                 (TCB.USER.TIMEOUT POINTER)  (* in milliseconds)
                                 (TCB.ESTABLISHED POINTER)   (* processes waiting for this event 
                                                           are notified when the connection 
                                                           becomes established)
                                 (TCB.SND.EVENT POINTER)     (* processes waiting for this event 
                                                           are notified when the send window 
                                                           opens up)
                                 (TCB.RCV.EVENT POINTER)     (* processes waiting for this event 
                                                           are notified when data is received)
                                 (TCB.URGENT.EVENT POINTER)  (* processes waiting for this event 
                                                           are notified when urgent data is 
                                                           received)
                                 (TCB.FINACKED.EVENT POINTER)(* processes waiting for this event 
                                                           are notified when our FIN has been 
                                                           acked)
                                 (TCB.MODE POINTER)          (* ACTIVE or PASSIVE)
                                 (TCB.RTFLG POINTER)         (* T if round trip time being 
                                                           measured)
                                 (TCB.RTSEQ POINTER)         (* sequence number being timed)
                                 (TCB.RTTIMER POINTER)       (* round trip timer)
                                 (TCB.SRTT POINTER)          (* smoothed round trip time)
                                 (TCB.RTO POINTER)           (* retransmission timeout based on 
                                                           smoothed round trip time)
                                 (TCB.PROBE.TIMER POINTER)   (* timer for delayed ACKs and window 
                                                           probes)
                                 (TCB.IPSOCKET POINTER)      (* Pointer to open IP socket for 
                                                           this connection)
                                 (TCB.PROCESS POINTER)       (* TCP monitor process for this 
                                                           connection)
                                 (TCB.SENT.ZERO FLAG)        (* Sent a zero allocation last time)
                                 (TCB.OUTPUT.HELD FLAG)      (* True if output window shut)
                                 (TCB.NO.IDLE.PROBING FLAG)  (* True if we don't probe when 
                                                           nothing to output)
                                 (NIL BITS 5)
                                 (TCB.OUR.MAXSEG WORD)
                                 (TCB.LAST.SENT.RCV.WND WORD)(* The value of the last rcv window 
                                                           we sent)
                                 )
                                TCB.LOCK _ (CREATE.MONITORLOCK)
                                TCB.STATE _ 'CLOSED TCB.RCV.WND _ \TCP.DEFAULT.RECEIVE.WINDOW 
                                TCB.USER.TIMEOUT _ \TCP.DEFAULT.USER.TIMEOUT TCB.ESTABLISHED _ (
                                                                                         CREATE.EVENT
                                                                                                )
                                TCB.SND.EVENT _ (CREATE.EVENT)
                                TCB.RCV.EVENT _ (CREATE.EVENT)
                                TCB.URGENT.EVENT _ (CREATE.EVENT)
                                TCB.FINACKED.EVENT _ (CREATE.EVENT)
                                TCB.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.OUR.MAXSEG _ \TCP.DEFAULT.MAXSEG
                                TCB.SRTT _ \TCP.INITIAL.RTO TCB.RTO _ \TCP.INITIAL.RTO)

(ACCESSFNS TCPSTREAM ((TCB (fetch (STREAM F1) of DATUM)
                               (replace (STREAM F1) of DATUM with NEWVALUE))
                          (BYTECOUNT (fetch (STREAM F2) of DATUM)
                                 (replace (STREAM F2) of DATUM with NEWVALUE))
                          (ACCESS (fetch (STREAM ACCESS) of DATUM)
                                 (replace (STREAM ACCESS) of DATUM with NEWVALUE))
                          (ORIGINAL.COFFSET (fetch (STREAM FW6) of DATUM)
                                 (replace (STREAM FW6) of DATUM with NEWVALUE)))
                         (CREATE (create STREAM
                                            DEVICE _ \TCP.DEVICE)))
)

(/DECLAREDATATYPE 'TCP.CONTROL.BLOCK
       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
               POINTER POINTER WORD WORD FIXP POINTER POINTER FIXP FIXP FIXP FIXP FIXP FIXP WORD WORD
               FIXP FIXP FIXP POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
               POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG FLAG (BITS 5)
               WORD WORD)
       '((TCP.CONTROL.BLOCK 0 POINTER)
         (TCP.CONTROL.BLOCK 2 POINTER)
         (TCP.CONTROL.BLOCK 4 POINTER)
         (TCP.CONTROL.BLOCK 6 POINTER)
         (TCP.CONTROL.BLOCK 8 POINTER)
         (TCP.CONTROL.BLOCK 10 POINTER)
         (TCP.CONTROL.BLOCK 12 POINTER)
         (TCP.CONTROL.BLOCK 14 POINTER)
         (TCP.CONTROL.BLOCK 16 POINTER)
         (TCP.CONTROL.BLOCK 18 POINTER)
         (TCP.CONTROL.BLOCK 20 POINTER)
         (TCP.CONTROL.BLOCK 22 POINTER)
         (TCP.CONTROL.BLOCK 24 POINTER)
         (TCP.CONTROL.BLOCK 26 (BITS . 15))
         (TCP.CONTROL.BLOCK 27 (BITS . 15))
         (TCP.CONTROL.BLOCK 28 FIXP)
         (TCP.CONTROL.BLOCK 30 POINTER)
         (TCP.CONTROL.BLOCK 32 POINTER)
         (TCP.CONTROL.BLOCK 34 FIXP)
         (TCP.CONTROL.BLOCK 36 FIXP)
         (TCP.CONTROL.BLOCK 38 FIXP)
         (TCP.CONTROL.BLOCK 40 FIXP)
         (TCP.CONTROL.BLOCK 42 FIXP)
         (TCP.CONTROL.BLOCK 44 FIXP)
         (TCP.CONTROL.BLOCK 46 (BITS . 15))
         (TCP.CONTROL.BLOCK 47 (BITS . 15))
         (TCP.CONTROL.BLOCK 48 FIXP)
         (TCP.CONTROL.BLOCK 50 FIXP)
         (TCP.CONTROL.BLOCK 52 FIXP)
         (TCP.CONTROL.BLOCK 54 POINTER)
         (TCP.CONTROL.BLOCK 56 POINTER)
         (TCP.CONTROL.BLOCK 58 POINTER)
         (TCP.CONTROL.BLOCK 60 POINTER)
         (TCP.CONTROL.BLOCK 62 POINTER)
         (TCP.CONTROL.BLOCK 64 POINTER)
         (TCP.CONTROL.BLOCK 66 POINTER)
         (TCP.CONTROL.BLOCK 68 POINTER)
         (TCP.CONTROL.BLOCK 70 POINTER)
         (TCP.CONTROL.BLOCK 72 POINTER)
         (TCP.CONTROL.BLOCK 74 POINTER)
         (TCP.CONTROL.BLOCK 76 POINTER)
         (TCP.CONTROL.BLOCK 78 POINTER)
         (TCP.CONTROL.BLOCK 80 POINTER)
         (TCP.CONTROL.BLOCK 82 POINTER)
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 0))
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 16))
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 32))
         (TCP.CONTROL.BLOCK 82 (BITS . 52))
         (TCP.CONTROL.BLOCK 84 (BITS . 15))
         (TCP.CONTROL.BLOCK 85 (BITS . 15)))
       '86)

(* "END EXPORTED DEFINITIONS")

)

(/DECLAREDATATYPE 'TCP.CONTROL.BLOCK
       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
               POINTER POINTER WORD WORD FIXP POINTER POINTER FIXP FIXP FIXP FIXP FIXP FIXP WORD WORD
               FIXP FIXP FIXP POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
               POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG FLAG (BITS 5)
               WORD WORD)
       '((TCP.CONTROL.BLOCK 0 POINTER)
         (TCP.CONTROL.BLOCK 2 POINTER)
         (TCP.CONTROL.BLOCK 4 POINTER)
         (TCP.CONTROL.BLOCK 6 POINTER)
         (TCP.CONTROL.BLOCK 8 POINTER)
         (TCP.CONTROL.BLOCK 10 POINTER)
         (TCP.CONTROL.BLOCK 12 POINTER)
         (TCP.CONTROL.BLOCK 14 POINTER)
         (TCP.CONTROL.BLOCK 16 POINTER)
         (TCP.CONTROL.BLOCK 18 POINTER)
         (TCP.CONTROL.BLOCK 20 POINTER)
         (TCP.CONTROL.BLOCK 22 POINTER)
         (TCP.CONTROL.BLOCK 24 POINTER)
         (TCP.CONTROL.BLOCK 26 (BITS . 15))
         (TCP.CONTROL.BLOCK 27 (BITS . 15))
         (TCP.CONTROL.BLOCK 28 FIXP)
         (TCP.CONTROL.BLOCK 30 POINTER)
         (TCP.CONTROL.BLOCK 32 POINTER)
         (TCP.CONTROL.BLOCK 34 FIXP)
         (TCP.CONTROL.BLOCK 36 FIXP)
         (TCP.CONTROL.BLOCK 38 FIXP)
         (TCP.CONTROL.BLOCK 40 FIXP)
         (TCP.CONTROL.BLOCK 42 FIXP)
         (TCP.CONTROL.BLOCK 44 FIXP)
         (TCP.CONTROL.BLOCK 46 (BITS . 15))
         (TCP.CONTROL.BLOCK 47 (BITS . 15))
         (TCP.CONTROL.BLOCK 48 FIXP)
         (TCP.CONTROL.BLOCK 50 FIXP)
         (TCP.CONTROL.BLOCK 52 FIXP)
         (TCP.CONTROL.BLOCK 54 POINTER)
         (TCP.CONTROL.BLOCK 56 POINTER)
         (TCP.CONTROL.BLOCK 58 POINTER)
         (TCP.CONTROL.BLOCK 60 POINTER)
         (TCP.CONTROL.BLOCK 62 POINTER)
         (TCP.CONTROL.BLOCK 64 POINTER)
         (TCP.CONTROL.BLOCK 66 POINTER)
         (TCP.CONTROL.BLOCK 68 POINTER)
         (TCP.CONTROL.BLOCK 70 POINTER)
         (TCP.CONTROL.BLOCK 72 POINTER)
         (TCP.CONTROL.BLOCK 74 POINTER)
         (TCP.CONTROL.BLOCK 76 POINTER)
         (TCP.CONTROL.BLOCK 78 POINTER)
         (TCP.CONTROL.BLOCK 80 POINTER)
         (TCP.CONTROL.BLOCK 82 POINTER)
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 0))
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 16))
         (TCP.CONTROL.BLOCK 82 (FLAGBITS . 32))
         (TCP.CONTROL.BLOCK 82 (BITS . 52))
         (TCP.CONTROL.BLOCK 84 (BITS . 15))
         (TCP.CONTROL.BLOCK 85 (BITS . 15)))
       '86)



(* ;; "global lock for TCP-related mutual exclusion")


(RPAQ? \TCP.LOCK (CREATE.MONITORLOCK))



(* ;; "list of TCP control blocks for connection lookup")


(RPAQ? \TCP.CONTROL.BLOCKS NIL)
(DEFINEQ

(\TCP.CREATE.TCB
(LAMBDA (DST.HOST DST.PORT SRC.PORT MODE OUR.MAXSEG) (* ejs%: "27-May-86 14:39") (* create a new TCB and the input and output streams that go with it) (WITH.FAST.MONITOR \TCP.LOCK (PROG ((TCB (create TCP.CONTROL.BLOCK TCB.DST.HOST _ DST.HOST TCB.DST.PORT _ DST.PORT TCB.SRC.PORT _ (if (ZEROP SRC.PORT) then (\TCP.SELECT.PORT) else SRC.PORT) TCB.INPUT.QUEUE _ (create SYSQUEUE) TCB.REXMT.QUEUE _ (create SYSQUEUE) TCB.MODE _ MODE TCB.OUR.MAXSEG _ (OR OUR.MAXSEG \TCP.DEFAULT.MAXSEG)))) (replace (STREAM STRMBOUTFN) of (replace TCB.RCV.STREAM of TCB with (create TCPSTREAM ACCESS _ (QUOTE INPUT) TCB _ TCB BYTECOUNT _ 0)) with (FUNCTION \TCP.OTHER.BOUT)) (replace (STREAM STRMBINFN) of (replace TCB.SND.STREAM of TCB with (create TCPSTREAM ACCESS _ (QUOTE APPEND) TCB _ TCB BYTECOUNT _ 0)) with (FUNCTION \TCP.OTHER.BIN)) (\TCP.START.PROBE.TIMER TCB) (push \TCP.CONTROL.BLOCKS TCB) (* put it on the global list of TCBs so it can be found by \TCP.LOOKUP.TCB) (replace TCB.IPSOCKET of TCB with (\IP.OPEN.SOCKET \TCP.PROTOCOL TCB)) (* Tell IP about it) (RETURN TCB))))
)

(\TCP.SELECT.PORT
(LAMBDA NIL (* ecc " 7-May-84 17:23") (* find a port unique among all TCP connections on this host) (PROG ((PORT (LOGAND (DAYTIME) 65535))) (until (for TCB in \TCP.CONTROL.BLOCKS always (NEQ PORT (fetch TCB.SRC.PORT of TCB))) do (add PORT 1)) (RETURN PORT)))
)

(\TCP.LOOKUP.TCB
(LAMBDA (DST.HOST DST.PORT SRC.PORT NOWILDCARDFLG) (* ejs%: "21-Mar-86 18:40") (* Find a TCB that matches the specified addresses. If NOWILDCARDFLG is non-NIL we match against a partially specified TCB if no fully specified one was found.) (WITH.FAST.MONITOR \TCP.LOCK (bind WILDCARD for TCB in \TCP.CONTROL.BLOCKS do (if (EQ SRC.PORT (fetch TCB.SRC.PORT of TCB)) then (* only check further if the local ports match) (if (AND (IEQP DST.HOST (fetch TCB.DST.HOST of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB))) then (* a full match) (RETURN TCB) elseif (AND (NOT NOWILDCARDFLG) (NULL WILDCARD) (OR (ZEROP (fetch TCB.DST.HOST of TCB)) (IEQP DST.HOST (fetch TCB.DST.HOST of TCB))) (OR (ZEROP (fetch TCB.DST.PORT of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB)))) then (* a wildcard match) (SETQ WILDCARD TCB))) finally (RETURN (if NOWILDCARDFLG then NIL else WILDCARD)))))
)

(\TCP.DELETE.TCB
  [LAMBDA (TCB)                                          (* ; "Edited 25-Aug-88 18:39 by bvm")
    (WITH.FAST.MONITOR \TCP.LOCK (\TCP.TRACE.TRANSITION TCB 'CLOSED)
           (replace TCB.STATE of TCB with 'CLOSED)
           (\FLUSH.PACKET.QUEUE (fetch TCB.INPUT.QUEUE of TCB))
           (\FLUSH.PACKET.QUEUE (fetch TCB.REXMT.QUEUE of TCB))
           (SETQ \TCP.CONTROL.BLOCKS (DREMOVE TCB \TCP.CONTROL.BLOCKS))
           (\IP.CLOSE.SOCKET (fetch TCB.IPSOCKET of TCB)
                  \TCP.PROTOCOL T)
           (replace TCB.IPSOCKET of TCB with NIL)
           [LET [(WHENCLOSEDFN (PROCESSPROP (THIS.PROCESS)
                                      'WHENCLOSEDFN]
                (COND
                   (WHENCLOSEDFN (CL:FUNCALL WHENCLOSEDFN (fetch TCB.RCV.STREAM of TCB)
                                        (fetch TCB.SND.STREAM of TCB]
                                                             (* ; "break circular links")
           (replace TCB.SND.STREAM of TCB with NIL)
           (replace TCB.RCV.STREAM of TCB with NIL)
                                                             (* ; 
                                                       "wake up anyone waiting for events to occur")
           (NOTIFY.EVENT (fetch TCB.ESTABLISHED of TCB))
           (NOTIFY.EVENT (fetch TCB.SND.EVENT of TCB))
           (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB))
           (NOTIFY.EVENT (fetch TCB.URGENT.EVENT of TCB))
           (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB])

(\TCP.NOSOCKETFN
(LAMBDA (IP) (* ejs%: " 1-Feb-86 18:12") (* * Called when no TCP port corresponding to IP packet is found. We try again, allowing for wildcards) (LET* ((PROTOCOLCHAIN (\IP.FIND.PROTOCOL \TCP.PROTOCOL \IP.PROTOCOLS)) (IPSOCKET (fetch (IPSOCKET IPSLINK) of PROTOCOLCHAIN))) (while IPSOCKET do (COND ((\TCP.PORTCOMPARE IP IPSOCKET T) (APPLY* (ffetch (IPSOCKET IPSINPUTFN) of IPSOCKET) IP IPSOCKET) (RETURN)) (T (SETQ IPSOCKET (fetch (IPSOCKET IPSLINK) of IPSOCKET)))) finally (COND ((NOT (BITTEST (fetch TCP.CTRL of IP) \TCP.CTRL.RST)) (COND ((BITTEST (fetch TCP.CTRL of IP) \TCP.CTRL.ACK) (\TCP.SEND.RESET IP (fetch TCP.ACK of IP) 0 \TCP.CTRL.RST)) (T (\TCP.SEND.RESET IP 0 (IPLUS (fetch TCP.SEQ of IP) (fetch TCP.DATA.LENGTH of IP)) (LOGOR \TCP.CTRL.ACK \TCP.CTRL.RST))))) (T (\RELEASE.ETHERPACKET IP))))))
)

(\TCP.PORTCOMPARE
(LAMBDA (SEGMENT IPSOCKET WILDCARDFLG) (* ejs%: "13-Apr-85 17:44") (* Find a TCB that matches the specified addresses. If NOWILDCARDFLG is non-NIL we match against a partially specified TCB if no fully specified one was found.) (WITH.FAST.MONITOR \TCP.LOCK (PROG ((DST.HOST (fetch (TCPSEGMENT TCP.SRC.ADDR) of SEGMENT)) (DST.PORT (fetch (TCPSEGMENT TCP.SRC.PORT) of SEGMENT)) (SRC.PORT (fetch (TCPSEGMENT TCP.DST.PORT) of SEGMENT)) (TCB (fetch (IPSOCKET IPSOCKET) of IPSOCKET))) (COND ((AND TCB (EQ SRC.PORT (fetch TCB.SRC.PORT of TCB))) (* only check further if the local ports match) (COND ((AND (IEQP DST.HOST (fetch TCB.DST.HOST of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB))) (* a full match) (RETURN IPSOCKET)) ((AND WILDCARDFLG (OR (ZEROP (fetch TCB.DST.HOST of TCB)) (IEQP DST.HOST (fetch TCB.DST.HOST of TCB))) (OR (ZEROP (fetch TCB.DST.PORT of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB)))) (* a wildcard match) (RETURN IPSOCKET))))))))
)
)



(* ;; "TCP checksums")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(DATATYPE TCP.PSEUDOHEADER ((PH.SRC.ADDR FIXP)
                                (PH.DST.ADDR FIXP)
                                (NIL BYTE)
                                (PH.PROTOCOL BYTE)
                                (PH.LENGTH WORD))
                               PH.PROTOCOL _ \TCP.PROTOCOL)
)

(/DECLAREDATATYPE 'TCP.PSEUDOHEADER '(FIXP FIXP BYTE BYTE WORD)
       '((TCP.PSEUDOHEADER 0 FIXP)
         (TCP.PSEUDOHEADER 2 FIXP)
         (TCP.PSEUDOHEADER 4 (BITS . 7))
         (TCP.PSEUDOHEADER 4 (BITS . 135))
         (TCP.PSEUDOHEADER 5 (BITS . 15)))
       '6)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.PSEUDOHEADER.LENGTH 12)


(CONSTANTS \TCP.PSEUDOHEADER.LENGTH)
)

(DECLARE%: EVAL@COMPILE 

[PUTPROPS \16BIT.COMPLEMENT MACRO ((X)
                                   (LOGXOR X (MASK.1'S 0 16]

[PUTPROPS \16BIT.1C.PLUS MACRO ((X Y)

         (* compute the one's complement sum of X and Y without creating FIXP boxes --
       the sum modulo |2^16| plus an end-around carry)

                                (PROG ((DELTA (IDIFFERENCE MAX.SMALLP Y)))
                                      (RETURN (if (ILEQ X DELTA)
                                                  then (IPLUS X Y)
                                                else (IDIFFERENCE X DELTA]
)
)

(/DECLAREDATATYPE 'TCP.PSEUDOHEADER '(FIXP FIXP BYTE BYTE WORD)
       '((TCP.PSEUDOHEADER 0 FIXP)
         (TCP.PSEUDOHEADER 2 FIXP)
         (TCP.PSEUDOHEADER 4 (BITS . 7))
         (TCP.PSEUDOHEADER 4 (BITS . 135))
         (TCP.PSEUDOHEADER 5 (BITS . 15)))
       '6)

(RPAQ? \TCP.PSEUDOHEADER NIL)



(* ;; "this variable controls whether checksums are performed on incoming segments")


(RPAQ? \TCP.CHECKSUMS.ON NIL)



(* ;; "checksum routines")

(DEFINEQ

(\COMPUTE.CHECKSUM
(LAMBDA (BASE LENGTH DONTCOMPLEMENTFLG) (* ecc "25-May-84 18:47") (* TCP/IP protocol checksum is the 16-bit 1's complement of the 1's complement sum of the 16-bit words) (PROG ((CHECKSUM 0) (N (SUB1 (LRSH LENGTH 1)))) (for I from 0 to N do (SETQ CHECKSUM (\16BIT.1C.PLUS CHECKSUM (\GETBASE BASE I)))) (if (ODDP LENGTH) then (* if LENGTH is odd, the last byte must be padded on the right by a zero byte) (SETQ CHECKSUM (\16BIT.1C.PLUS CHECKSUM (LLSH (\GETBASEBYTE BASE (SUB1 LENGTH)) 8)))) (RETURN (if DONTCOMPLEMENTFLG then (* if DONTCOMPLEMENTFLG is non-NIL just return the 1's complement sum) CHECKSUM else (\16BIT.COMPLEMENT CHECKSUM)))))
)

(\TCP.CHECKSUM.INCOMING
(LAMBDA (SEGMENT) (* ecc "16-May-84 11:53") (* computes the TCP checksum and returns T or NIL depending on whether it matches the checksum in the header) (PROG ((LENGTH (IPLUS (fetch TCP.HEADER.LENGTH of SEGMENT) (\TCP.DATA.LENGTH SEGMENT))) (SEGMENT.CHECKSUM (fetch TCP.CHECKSUM of SEGMENT)) CHECKSUM OK) (WITH.FAST.MONITOR \TCP.LOCK (* need to lock this because we're using \TCP.PSEUDOHEADER) (replace PH.SRC.ADDR of \TCP.PSEUDOHEADER with (fetch TCP.SRC.ADDR of SEGMENT)) (replace PH.DST.ADDR of \TCP.PSEUDOHEADER with (fetch TCP.DST.ADDR of SEGMENT)) (replace PH.LENGTH of \TCP.PSEUDOHEADER with LENGTH) (replace TCP.CHECKSUM of SEGMENT with 0) (* checksum field must be 0 while we are computing checksum) (SETQ CHECKSUM (\16BIT.COMPLEMENT (\16BIT.1C.PLUS (\COMPUTE.CHECKSUM \TCP.PSEUDOHEADER \TCP.PSEUDOHEADER.LENGTH T) (\COMPUTE.CHECKSUM (fetch TCPHEADER of SEGMENT) LENGTH T))))) (SETQ OK (EQ CHECKSUM SEGMENT.CHECKSUM)) (if (AND (NOT OK) (MEMB (QUOTE CHECKSUM) TCPTRACEFLG)) then (printout TCPTRACEFILE .TAB0 0 "[bad checksum " CHECKSUM "]" T)) (RETURN OK)))
)

(\TCP.CHECKSUM.OUTGOING
(LAMBDA (TCB SEGMENT) (* ecc "16-May-84 11:53") (* compute checksum and place in header) (PROG ((LENGTH (IPLUS (fetch TCP.HEADER.LENGTH of SEGMENT) (\TCP.DATA.LENGTH SEGMENT))) (PH (if TCB then (fetch TCB.PH of TCB) else \TCP.PSEUDOHEADER))) (WITH.FAST.MONITOR \TCP.LOCK (* need to lock this in case we're using \TCP.PSEUDOHEADER) (replace PH.SRC.ADDR of PH with (fetch TCP.SRC.ADDR of SEGMENT)) (replace PH.DST.ADDR of PH with (fetch TCP.DST.ADDR of SEGMENT)) (replace PH.LENGTH of PH with LENGTH) (replace TCP.CHECKSUM of SEGMENT with 0) (* checksum field must be 0 while we are computing checksum) (replace TCP.CHECKSUM of SEGMENT with (\16BIT.COMPLEMENT (\16BIT.1C.PLUS (\COMPUTE.CHECKSUM PH \TCP.PSEUDOHEADER.LENGTH T) (\COMPUTE.CHECKSUM (fetch TCPHEADER of SEGMENT) LENGTH T)))))))
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.INITIAL.RTO 1000)


(CONSTANTS \TCP.INITIAL.RTO)
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.UBOUND 5000)

(RPAQQ \TCP.LBOUND 1000)


(CONSTANTS (\TCP.UBOUND 5000)
       (\TCP.LBOUND 1000))
)
)



(* ;; "maximum segment lifetime")


(RPAQ? \TCP.MSL 5000)

(RPAQ? \TCP.DEFAULT.USER.TIMEOUT 60000)

(RPAQ? \TCP.DEFAULT.RECEIVE.WINDOW 4096)

(RPAQ? \TCP.DEVICE NIL)



(* ;; "TCP protocol routines")

(DEFINEQ

(\TCP.ACK#
(LAMBDA (TCB) (* ejs%: " 7-Jun-85 13:18") (* * Returns the byte id for the next ACK) (* (LET* ((STREAM (fetch TCB.RCV.STREAM of TCB)) (BUFFER (fetch TCB.RCV.SEGMENT of TCB))) (COND (BUFFER (IPLUS (fetch TCP.SEQ of BUFFER) (fetch (STREAM COFFSET) of STREAM))) ((SETQ BUFFER (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))) (IMIN (fetch TCB.RCV.NXT of TCB) (fetch TCP.SEQ of BUFFER))) (T (fetch TCB.RCV.NXT of TCB))))) (fetch TCB.RCV.NXT of TCB))
)

(\TCP.PACKET.FILTER
(LAMBDA (SEGMENT PROTOCOL) (* ecc " 7-May-84 17:27") (* packet filter used by IP code to dispatch packets by protocol) (SELECTC PROTOCOL (\TCP.PROTOCOL (ERSETQ (\TCP.INPUT SEGMENT)) T) (\ICMP.PROTOCOL (ERSETQ (\TCP.HANDLE.ICMP SEGMENT)) T) NIL))
)

(\TCP.SETUP.SEGMENT
(LAMBDA (SRC.HOST SRC.PORT DST.HOST DST.PORT) (* ejs%: " 1-Jan-01 10:28") (* allocate a new TCP segment and set up its header) (PROG ((SEGMENT (\IP.SETUPIP (\ALLOCATE.ETHERPACKET) DST.HOST NIL \TCP.MASTER.SOCKET (QUOTE FREE)))) (add (fetch (IP IPTOTALLENGTH) of SEGMENT) \TCP.HEADER.LENGTH) (replace TCP.SRC.PORT of SEGMENT with SRC.PORT) (replace TCP.DST.PORT of SEGMENT with DST.PORT) (replace TCP.DATA.OFFSET of SEGMENT with \TCP.MIN.DATA.OFFSET) (replace TCP.MBZ of SEGMENT with 0) (RETURN SEGMENT)))
)

(\TCP.RELEASE.SEGMENT
(LAMBDA (SEGMENT) (* ecc " 7-May-84 17:28") (* release a TCP segment -- it had better not be on anyone's queue) (CHECK (OR (NULL (fetch QLINK of SEGMENT)) (SHOULDNT "releasing queued segment"))) (\RELEASE.ETHERPACKET SEGMENT))
)

(\TCP.CONNECTION
(LAMBDA (DST.HOST DST.PORT SRC.PORT MODE OPTIONS) (* ; "Edited 23-May-88 19:14 by Snow") (* ;; "open a TCP connection and return the TCB or NIL if the connection fails") (PROG (SPECIFIED TCB ISS TCP.PROCESS) (SELECTQ MODE (ACTIVE) (PASSIVE) (ERROR "TCP open mode must be ACTIVE or PASSIVE")) (if (NULL DST.HOST) then (SETQ DST.HOST 0)) (if (NULL DST.PORT) then (SETQ DST.PORT 0)) (if (NULL SRC.PORT) then (SETQ SRC.PORT 0)) (SETQ SPECIFIED (NOT (OR (ZEROP DST.HOST) (ZEROP DST.PORT)))) (if (AND (EQ MODE (QUOTE ACTIVE)) (NOT SPECIFIED)) then (ERROR "foreign socket unspecified")) (* ;; "Check for conflict with existing connections.  ACTIVE open only conflicts with other fully specified connections.  PASSIVE open conflicts with fully specified connections if the open is fully specifed, and with partially specified connections if the open is partially specified") (if (SETQ TCB (OR (AND (OR (EQ MODE (QUOTE ACTIVE)) SPECIFIED) (\TCP.LOOKUP.TCB DST.HOST DST.PORT SRC.PORT T)) (AND (EQ MODE (QUOTE PASSIVE)) (NOT SPECIFIED) (SETQ TCB (\TCP.LOOKUP.TCB DST.HOST DST.PORT SRC.PORT NIL)) (OR (ZEROP (fetch TCB.DST.HOST of TCB)) (ZEROP (fetch TCB.DST.PORT of TCB))) TCB))) then (COND ((type? TCP.CONTROL.BLOCK TCB) (COND ((FMEMB (fetch TCB.STATE of TCB) (QUOTE (CLOSED CLOSE.WAIT TIME.WAIT FIN.WAIT.1 FIN.WAIT.2))) (\TCP.DELETE.TCB TCB)) (T (ERROR "TCP connection already exists")))) (T (ERROR "TCP connection already exists")))) (SETQ TCB (\TCP.CREATE.TCB DST.HOST DST.PORT SRC.PORT MODE (OR (LISTGET OPTIONS (QUOTE MAXSEG)) \TCP.DEFAULT.MAXSEG))) (replace TCB.NO.IDLE.PROBING of TCB with (LISTGET OPTIONS (QUOTE NO.IDLE.PROBING))) (SELECTQ MODE (ACTIVE (WITH.MONITOR \TCP.LOCK (SETQ ISS (\TCP.SELECT.ISS)) (replace TCB.ISS of TCB with ISS)) (\TCP.TEMPLATE TCB (COND ((LISTGET OPTIONS (QUOTE MAXSEG)) OPTIONS) (T (APPEND OPTIONS (BQUOTE (MAXSEG %, \TCP.DEFAULT.MAXSEG)))))) (replace TCB.SND.UNA of TCB with ISS) (replace TCB.SND.NXT of TCB with ISS) (replace TCB.SND.UP of TCB with ISS) (\TCP.TRACE.TRANSITION TCB (QUOTE SYN.SENT)) (replace TCB.STATE of TCB with (QUOTE SYN.SENT)) (SETQ TCP.PROCESS (ADD.PROCESS (BQUOTE (\TCP.PROCESS %, TCB)) (QUOTE NAME) (QUOTE TCP) (QUOTE WHENCLOSEDFN) (LISTGET OPTIONS (QUOTE WHENCLOSEDFN)))) (* ; "initiate the three-way handshake to establish the connection") (\TCP.FLUSH (fetch TCB.SND.STREAM of TCB) \TCP.CTRL.SYN) (* ; "wait until established") (WITH.MONITOR (fetch TCB.LOCK of TCB) (RESETLST (RESETSAVE NIL (BQUOTE (AND RESETSTATE (DEL.PROCESS %, TCP.PROCESS)))) (until (NEQ (fetch TCB.STATE of TCB) (QUOTE SYN.SENT)) do (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.ESTABLISHED of TCB)))))) (PASSIVE (\TCP.TRACE.TRANSITION TCB (QUOTE LISTEN)) (replace TCB.STATE of TCB with (QUOTE LISTEN)) (SETQ TCP.PROCESS (ADD.PROCESS (BQUOTE (\TCP.PROCESS %, TCB)) (QUOTE NAME) (QUOTE TCP) (QUOTE WHENCLOSEDFN) (LISTGET OPTIONS (QUOTE WHENCLOSEDFN)))) (* ; "wait until established") (WITH.MONITOR (fetch TCB.LOCK of TCB) (RESETLST (RESETSAVE NIL (BQUOTE (AND RESETSTATE (DEL.PROCESS %, TCP.PROCESS)))) (until (NEQ (fetch TCB.STATE of TCB) (QUOTE LISTEN)) do (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.ESTABLISHED of TCB)))))) (SHOULDNT)) (RETURN (if (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) then TCB else NIL))))
)

(\TCP.FIX.INCOMING.SEGMENT
(LAMBDA (SEGMENT FLAGS) (* ecc "16-May-84 11:56") (PROG NIL (if (AND (BITTEST FLAGS \TCP.CTRL.SYN) (BITTEST FLAGS \TCP.CTRL.FIN)) then (RETURN NIL)) (* calculate the length of the segment data and place it in a fixed position in the header for fast access -- note that the TCP.DATA.LENGTH field isn't a true part of the TCP header; it overlays the IP level checksum which is no longer needed) (replace TCP.DATA.LENGTH of SEGMENT with (\TCP.DATA.LENGTH SEGMENT)) (* return T or NIL depending on whether checksum is correct) (RETURN (OR (NOT \TCP.CHECKSUMS.ON) (\TCP.CHECKSUM.INCOMING SEGMENT)))))
)

(\TCP.DATA.LENGTH
(LAMBDA (SEGMENT) (* ejs%: "21-Jun-85 17:04") (* data length = total segment length - (IP header length + TCP header length)) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of SEGMENT) (IPLUS (UNFOLD (fetch (IP IPHEADERLENGTH) of SEGMENT) BYTESPERCELL) (UNFOLD (fetch TCP.DATA.OFFSET of SEGMENT) BYTESPERCELL))))
)

(\TCP.SYN.OR.FIN
(LAMBDA (FLAGS NOERRORFLG) (* ecc " 1-May-84 17:10") (* SYN and FIN occupy sequence number space so we have to include them in the "length" of the segment) (SELECTC (LOGAND FLAGS (LOGOR \TCP.CTRL.SYN \TCP.CTRL.FIN)) (0 0) (\TCP.CTRL.SYN 1) (\TCP.CTRL.FIN 1) (if NOERRORFLG then 0 else (SHOULDNT "both SYN and FIN"))))
)

(\TCP.INPUT
(LAMBDA (SEGMENT TCB) (* ejs%: "20-Jun-85 13:06") (* handle an incoming TCP segment -- pages |65-76| of RFC 793) (PROG ((SEQ (fetch TCP.SEQ of SEGMENT)) (ACK (fetch TCP.ACK of SEGMENT)) (FLAGS (fetch TCP.CTRL of SEGMENT)) UNA QUEUEDFLG) (if (NOT (\TCP.INPUT.INITIAL TCB SEGMENT SEQ ACK FLAGS)) then (\TCP.RELEASE.SEGMENT SEGMENT) (RETURN)) (WITH.MONITOR (fetch TCB.LOCK of TCB) (PROG NIL (* handle unsynchronized states) (if (NOT (\TCP.INPUT.UNSYNC TCB SEGMENT SEQ ACK FLAGS)) then (GO DROPIT)) (* first check sequence number) (if (NOT (\TCP.CHECK.WINDOW TCB SEGMENT FLAGS)) then (GO DROPIT)) (* second check the RST bit) (if (NOT (\TCP.CHECK.RESET TCB SEGMENT SEQ ACK FLAGS)) then (GO DROPIT)) (* third check security and precedence) (if (NOT (\TCP.CHECK.SECURITY TCB SEGMENT FLAGS)) then (GO DROPIT)) (* fourth check the SYN bit) (if (NOT (\TCP.CHECK.NO.SYN TCB SEGMENT FLAGS)) then (GO DROPIT)) (if (NOT (\TCP.CHECK.OPTIONS TCB SEGMENT FLAGS)) then (GO DROPIT)) (* fifth check the ACK field) (if (NOT (\TCP.CHECK.ACK TCB SEGMENT FLAGS)) then (GO DROPIT)) (if (EQ (fetch TCB.STATE of TCB) (QUOTE SYN.RECEIVED)) then (if (AND (\32BIT.LEQ (fetch TCB.SND.UNA of TCB) ACK) (\32BIT.LEQ ACK (fetch TCB.SND.NXT of TCB))) then (* our SYN has been acked) (\TCP.TRACE.TRANSITION TCB (QUOTE ESTABLISHED)) (replace TCB.STATE of TCB with (QUOTE ESTABLISHED)) (replace TCB.DST.HOST of TCB with (fetch (TCPSEGMENT TCP.SRC.ADDR) of SEGMENT)) (replace TCB.DST.PORT of TCB with (fetch (TCPSEGMENT TCP.SRC.PORT) of SEGMENT)) (NOTIFY.EVENT (fetch TCB.ESTABLISHED of TCB)) (* continue processing in ESTABLISHED state) else (\TCP.SEND.CONTROL TCB ACK NIL \TCP.CTRL.RST) (GO DROPIT))) (if (NOT (\TCP.HANDLE.ACK TCB SEGMENT SEQ ACK FLAGS)) then (GO DROPIT)) (SELECTQ (fetch TCB.STATE of TCB) (FIN.WAIT.1 (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.TRACE.TRANSITION TCB (QUOTE FIN.WAIT.2)) (replace TCB.STATE of TCB with (QUOTE FIN.WAIT.2)) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)))) ((ESTABLISHED FIN.WAIT.2 CLOSE.WAIT) NIL) (CLOSING (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.START.TIME.WAIT TCB) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)) else (GO DROPIT))) (LAST.ACK (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED)) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)) (RETURN) else (GO DROPIT))) (TIME.WAIT (\TCP.SEND.ACK TCB) (GO DROPIT)) (SHOULDNT)) (* sixth check the URG bit) (\TCP.HANDLE.URG TCB SEGMENT SEQ ACK FLAGS) (* seventh process the segment text) (SELECTQ (fetch TCB.STATE of TCB) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2) (SETQ QUEUEDFLG (\TCP.QUEUE.INPUT TCB SEGMENT SEQ))) ((CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT)) (SHOULDNT)) (* eighth check the FIN bit) (\TCP.HANDLE.FIN TCB SEGMENT SEQ ACK FLAGS) (if QUEUEDFLG then (RETURN)) DROPIT (\TCP.RELEASE.SEGMENT SEGMENT)))))
)

(\TCP.INPUT.INITIAL
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 17:27") (* handle segment for non-existent TCB -- page 65 of RFC 793) (PROG NIL (\TCP.TRACE.SEGMENT (QUOTE RECV) SEGMENT) (if (NOT (\TCP.FIX.INCOMING.SEGMENT SEGMENT FLAGS)) then (* bad checksum) (RETURN NIL)) (if (OR (NULL TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED))) then (* an incoming segment not containing a RST causes a RST to be sent in response) (if TCPTRACEFLG then (printout TCPTRACEFILE .TAB0 0 "[no such TCP connection]")) (if (NOT (BITTEST FLAGS \TCP.CTRL.RST)) then (* send a RST) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (\TCP.SEND.RESET SEGMENT ACK) else (\TCP.SEND.RESET SEGMENT 0 (IPLUS SEQ (fetch TCP.DATA.LENGTH of SEGMENT) (\TCP.SYN.OR.FIN FLAGS))))) (RETURN NIL)) (RETURN T)))
)

(\TCP.INPUT.UNSYNC
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "21-Mar-86 20:03") (* handle segment for TCB in LISTEN or SYN.SENT state -- pages |65-68| of RFC 793) (SELECTQ (fetch TCB.STATE of TCB) (LISTEN (\TCP.INPUT.LISTEN TCB SEGMENT SEQ ACK FLAGS) NIL) (SYN.SENT (\TCP.INPUT.SYN.SENT TCB SEGMENT SEQ ACK FLAGS) (\TCP.CHECK.OPTIONS TCB SEGMENT FLAGS) NIL) T))
)

(\TCP.INPUT.LISTEN
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "22-Jun-85 03:14") (* handle segment for TCB in LISTEN state -- pages |65-66| of RFC 793) (PROG (ISS) (* first check for a RST) (if (BITTEST FLAGS \TCP.CTRL.RST) then (RETURN NIL)) (* second check for an ACK) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (* any acknowledgment is bad if it arrives on a connection still in the LISTEN state) (\TCP.SEND.RESET SEGMENT ACK) (RETURN NIL)) (* third check for a SYN) (if (BITTEST FLAGS \TCP.CTRL.SYN) then (if (NOT (\TCP.CHECK.SECURITY TCB SEGMENT FLAGS)) then (RETURN NIL)) (replace TCB.RCV.NXT of TCB with (ADD1 SEQ)) (replace TCB.IRS of TCB with SEQ) (SETQ ISS (\TCP.SELECT.ISS)) (replace TCB.ISS of TCB with ISS) (replace TCB.SND.NXT of TCB with ISS) (replace TCB.SND.UNA of TCB with ISS) (replace TCB.SND.UP of TCB with ISS) (\TCP.TRACE.TRANSITION TCB (QUOTE SYN.RECEIVED)) (replace TCB.STATE of TCB with (QUOTE SYN.RECEIVED)) (* fill in foreign socket in case it was only partially specified) (replace TCB.DST.HOST of TCB with (fetch TCP.SRC.ADDR of SEGMENT)) (replace TCB.DST.PORT of TCB with (fetch TCP.SRC.PORT of SEGMENT)) (\TCP.TEMPLATE TCB) (* send a SYN, ACK segment using \TCP.FLUSH because SYN occupies sequence number space) (\TCP.FLUSH (fetch TCB.SND.STREAM of TCB) \TCP.CTRL.SYN) (* NOTE%: we never queue data that arrives in a SYN segment, we just ACK the SYN and require the data to be retransmitted)) (RETURN NIL)))
)

(\TCP.INPUT.SYN.SENT
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 12:13") (* handle segment for TCB in SYN.SENT state -- pages |66-68| of RFC 793) (PROG NIL (* first check the ACK bit) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (if (OR (\32BIT.LEQ ACK (fetch TCB.ISS of TCB)) (\32BIT.GT ACK (fetch TCB.SND.NXT of TCB))) then (* ACK is unacceptable) (if (NOT (BITTEST FLAGS \TCP.CTRL.RST)) then (\TCP.SEND.CONTROL TCB ACK NIL \TCP.CTRL.RST)) (RETURN NIL))) (* second check the RST bit) (if (BITTEST FLAGS \TCP.CTRL.RST) then (if (BITTEST FLAGS \TCP.CTRL.ACK) then (* if the ACK was acceptable then signal the user) (\TCP.CONNECTION.DROPPED TCB "reset")) (RETURN NIL)) (* third check the security and precedence) (if (NOT (\TCP.CHECK.SECURITY TCB SEGMENT FLAGS)) then (RETURN NIL)) (* fourth check the SYN bit) (if (BITTEST FLAGS \TCP.CTRL.SYN) then (replace TCB.RCV.NXT of TCB with (ADD1 SEQ)) (replace TCB.IRS of TCB with SEQ) (if (AND (BITTEST FLAGS \TCP.CTRL.ACK) (\32BIT.GEQ ACK (fetch TCB.SND.UNA of TCB))) then (* new ACK information) (replace TCB.SND.UNA of TCB with ACK)) (replace TCP.CTRL of SEGMENT with (SETQ FLAGS (BITCLEAR FLAGS \TCP.CTRL.SYN))) (if (\32BIT.GT (fetch TCB.SND.UNA of TCB) (fetch TCB.ISS of TCB)) then (* our SYN has been acked) (\TCP.TRACE.TRANSITION TCB (QUOTE ESTABLISHED)) (replace TCB.STATE of TCB with (QUOTE ESTABLISHED)) (* send an ACK segment) (\TCP.SEND.ACK TCB (QUOTE NOW)) (NOTIFY.EVENT (fetch TCB.ESTABLISHED of TCB)) else (* we can just let our original SYN segment be retransmitted) (\TCP.TRACE.TRANSITION TCB (QUOTE SYN.RECEIVED)) (replace TCB.STATE of TCB with (QUOTE SYN.RECEIVED)) (* send an ACK segment) (\TCP.SEND.ACK TCB (QUOTE NOW))) (* NOTE%: we never queue data that arrives in a SYN segment, we just ACK the SYN and require the data to be retransmitted)) (* drop the segment and return) (RETURN NIL)))
)

(\TCP.CHECK.WINDOW
(LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 16:29") (* check segment length against receive window -- page 69 of RFC 793) (PROG ((LEN (fetch TCP.DATA.LENGTH of SEGMENT)) (SEQ (fetch TCP.SEQ of SEGMENT)) (RCV.NXT (fetch TCB.RCV.NXT of TCB)) (WND (fetch TCB.RCV.WND of TCB)) TOP) (SETQ TOP (IPLUS SEQ LEN (\TCP.SYN.OR.FIN FLAGS))) (if (ZEROP LEN) then (if (ZEROP WND) then (if (\32BIT.EQ SEQ RCV.NXT) then (RETURN T)) else (if (AND (\32BIT.LEQ RCV.NXT SEQ) (\32BIT.LT SEQ (IPLUS RCV.NXT WND))) then (RETURN T))) else (if (NOT (ZEROP WND)) then (if (OR (AND (\32BIT.LEQ RCV.NXT SEQ) (\32BIT.LT SEQ (IPLUS RCV.NXT WND))) (AND (\32BIT.LT RCV.NXT TOP) (\32BIT.LEQ TOP (IPLUS RCV.NXT WND)))) then (RETURN T)))) (if (NOT (BITTEST FLAGS \TCP.CTRL.RST)) then (* send an ACK in reply) (\TCP.SEND.ACK TCB (QUOTE NOW))) (RETURN NIL)))
)

(\TCP.CHECK.RESET
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 12:07") (* check the RST bit -- page 70 of RFC 793) (PROG NIL (if (BITTEST FLAGS \TCP.CTRL.RST) then (SELECTQ (fetch TCB.STATE of TCB) (SYN.RECEIVED (if (EQ (fetch TCB.MODE of TCB) (QUOTE PASSIVE)) then (\TCP.TRACE.TRANSITION TCB (QUOTE LISTEN)) (replace TCB.STATE of TCB with (QUOTE LISTEN)) else (\TCP.CONNECTION.DROPPED TCB "refused")) (\FLUSH.PACKET.QUEUE (fetch TCB.REXMT.QUEUE of TCB)) (\TCP.SEND.CONTROL TCB ACK NIL \TCP.CTRL.RST)) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2 CLOSE.WAIT) (\TCP.CONNECTION.DROPPED TCB "reset")) ((CLOSING LAST.ACK TIME.WAIT) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED))) (SHOULDNT)) (RETURN NIL) else (RETURN T))))
)

(\TCP.CHECK.SECURITY
(LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 12:06") (* returns T or NIL depending on whether security and precedence are OK; sends RST if necessary) (* not implemented) T)
)

(\TCP.CHECK.NO.SYN
(LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 12:07") (* check the SYN bit -- page 71 of RFC 793) (PROG NIL (CHECK (OR (NOT (BITTEST FLAGS \TCP.CTRL.RST)) (SHOULDNT "RST bit set"))) (if (NOT (BITTEST FLAGS \TCP.CTRL.SYN)) then (RETURN T)) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (\TCP.SEND.CONTROL TCB (fetch TCP.ACK of SEGMENT) NIL \TCP.CTRL.RST) else (\TCP.SEND.CONTROL TCB 0 (IPLUS (fetch TCP.ACK of SEGMENT) (fetch TCP.DATA.LENGTH of SEGMENT) 1) (LOGOR \TCP.CTRL.ACK \TCP.CTRL.RST))) (\TCP.CONNECTION.DROPPED TCB "reset") (RETURN NIL)))
)

(\TCP.CHECK.ACK
(LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 12:08") (* check the ACK field -- page 72 of RFC 793) (PROG NIL (CHECK (OR (NOT (BITTEST FLAGS (LOGOR \TCP.CTRL.SYN \TCP.CTRL.RST))) (SHOULDNT "SYN or RST bit set"))) (RETURN (BITTEST FLAGS \TCP.CTRL.ACK))))
)

(\TCP.HANDLE.ACK
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "22-Jun-85 00:35") (* ACK processing -- pages |72-73| of RFC 793) (PROG (EVENT) (if (\32BIT.GT ACK (fetch TCB.SND.NXT of TCB)) then (* this segment acks something we haven't sent yet) (\TCP.SEND.ACK TCB (QUOTE NOW)) (RETURN NIL)) (if (AND (fetch TCB.RTFLG of TCB) (\32BIT.GT ACK (fetch TCB.RTSEQ of TCB))) then (* calculate smoothed round trip time) (replace TCB.RTFLG of TCB with NIL) (replace TCB.SRTT of TCB with (FOLDLO (PLUS (ITIMES 7 (fetch TCB.SRTT of TCB)) (CLOCKDIFFERENCE (fetch TCB.RTTIMER of TCB))) 8)) (replace TCB.RTTIMER of TCB with (SETUPTIMER 0 (fetch TCB.RTTIMER of TCB))) (replace TCB.RTO of TCB with (IMIN \TCP.UBOUND (IMAX \TCP.LBOUND (FOLDLO (ITIMES 3 (fetch TCB.SRTT of TCB)) 2))))) (if (\32BIT.GT ACK (fetch TCB.SND.UNA of TCB)) then (* new ACK information) (replace TCB.SND.UNA of TCB with ACK) (SETQ EVENT T)) (if (OR (\32BIT.GT SEQ (fetch TCB.SND.WL1 of TCB)) (AND (\32BIT.EQ SEQ (fetch TCB.SND.WL1 of TCB)) (\32BIT.GEQ ACK (fetch TCB.SND.WL2 of TCB)))) then (* update send window) (replace TCB.SND.WND of TCB with (fetch TCP.WINDOW of SEGMENT)) (replace TCB.SND.WL1 of TCB with SEQ) (replace TCB.SND.WL2 of TCB with ACK) (SETQ EVENT T)) (if EVENT then (NOTIFY.EVENT (fetch TCB.SND.EVENT of TCB))) (RETURN T)))
)

(\TCP.HANDLE.URG
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 12:10") (* check the URG bit -- pages |73-74| of RFC 793) (PROG (UP) (if (BITTEST FLAGS \TCP.CTRL.URG) then (SELECTQ (fetch TCB.STATE of TCB) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2) (SETQ UP (IPLUS SEQ (fetch TCP.URG.PTR of SEGMENT))) (if (\32BIT.GT UP (fetch TCB.RCV.UP of TCB)) then (replace TCB.RCV.UP of TCB with UP) (if (\32BIT.GT UP (fetch TCB.RCV.NXT of TCB)) then (* urgent pointer is in advance of the data consumed) (\TCP.SIGNAL.URGENT.DATA TCB)))) ((CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT) NIL) (SHOULDNT)))))
)

(\TCP.QUEUE.INPUT
(LAMBDA (TCB SEGMENT SEQ) (* ejs%: "18-Dec-86 17:39") (* Put the segment in its proper position in the input queue according to its sequence number range. Returns T if the segment was queued, NIL if it was a duplicate. Segments are queued by increasing left endpoint of their sequence number range. If the entire sequence number range has been seen or is covered by segments already in the queue, the segment is a duplicate. Otherwise, it covers some gap in the queue, so it is placed in its proper position. Note that a later segment that covers gaps on both sides will also be queued, resulting in duplicates in the queue. Therefore \TCP.GET.SEGMENT must be prepared to skip over duplicates.) (CHECK (OR (NULL (fetch QLINK of SEGMENT)) (SHOULDNT "input segment already queued"))) (CHECK (\TCP.CHECK.INPUT.QUEUE TCB)) (UNINTERRUPTABLY (PROG ((QUEUE (fetch TCB.INPUT.QUEUE of TCB)) (RCV.NXT (fetch TCB.RCV.NXT of TCB)) (LEN (fetch TCP.DATA.LENGTH of SEGMENT)) (FLAGS (fetch TCP.CTRL of SEGMENT)) TOP CURRENT CURSEQ NEXT) (if (EQ 0 LEN) then (* this segment has no data) (GO DROPITANDPROBE)) (SETQ TOP (IPLUS SEQ LEN)) (if (\32BIT.LEQ TOP RCV.NXT) then (* this segment is a duplicate) (GO DROPITANDPROBE)) (SETQ CURRENT (fetch SYSQUEUEHEAD of QUEUE)) (SETQ NEXT (fetch SYSQUEUETAIL of QUEUE)) (if (OR (NULL CURRENT) (\32BIT.GEQ SEQ (fetch TCP.SEQ of NEXT))) then (* the segment goes at the tail of the queue -- we check this first since this is the expected case) (\ENQUEUE QUEUE SEGMENT) elseif (\32BIT.LT SEQ (SETQ CURSEQ (fetch TCP.SEQ of CURRENT))) then (* the segment goes at the head of the queue) (replace QLINK of SEGMENT with CURRENT) (replace SYSQUEUEHEAD of QUEUE with SEGMENT) else (* * Search for this segment's proper position in the queue. The invariant upon entering this loop is%: segment.seq >= current.seq) (do (if (\32BIT.LEQ TOP (IPLUS CURSEQ (fetch TCP.DATA.LENGTH of CURRENT))) then (* * segment.seq <= current.seq + current.length. The packet is totally subsumed by a previously received packet, and thus, is a duplicate and is dropped) (GO DROPITANDPROBE)) (SETQ NEXT (fetch QLINK of CURRENT)) (SETQ CURSEQ (fetch TCP.SEQ of NEXT)) (if (\32BIT.LT SEQ CURSEQ) then (* * current.seq <= segment.seq < next.seq. Insert the segment between current and next) (replace QLINK of SEGMENT with NEXT) (replace QLINK of CURRENT with SEGMENT) (RETURN)) (SETQ CURRENT NEXT))) (* * Note that we have a zero window allocation at this point. When we free up the window (in \TCP.GET.SEGMENT) %, we'll know to send a gratuitous ACK to our partner to let it know the window's once again open.) (replace TCB.RCV.WND of TCB with (IMAX 0 (IDIFFERENCE (fetch TCB.RCV.WND of TCB) LEN))) (replace TCB.LAST.SENT.RCV.WND of TCB with (IMAX 0 (IDIFFERENCE (fetch TCB.LAST.SENT.RCV.WND of TCB) LEN))) (COND ((OR (EQ 0 (fetch TCB.LAST.SENT.RCV.WND of TCB)) (EQ 0 (fetch TCB.RCV.WND of TCB))) (replace TCB.SENT.ZERO of TCB with T))) (while (AND (\32BIT.LEQ SEQ RCV.NXT) (\32BIT.LT RCV.NXT TOP)) do (* advance RCV.NXT) (replace TCB.RCV.NXT of TCB with (SETQ RCV.NXT TOP)) (if (SETQ SEGMENT (fetch QLINK of SEGMENT)) then (SETQ TOP (IPLUS (SETQ SEQ (fetch TCP.SEQ of SEGMENT)) (fetch TCP.DATA.LENGTH of SEGMENT))))) (if (BITTEST FLAGS \TCP.CTRL.PSH) then (\TCP.SEND.ACK TCB (QUOTE NOW)) else (\TCP.SEND.ACK TCB)) (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB)) (RETURN T) DROPITANDPROBE (* * Here when we think we should let the other side know immediately about our condition (e.g. a duplicate packet was received)) (\TCP.SEND.ACK TCB (QUOTE NOW)) DROPIT (* * Here when we have nothing to do, but it's not worth informing our TCP partner) (RETURN NIL))))
)

(\TCP.HANDLE.FIN
(LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "11-Aug-86 22:29") (* check the FIN bit -- pages |75-76| of RFC 793) (PROG (TOP) (if (BITTEST FLAGS \TCP.CTRL.FIN) then (SETQ TOP (IPLUS SEQ (fetch TCP.DATA.LENGTH of SEGMENT))) (* check whether we've received all the data before the FIN) (if (\32BIT.GEQ (fetch TCB.RCV.NXT of TCB) TOP) then (if (\32BIT.EQ (fetch TCB.RCV.NXT of TCB) TOP) then (* advance RCV.NXT over the FIN) (add (fetch TCB.RCV.NXT of TCB) 1)) (SELECTQ (fetch TCB.STATE of TCB) ((SYN.RECEIVED ESTABLISHED) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSE.WAIT)) (replace TCB.STATE of TCB with (QUOTE CLOSE.WAIT))) (FIN.WAIT.1 (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.START.TIME.WAIT TCB) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)) else (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSING)) (replace TCB.STATE of TCB with (QUOTE CLOSING)))) (FIN.WAIT.2 (\TCP.START.TIME.WAIT TCB)) ((CLOSE.WAIT CLOSING LAST.ACK) NIL) (TIME.WAIT (\TCP.START.TIME.WAIT TCB)) (SHOULDNT)) (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB))) (* acknowledge the FIN) (\TCP.SEND.ACK TCB (QUOTE NOW)))))
)

(\TCP.OUR.FIN.IS.ACKED
(LAMBDA (TCB) (* ecc "16-May-84 12:15") (* check whether our FIN's sequence number (recorded in the TCB.FINSEQ field) has been acknowledged) (\32BIT.GEQ (fetch TCB.SND.UNA of TCB) (OR (fetch TCB.FINSEQ of TCB) (SHOULDNT "FIN not sent"))))
)

(\TCP.SIGNAL.URGENT.DATA
(LAMBDA (TCB) (* ecc " 7-May-84 12:19") (NOTIFY.EVENT (fetch TCB.URGENT.EVENT of TCB)) (if TCPTRACEFLG then (printout TCPTRACEFILE .TAB0 0 "[Urgent TCP data has arrived]" T)))
)

(\TCP.PROCESS
(LAMBDA (TCB) (* ejs%: "11-Aug-86 21:57") (* process to handle retransmission and timeouts for TCP connection) (RESETSAVE NIL (LIST (FUNCTION \TCP.DELETE.TCB) TCB)) (PROCESSPROP (THIS.PROCESS) (QUOTE INFOHOOK) (FUNCTION (LAMBDA NIL (PPTCB TCB)))) (replace TCB.PROCESS of TCB with (THIS.PROCESS)) (WITH.MONITOR (fetch TCB.LOCK of TCB) (bind SEGMENT PACKETQUEUE REXMTQUEUE EVENT (IPSOCKET _ (fetch TCB.IPSOCKET of TCB)) first (SETQ PACKETQUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)) (SETQ REXMTQUEUE (fetch TCB.REXMT.QUEUE of TCB)) (SETQ EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET)) while (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) do (COND ((AND (fetch TCB.RTFLG of TCB) (fetch TCB.PROBE.TIMER of TCB) (IGREATERP (CLOCKDIFFERENCE (fetch TCB.RTTIMER of TCB)) (fetch TCB.USER.TIMEOUT of TCB))) (* timeout has expired without other end responding) (\TCP.CONNECTION.DROPPED TCB "not responding")) ((AND (EQ (fetch TCB.STATE of TCB) (QUOTE TIME.WAIT)) (TIMEREXPIRED? (fetch TCB.2MSL.TIMER of TCB))) (* 2MSL has expired) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED))) ((\TCP.RETRANSMIT TCB) NIL) ((OR (EQ (fetch TCB.ACKFLG of TCB) (QUOTE NOW)) (AND (EQ (fetch TCB.STATE of TCB) (QUOTE ESTABLISHED)) (fetch TCB.PROBE.TIMER of TCB) (TIMEREXPIRED? (fetch TCB.PROBE.TIMER of TCB))) (AND (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB)) (\32BIT.GT (fetch TCP.SEQ of (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))) (fetch TCB.RCV.NXT of TCB)))) (* an ACK needs to be sent either because the protocol routines requested it or because we need to fill a gap in the input queue) (\TCP.SEND.CONTROL TCB (fetch TCB.SND.NXT of TCB) (\TCP.ACK# TCB) \TCP.CTRL.ACK)) ((AND (\32BIT.GT (fetch TCB.SND.NXT of TCB) (IPLUS (fetch TCB.SND.WL1 of TCB) (fetch TCB.SND.WND of TCB))) (fetch TCB.PROBE.TIMER of TCB) (TIMEREXPIRED? (fetch TCB.PROBE.TIMER of TCB))) (* a probe needs to be sent to open the window) (\TCP.SEND.CONTROL TCB (IPLUS (fetch TCB.SND.NXT of TCB) (fetch TCB.SND.WND of TCB)) (\TCP.ACK# TCB) \TCP.CTRL.ACK))) (COND ((SETQ SEGMENT (\DEQUEUE PACKETQUEUE)) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) -1) (\TCP.INPUT SEGMENT TCB)) (T (COND ((EQ (COND ((OR (fetch TCB.OUTPUT.HELD of TCB) (fetch SYSQUEUEHEAD of REXMTQUEUE) (\32BIT.GT (fetch TCB.SND.NXT of TCB) (IPLUS (fetch TCB.SND.WL1 of TCB) (fetch TCB.SND.WND of TCB)))) (* Something on the retransmit queue. Be agressive.) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) EVENT (fetch TCB.RTO of TCB))) (T (* Nothing to do. Be lazy) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) EVENT (fetch TCB.PROBE.TIMER of TCB) (NOT (NULL (fetch TCB.PROBE.TIMER of TCB)))))) EVENT) (COND ((SETQ SEGMENT (\DEQUEUE PACKETQUEUE)) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) -1) (\TCP.INPUT SEGMENT TCB))))))))))
)

(\TCP.TEMPLATE
(LAMBDA (TCB OPTIONS) (* ejs%: "21-Jun-85 16:40") (* set up segment for sending control information and pseudo-header for checksumming) (LET ((SEGMENT (fetch TCB.TEMPLATE of TCB))) (if SEGMENT then (replace TCP.DST.ADDR of SEGMENT with (fetch TCB.DST.HOST of TCB)) (replace TCP.DST.PORT of SEGMENT with (fetch TCB.DST.PORT of TCB)) else (SETQ SEGMENT (\TCP.SETUP.SEGMENT (\LOCAL.IP.ADDRESS) (fetch TCB.SRC.PORT of TCB) (fetch TCB.DST.HOST of TCB) (fetch TCB.DST.PORT of TCB)))) (if OPTIONS then (\TCP.SETUP.SEGMENT.OPTIONS SEGMENT OPTIONS)) (replace TCB.TEMPLATE of TCB with SEGMENT) (if (NULL (fetch TCB.PH of TCB)) then (replace TCB.PH of TCB with (create TCP.PSEUDOHEADER))) SEGMENT))
)

(\TCP.SETUP.SEGMENT.OPTIONS
(LAMBDA (SEGMENT OPTIONS) (* ejs%: "28-Jul-86 13:31") (* * Add options to a freshly setup segment. OPTIONS is in PLIST format) (LET ((OPTIONSBASE (fetch TCP.OPTIONS of SEGMENT)) (OPTIONSOFFSET 0) DIDPLACEOPTION) (COND ((IGREATERP (fetch (IP IPTOTALLENGTH) of SEGMENT) (CONSTANT (IPLUS \TCP.HEADER.LENGTH \IPOVLEN))) (ERROR "Tried to add options to a segment with TCP data already in place" SEGMENT))) (for OPTIONVALUETAIL on OPTIONS by (CDDR OPTIONVALUETAIL) do (SELECTQ (CAR OPTIONVALUETAIL) (MAXSEG (LET ((VALUE (CADR OPTIONVALUETAIL))) (COND ((SMALLP VALUE) (\PUTBASEBYTE OPTIONSBASE OPTIONSOFFSET \TCPOPT.MAXSEG) (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) 4) (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) (LOGAND (MASK.1'S 0 BITSPERBYTE) (LRSH VALUE BITSPERBYTE))) (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) (LOGAND VALUE (MASK.1'S 0 BITSPERBYTE))) (SETQ DIDPLACEOPTION T))))) NIL)) (COND (DIDPLACEOPTION (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) \TCPOPT.END))) (until (EQ 0 (IMOD OPTIONSOFFSET 4)) do (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) \TCPOPT.END)) (add (fetch (IP IPTOTALLENGTH) of SEGMENT) OPTIONSOFFSET) (add (fetch TCP.DATA.OFFSET of SEGMENT) (FOLDHI OPTIONSOFFSET BYTESPERCELL))))
)

(\TCP.SEND.CONTROL
(LAMBDA (TCB SEQ ACK FLAGS) (* ejs%: "18-Dec-86 17:29") (* send a control segment with the specified sequence number and ACK information) (PROG ((SEGMENT (OR (fetch TCB.TEMPLATE of TCB) (\TCP.NEW.TEMPLATE TCB)))) (if (NULL FLAGS) then (SETQ FLAGS 0)) (CHECK (OR (NOT (BITTEST FLAGS (LOGOR \TCP.CTRL.SYN \TCP.CTRL.FIN))) (SHOULDNT "SYN or FIN"))) (while (fetch EPTRANSMITTING of SEGMENT) do (BLOCK)) (replace TCP.SEQ of SEGMENT with SEQ) (if ACK then (replace TCP.ACK of SEGMENT with ACK) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.ACK)) else (replace TCP.ACK of SEGMENT with 0)) (replace TCP.CTRL of SEGMENT with FLAGS) (replace TCB.SENT.ZERO of TCB with (EQ 0 (replace TCP.WINDOW of SEGMENT with (replace TCB.LAST.SENT.RCV.WND of TCB with (fetch TCB.RCV.WND of TCB))))) (\TCP.SEND.SEGMENT TCB SEGMENT FLAGS) (\TCP.NEW.TEMPLATE TCB)))
)

(\TCP.SEND.ACK
(LAMBDA (TCB WHEN) (* ejs%: "17-Dec-86 16:43") (* set TCB.ACKFLG to tell the \TCP.PROCESS that an ACK needs to be sent -- NOW means send the ack immediately, LATER means delay in the hope that it can be piggybacked on an outgoing data segment) (COND ((EQ WHEN (QUOTE NOW)) (\TCP.SEND.CONTROL TCB (fetch TCB.SND.NXT of TCB) (\TCP.ACK# TCB) \TCP.CTRL.ACK)) (T (replace TCB.ACKFLG of TCB with (OR WHEN (QUOTE LATER))))))
)

(\TCP.SEND.RESET
(LAMBDA (ORIG SEQ ACK FLAGS) (* ejs%: " 7-Jun-85 12:58") (* like \TCP.SEND.CONTROL but always sends RST and can be used without a TCB) (PROG (SEGMENT) (SETQ SEGMENT (\TCP.SETUP.SEGMENT (\LOCAL.IP.ADDRESS) (fetch TCP.DST.PORT of ORIG) (fetch TCP.SRC.ADDR of ORIG) (fetch TCP.SRC.PORT of ORIG))) (replace TCP.SEQ of SEGMENT with SEQ) (if ACK then (replace TCP.ACK of SEGMENT with ACK) (OR FLAGS (SETQ FLAGS (LOGOR \TCP.CTRL.RST \TCP.CTRL.ACK))) else (replace TCP.ACK of SEGMENT with 0) (OR FLAGS (SETQ FLAGS \TCP.CTRL.RST))) (replace TCP.CTRL of SEGMENT with FLAGS) (replace TCP.WINDOW of SEGMENT with 0) (replace EPREQUEUE of SEGMENT with (QUOTE FREE)) (\TCP.SEND.SEGMENT NIL SEGMENT FLAGS)))
)

(\TCP.FIX.OUTGOING.SEGMENT
(LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "18-Dec-86 17:29") (* fill in control bits, ACK and window information, and start round trip timer) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (replace TCP.ACK of SEGMENT with (fetch TCB.RCV.NXT of TCB)) else (replace TCP.ACK of SEGMENT with 0)) (replace TCP.CTRL of SEGMENT with FLAGS) (* set control bits) (replace TCP.WINDOW of SEGMENT with (replace TCB.LAST.SENT.RCV.WND of TCB with (fetch TCB.RCV.WND of TCB))) (if (NULL (fetch TCB.RTFLG of TCB)) then (* time round trip response to this segment) (replace TCB.RTFLG of TCB with T) (replace TCB.RTSEQ of TCB with (fetch TCP.SEQ of SEGMENT)) (replace TCB.RTTIMER of TCB with (SETUPTIMER 0 (fetch TCB.RTTIMER of TCB)))))
)

(\TCP.SEND.DATA
(LAMBDA (TCB SEGMENT LENGTH FLAGS) (* wjy "13-Dec-85 14:30") (* * This function is used to send a TCP data segment for the first time. Subsequent retransmissions are done directly through \TCP.SEND.SEGMENT) (* * NOTE%: This function MUST be called with the TCB.LOCK already locked!) (PROG (SEQ TOP) (CHECK (OR (EQ LENGTH (\TCP.DATA.LENGTH SEGMENT)) (SHOULDNT "bad segment length"))) (CHECK (OR (ILEQ LENGTH (fetch TCB.MAXSEG of TCB)) (SHOULDNT "segment > max segment size"))) (if (NEQ (fetch TCB.STATE of TCB) (QUOTE SYN.SENT)) then (* ACK in all synchronized states) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.ACK))) (SETQ SEQ (fetch TCB.SND.NXT of TCB)) (* assign sequence number) (if (fetch TCB.ACKFLG of TCB) then (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.ACK))) (SETQ TOP (IPLUS SEQ LENGTH (\TCP.SYN.OR.FIN FLAGS))) (CHECK (OR (\32BIT.GEQ TOP (fetch TCB.SND.NXT of TCB)) (SHOULDNT "bad sequence numbers"))) (replace TCP.SEQ of SEGMENT with SEQ) (if (BITTEST FLAGS \TCP.CTRL.URG) then (replace TCB.SND.UP of TCB with TOP)) (if (\32BIT.GT (fetch TCB.SND.UP of TCB) SEQ) then (* there's urgent data to send) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.URG)) (replace TCP.URG.PTR of SEGMENT with (IDIFFERENCE (fetch TCB.SND.UP of TCB) SEQ)) else (* no urgent data) (* drag the urgent pointer along at the left edge of the window) (replace TCB.SND.UP of TCB with (fetch TCB.SND.UNA of TCB))) (if (BITTEST FLAGS \TCP.CTRL.FIN) then (* remember the sequence number of the FIN so we can tell when it's been acked) (CHECK (OR (EQ (fetch TCB.STATE of TCB) (QUOTE FIN.WAIT.1)) (EQ (fetch TCB.STATE of TCB) (QUOTE LAST.ACK)) (SHOULDNT "bad state for FIN"))) (replace TCB.FINSEQ of TCB with TOP)) (replace TCB.SND.NXT of TCB with TOP) (do (* try to send segment) (SELECTQ (fetch TCB.STATE of TCB) (LISTEN (ERROR "TCP connection not established")) ((SYN.SENT SYN.RECEIVED ESTABLISHED FIN.WAIT.1 CLOSE.WAIT LAST.ACK) (if (OR (ZEROP LENGTH) (ZEROP (fetch TCB.SND.WL1 of TCB)) (\32BIT.LEQ TOP (IPLUS (fetch TCB.SND.UNA of TCB) (fetch TCB.SND.WND of TCB))) (\32BIT.GT (fetch TCB.SND.UP of TCB) (fetch TCB.SND.UNA of TCB))) then (* go ahead and send it) (CHECK (OR (ZEROP LENGTH) (ZEROP (fetch TCB.SND.WL1 of TCB)) (\32BIT.LEQ TOP (IPLUS (fetch TCB.SND.UNA of TCB) (fetch TCB.SND.WND of TCB))))) (replace TCB.OUTPUT.HELD of TCB with NIL) (* advance SND.NXT) (\TCP.FIX.OUTGOING.SEGMENT TCB SEGMENT FLAGS) (replace EPREQUEUE of SEGMENT with (fetch TCB.REXMT.QUEUE of TCB)) (replace EPUSERFIELD of SEGMENT with (CLOCK0 (CREATECELL \FIXP))) (\TCP.SEND.SEGMENT TCB SEGMENT FLAGS) (RETURN) else (* block until we can send it) (replace TCB.OUTPUT.HELD of TCB with T) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.SND.EVENT of TCB)))) ((FIN.WAIT.2 CLOSING TIME.WAIT) (ERROR "TCP connection closing")) (CLOSED (ERROR "TCP connection closed")) (SHOULDNT)))))
)

(\TCP.SEND.SEGMENT
(LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "28-Dec-84 18:06") (* common routine to transmit a TCP segment) (\TCP.CHECKSUM.OUTGOING TCB SEGMENT) (\TCP.TRACE.SEGMENT (QUOTE SEND) SEGMENT) (if TCB then (if (BITTEST FLAGS \TCP.CTRL.ACK) then (replace TCB.ACKFLG of TCB with NIL)) (\TCP.START.PROBE.TIMER TCB)) (\IP.TRANSMIT SEGMENT))
)

(\TCP.NEW.TEMPLATE
(LAMBDA (TCB) (* ejs%: "29-Dec-84 13:05") (replace TCB.TEMPLATE of TCB with NIL) (\TCP.TEMPLATE TCB)))

(\TCP.START.PROBE.TIMER
(LAMBDA (TCB) (* ejs%: "12-Aug-86 10:35") (replace TCB.PROBE.TIMER of TCB with (COND ((AND (fetch TCB.NO.IDLE.PROBING of TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE ESTABLISHED))) NIL) (T (COND ((NULL (fetch TCB.PROBE.TIMER of TCB)) (LET ((IPSOCKET (fetch TCB.IPSOCKET of TCB))) (COND (IPSOCKET (NOTIFY.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET))))))) (SETUPTIMER (ITIMES 4 (fetch TCB.RTO of TCB)) (fetch TCB.PROBE.TIMER of TCB))))))
)

(\TCP.RETRANSMIT
(LAMBDA (TCB) (* ejs%: " 3-Jun-85 07:58") (* find the first unacknowledged segment and retransmit it) (PROG ((QUEUE (fetch TCB.REXMT.QUEUE of TCB)) (UNA (fetch TCB.SND.UNA of TCB)) CURRENT CURSEQ NEXT PREV REST FIRSTSEG MINSEQ FLAGS) (UNINTERRUPTABLY (* detach the list of segments to be retransmitted so we don't interfere with the driver) (SETQ NEXT (fetch SYSQUEUEHEAD of QUEUE)) (replace SYSQUEUEHEAD of QUEUE with NIL) (replace SYSQUEUETAIL of QUEUE with NIL)) (while (SETQ CURRENT NEXT) do (SETQ NEXT (fetch QLINK of CURRENT)) (replace QLINK of CURRENT with NIL) (if (\32BIT.LEQ (IPLUS (SETQ CURSEQ (fetch TCP.SEQ of CURRENT)) (\TCP.DATA.LENGTH CURRENT) (\TCP.SYN.OR.FIN (fetch TCP.CTRL of CURRENT))) UNA) then (* this segment has already been acked) (\TCP.RELEASE.SEGMENT CURRENT) elseif (NULL FIRSTSEG) then (* this is the first unacked segment we've encountered) (SETQ FIRSTSEG CURRENT) (SETQ MINSEQ CURSEQ) elseif (\32BIT.LT CURSEQ MINSEQ) then (* this is the lowest sequence number seen so so far; put the previous contender back on the REST queue) (replace QLINK of FIRSTSEG with REST) (SETQ REST FIRSTSEG) (SETQ FIRSTSEG CURRENT) (SETQ MINSEQ CURSEQ) else (* this is an unacked segment but later than one we've already seen; just add it to the REST queue) (replace QLINK of CURRENT with REST) (SETQ REST CURRENT))) (UNINTERRUPTABLY (* set the retransmit queue to be the REST queue we've accumulated) (if (SETQ CURRENT REST) then (* find tail of REST queue) (while (SETQ NEXT (fetch QLINK of CURRENT)) do (SETQ CURRENT NEXT))) (replace SYSQUEUEHEAD of QUEUE with REST) (replace SYSQUEUETAIL of QUEUE with CURRENT)) (if FIRSTSEG then (if (IGEQ (CLOCKDIFFERENCE (fetch EPUSERFIELD of FIRSTSEG)) (fetch TCB.RTO of TCB)) then (SETQ FLAGS (fetch TCP.CTRL of FIRSTSEG)) (\TCP.FIX.OUTGOING.SEGMENT TCB FIRSTSEG FLAGS) (replace EPREQUEUE of FIRSTSEG with (fetch TCB.REXMT.QUEUE of TCB)) (CLOCK0 (fetch EPUSERFIELD of FIRSTSEG)) (\TCP.SEND.SEGMENT TCB FIRSTSEG FLAGS) (RETURN T) else (\ENQUEUE (fetch TCB.REXMT.QUEUE of TCB) FIRSTSEG) (RETURN NIL)) else (RETURN NIL))))
)

(\TCP.START.TIME.WAIT
(LAMBDA (TCB) (* ecc "16-Apr-84 17:58") (* start 2MSL timer) (replace TCB.2MSL.TIMER of TCB with (SETUPTIMER (ITIMES 2 \TCP.MSL) (fetch TCB.2MSL.TIMER of TCB))) (\TCP.TRACE.TRANSITION TCB (QUOTE TIME.WAIT)) (replace TCB.STATE of TCB with (QUOTE TIME.WAIT)))
)

(\TCP.CONNECTION.DROPPED
(LAMBDA (TCB MSG) (* ejs%: "29-Jan-85 16:06") (if TCPTRACEFLG then (printout TCPTRACEFILE .TAB0 0 "[TCP connection " (OR MSG "dropped") "]" T)) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED)) (AND (OPENP (fetch TCB.RCV.STREAM of TCB) (QUOTE INPUT)) (CLOSEF (fetch TCB.RCV.STREAM of TCB))) (AND (OPENP (fetch TCB.SND.STREAM of TCB) (QUOTE OUTPUT)) (CLOSEF (fetch TCB.SND.STREAM of TCB))) (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB)))
)

(\TCP.CHECK.OPTIONS
(LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "21-Mar-86 20:04") (* * Do TCP header options processing) (COND ((IGREATERP (fetch (TCPSEGMENT TCP.DATA.OFFSET) of SEGMENT) \TCP.MIN.DATA.OFFSET) (\TCP.PROCESS.OPTIONS TCB SEGMENT FLAGS)) (T T)))
)

(\TCP.PROCESS.OPTIONS
(LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "20-Jun-85 16:08") (* * Process the options in a TCP header) (bind (OPTIONBASE _ (fetch (TCPSEGMENT TCP.OPTIONS) of SEGMENT)) (OPTIONOFFSET _ 0) OPTION eachtime (SETQ OPTION (\GETBASEBYTE OPTIONBASE OPTIONOFFSET)) until (EQ OPTION \TCPOPT.END) do (SELECTC OPTION (\TCPOPT.END (HELP "Unexpected \TCPOPT.END processing TCP options")) (\TCPOPT.NOP (add OPTIONOFFSET 1)) (\TCPOPT.MAXSEG (COND ((BITTEST FLAGS \TCP.CTRL.SYN) (replace TCB.MAXSEG of TCB with (IMIN \TCP.DEFAULT.MAXSEG (LOGOR (LLSH (\GETBASEBYTE OPTIONBASE (IPLUS OPTIONOFFSET 2)) BITSPERBYTE) (\GETBASEBYTE OPTIONBASE (IPLUS OPTIONOFFSET 3))))))) (add OPTIONOFFSET (\GETBASEBYTE OPTIONBASE (ADD1 OPTIONOFFSET)))) (RETURN))) T)
)
)



(* ;; "support for ICMP messages that affect TCP connections")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.PROTOCOL 1)


(CONSTANTS \ICMP.PROTOCOL)
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.32BIT.WORDS 2)


(CONSTANTS \ICMP.32BIT.WORDS)
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.DESTINATION.UNREACHABLE 3)

(RPAQQ \ICMP.SOURCE.QUENCH 4)


(CONSTANTS \ICMP.DESTINATION.UNREACHABLE \ICMP.SOURCE.QUENCH)
)
)
(DEFINEQ

(\TCP.HANDLE.ICMP
(LAMBDA (ICMP SEGMENT) (* ejs%: " 3-Jun-85 07:41") (* handle ICMP messages) (PROG (MSG TCB) (if (NEQ (fetch (ICMP ICMPTYPE) of ICMP) \ICMP.DESTINATION.UNREACHABLE) then (RETURN)) (SETQ MSG (SELECTQ (fetch (ICMP ICMPCODE) of ICMP) (0 "net unreachable") (1 "host unreachable") (2 "protocol unreachable") (3 "port unreachable") (4 "fragmentation needed and DF set") (5 "source route failed") "destination unreachable (unknown code)")) (SETQ TCB (\TCP.LOOKUP.TCB (fetch TCP.DST.ADDR of SEGMENT) (fetch TCP.DST.PORT of SEGMENT) (fetch TCP.SRC.PORT of SEGMENT))) (if (OR (NULL TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED))) then (RETURN)) (\RELEASE.ETHERPACKET ICMP) (\TCP.CONNECTION.DROPPED TCB MSG)))
)
)



(* ;; "TCP stream routines")

(DEFINEQ

(TCP.OPEN
(LAMBDA (DST.HOST DST.PORT SRC.PORT MODE ACCESS NOERRORFLG OPTIONS) (* ejs%: "21-Mar-86 17:38") (PROG (TCB DST.HOST.NUMBER) (SELECTQ ACCESS (INPUT) (APPEND) (OUTPUT (SETQ ACCESS (QUOTE APPEND))) (LISPERROR "ILLEGAL ARG" ACCESS)) (COND ((ATOM DST.HOST) (COND ((AND (NOT (SETQ DST.HOST.NUMBER (DODIP.HOSTP DST.HOST))) (EQ MODE (QUOTE ACTIVE))) (ERROR "Unknown TCP/IP host: " DST.HOST)))) ((FIXP DST.HOST) (SETQ DST.HOST.NUMBER DST.HOST)) (T (ERROR "Illegal TCP/IP host: " DST.HOST))) (SETQ TCB (\TCP.CONNECTION DST.HOST.NUMBER DST.PORT SRC.PORT MODE OPTIONS)) (RETURN (if (NULL TCB) then (if NOERRORFLG then NIL else (ERROR "TCP connection failed")) else (SELECTQ ACCESS (INPUT (fetch TCB.RCV.STREAM of TCB)) (APPEND (fetch TCB.SND.STREAM of TCB)) (SHOULDNT))))))
)

(TCP.OTHER.STREAM
(LAMBDA (STREAM) (* ecc "14-May-84 16:52") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (NOT (type? TCP.CONTROL.BLOCK TCB)) then (ERROR "no TCP control block")) (RETURN (SELECTQ (fetch (TCPSTREAM ACCESS) of STREAM) (INPUT (fetch TCB.SND.STREAM of TCB)) (APPEND (fetch TCB.RCV.STREAM of TCB)) (SHOULDNT)))))
)

(\TCP.BOUTS
(LAMBDA (STREAM BASE OFF NBYTES) (* ejs%: "27-May-86 15:09") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (RETURN (\BUFFERED.BOUTS (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of TCB) BASE OFF NBYTES))))
)

(\TCP.OTHER.BIN
(LAMBDA (STREAM) (* ejs%: "27-May-86 14:40") (\BIN (TCP.OTHER.STREAM STREAM))))

(\TCP.OTHER.BOUT
(LAMBDA (STREAM BYTE) (* ejs%: "27-May-86 14:19") (BOUT (TCP.OTHER.STREAM STREAM) BYTE)))

(\TCP.BIN
(LAMBDA (STREAM) (* ecc " 3-May-84 13:55") (do (if (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) then (RETURN (\GETBASEBYTE (fetch CPPTR of STREAM) (PROG1 (fetch COFFSET of STREAM) (add (fetch COFFSET of STREAM) 1)))) elseif (NULL (\TCP.GET.SEGMENT STREAM)) then (RETURN (STREAMOP (QUOTE ENDOFSTREAMOP) STREAM STREAM)))))
)

(\TCP.BACKFILEPTR
(LAMBDA (STREAM) (* ejs%: "15-Sep-85 23:25") (COND ((AND (fetch CPPTR of STREAM) (IGEQ (fetch COFFSET of STREAM) (fetch (TCPSTREAM ORIGINAL.COFFSET) of STREAM))) (add (fetch COFFSET of STREAM) -1)) (T (\IS.NOT.RANDACCESSP STREAM))))
)

(\TCP.GETNEXTBUFFER
(LAMBDA (STREAM WHATFOR NOERRORFLG) (* ejs%: "27-May-86 14:45") (BLOCK) (SELECTQ WHATFOR (READ (COND ((NEQ STREAM (fetch (TCP.CONTROL.BLOCK TCB.RCV.STREAM) of (fetch (TCPSTREAM TCB) of STREAM))) (SETQ STREAM (TCP.OTHER.STREAM STREAM)))) (\TCP.GET.SEGMENT STREAM NOERRORFLG)) (WRITE (COND ((NEQ STREAM (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of (fetch (TCPSTREAM TCB) of STREAM))) (SETQ STREAM (TCP.OTHER.STREAM STREAM)))) (\TCP.FLUSH STREAM) (\TCP.FILL.IN.SEGMENT STREAM)) (SHOULDNT)))
)

(\TCP.GET.SEGMENT
(LAMBDA (STREAM NOERRORFLG) (* ejs%: "18-Dec-86 17:33") (* * Get the next segment from the input stream. Return T if successful; otherwise, an error code. Call the user-specified error handler to get a code, if necessary) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM)) SEGMENT SEQ LEN OLDSEGMENT OLDSEQ OLDLEN OLDTOP SUCCESS OFFSET LAST.BYTE) (if (OR (NULL TCB) (AND (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (NEQ STREAM (fetch TCB.RCV.STREAM of TCB)))) then (ERROR "not TCP input stream")) (WITH.MONITOR (fetch TCB.LOCK of TCB) (SETQ OLDSEGMENT (fetch TCB.RCV.SEGMENT of TCB)) (CHECK (OR (NULL OLDSEGMENT) (EQ (fetch TCP.DATA.LENGTH of OLDSEGMENT) (fetch CBUFSIZE of STREAM)) (SHOULDNT "inconsistent stream buffer size"))) (UNINTERRUPTABLY (COND ((fetch CPPTR of STREAM) (SETQ LAST.BYTE (\GETBASEBYTE (fetch CPPTR of STREAM) (fetch COFFSET of STREAM))))) (replace TCB.RCV.SEGMENT of TCB with NIL) (replace CPPTR of STREAM with NIL) (replace CBUFSIZE of STREAM with 0) (replace COFFSET of STREAM with 0)) (if OLDSEGMENT then (* remember sequence number range of previous segment so we can adjust for overlap) (SETQ OLDTOP (IPLUS (SETQ OLDSEQ (fetch TCP.SEQ of OLDSEGMENT)) (SETQ OLDLEN (fetch TCP.DATA.LENGTH of OLDSEGMENT)))) (replace TCB.RCV.WND of TCB with (IMIN \TCP.DEFAULT.RECEIVE.WINDOW (IPLUS (fetch TCB.RCV.WND of TCB) OLDLEN))) (add (fetch (TCPSTREAM BYTECOUNT) of STREAM) OLDLEN) (\TCP.RELEASE.SEGMENT OLDSEGMENT) (SETQ OLDSEGMENT T)) (* look at first segment in input queue to see if it overlaps the sequence number range we're expecting; there may be duplicates that must be skipped over) (do ((CHECK (\TCP.CHECK.INPUT.QUEUE TCB)) (COND ((AND (SETQ SEGMENT (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))) (\32BIT.LT (SETQ SEQ (fetch TCP.SEQ of SEGMENT)) (fetch TCB.RCV.NXT of TCB))) (* this segment is within the range of contiguous sequence numbers received so far, because its sequence number is less than RCV.NXT) (\DEQUEUE (fetch TCB.INPUT.QUEUE of TCB)) (SETQ LEN (fetch TCP.DATA.LENGTH of SEGMENT)) (COND ((AND OLDSEGMENT (\32BIT.LEQ (IPLUS SEQ LEN) OLDTOP)) (* this segment is a duplicate) (\TCP.RELEASE.SEGMENT SEGMENT)) (T (* this segment overlaps with the range of sequence numbers we're expecting) (CHECK (OR (NOT OLDSEGMENT) (\32BIT.LEQ SEQ OLDTOP) (SHOULDNT "gap in input queue"))) (UNINTERRUPTABLY (replace CPPTR of STREAM with (fetch TCP.CONTENTS of SEGMENT)) (* eliminate overlap) (SETQ OFFSET (replace (TCPSTREAM ORIGINAL.COFFSET) of STREAM with (replace COFFSET of STREAM with (COND (OLDSEGMENT (IDIFFERENCE OLDLEN (IDIFFERENCE SEQ OLDSEQ))) (T 0))))) (COND (LAST.BYTE (\PUTBASEBYTE (fetch CPPTR of STREAM) (SUB1 OFFSET) LAST.BYTE))) (add (fetch (TCPSTREAM BYTECOUNT) of STREAM) (IMINUS OFFSET)) (replace CBUFSIZE of STREAM with LEN) (replace TCB.RCV.SEGMENT of TCB with SEGMENT)) (SETQ SUCCESS T) (RETURN)))) (T (SELECTQ (fetch TCB.STATE of TCB) ((LISTEN SYN.SENT SYN.RECEIVED) (* wait until established) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.ESTABLISHED of TCB))) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2) (* wait for next segment) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.RCV.EVENT of TCB)) (SELECTQ (fetch TCB.STATE of TCB) ((CLOSED CLOSING LAST.ACK) (RELEASE.MONITORLOCK (fetch TCB.LOCK of TCB)) (COND (NOERRORFLG (RETURN NIL)) (T (RETURN (SETQ SUCCESS (\EOF.ACTION STREAM)))))) NIL)) ((CLOSED CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT) (* return NIL to punt to ENDOFSTREAMOP in \TCP.BIN) (RELEASE.MONITORLOCK (fetch TCB.LOCK of TCB)) (COND (NOERRORFLG (RETURN NIL)) (T (RETURN (SETQ SUCCESS (\EOF.ACTION STREAM)))))) (SHOULDNT))))))) (if (fetch TCB.SENT.ZERO of TCB) then (\TCP.SEND.ACK TCB (QUOTE NOW)) (BLOCK)) (RETURN SUCCESS)))
)

(\TCP.PEEKBIN
(LAMBDA (STREAM NOERRORFLG) (* ecc " 3-May-84 13:55") (do (if (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) then (RETURN (\GETBASEBYTE (fetch CPPTR of STREAM) (fetch COFFSET of STREAM))) elseif (NULL (\TCP.GET.SEGMENT STREAM)) then (RETURN (if NOERRORFLG then NIL else (STREAMOP (QUOTE ENDOFSTREAMOP) STREAM STREAM))))))
)

(\TCP.GETFILEPTR
(LAMBDA (STREAM) (* ejs%: "10-Jun-85 14:07") (IPLUS (fetch (STREAM COFFSET) of STREAM) (fetch (TCPSTREAM BYTECOUNT) of STREAM)))
)

(\TCP.READP
(LAMBDA (STREAM) (* ejs%: " 7-Jun-85 13:39") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (AND (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (NEQ STREAM (fetch TCB.RCV.STREAM of TCB)))) then (ERROR "not TCP input stream") else (RETURN (OR (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) (AND (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB)) T))))))
)

(\TCP.EOFP
(LAMBDA (STREAM) (* ejs%: "13-Apr-85 16:15") (* check whether EOF has been reached on stream -- may block waiting for next segment) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (NULL TCB) then (ERROR "not TCP stream") elseif (AND (NEQ (QUOTE CLOSED) (fetch TCB.STATE of TCB)) (EQ STREAM (fetch TCB.SND.STREAM of TCB))) then (RETURN T) (* Always at EOF of outgoing stream.) elseif (OR (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) (NOT (NULL (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))))) then (* there is still data left to read) (RETURN NIL) else (RETURN (SELECTQ (fetch TCB.STATE of TCB) (ESTABLISHED NIL) ((LISTEN SYN.SENT SYN.RECEIVED FIN.WAIT.1 FIN.WAIT.2) (* can't tell without waiting for next segment) (NULL (\TCP.GET.SEGMENT STREAM T))) ((CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT CLOSED) (* no more data can be forthcoming) T) (SHOULDNT))))))
)

(TCP.URGENTP
(LAMBDA (STREAM) (* ecc " 7-May-84 14:27") (* check if current point in receive stream is before receive urgent pointer) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (NEQ STREAM (fetch TCB.RCV.STREAM of TCB))) then (ERROR "not TCP input stream")) (RETURN (AND (fetch TCB.RCV.SEGMENT of TCB) (\32BIT.GT (fetch TCB.RCV.UP of TCB) (IPLUS (fetch TCP.SEQ of (fetch TCB.RCV.SEGMENT of TCB)) (fetch COFFSET of STREAM)))))))
)

(TCP.URGENT.EVENT
(LAMBDA (STREAM) (* edited%: "22-May-84 18:10") (* return the urgent data event so that a user process can wait for it) (fetch TCB.URGENT.EVENT of (fetch (TCPSTREAM TCB) of STREAM)))
)

(\TCP.BOUT
(LAMBDA (STREAM CHAR) (* ecc " 3-May-84 13:55") (do (if (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) then (\PUTBASEBYTE (fetch CPPTR of STREAM) (fetch COFFSET of STREAM) CHAR) (add (fetch COFFSET of STREAM) 1) (RETURN) else (\TCP.FLUSH STREAM) (\TCP.FILL.IN.SEGMENT STREAM))))
)

(\TCP.FLUSH
(LAMBDA (STREAM FLAGS) (* ; "Edited  4-Dec-87 12:11 by scp") (* Force out current output segment. If FLAGS is non-nil, send a segment with those flags even if we have to create a new one) (PROG ((TCB (fetch TCB of STREAM)) SEGMENT LENGTH) (if (OR (NULL TCB) (AND (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (NEQ STREAM (fetch TCB.SND.STREAM of TCB)))) then (ERROR "not TCP output stream")) (SETQ LENGTH (fetch COFFSET of STREAM)) (WITH.FAST.MONITOR (fetch TCB.LOCK of TCB) (if (OR (AND (SETQ SEGMENT (fetch TCB.SND.SEGMENT of TCB)) (NOT (ZEROP LENGTH))) (AND FLAGS (SETQ SEGMENT (\TCP.FILL.IN.SEGMENT STREAM (COND ((EQ (fetch TCB.STATE of TCB) (QUOTE SYN.SENT)) (BQUOTE (MAXSEG %, (OR (fetch TCB.OUR.MAXSEG of TCB) \TCP.DEFAULT.MAXSEG)))) ((EQ (fetch TCB.STATE of TCB) (QUOTE SYN.RECEIVED)) (BQUOTE (MAXSEG %, (OR (fetch TCB.OUR.MAXSEG of TCB) \TCP.DEFAULT.MAXSEG))))))))) then (if (NULL FLAGS) then (SETQ FLAGS 0)) (CHECK (OR (NOT (ZEROP LENGTH)) (NOT (ZEROP (\TCP.SYN.OR.FIN FLAGS))) (SHOULDNT "sending empty segment"))) (if (AND (IGREATERP LENGTH 0) (ILESSP LENGTH (fetch TCB.OUR.MAXSEG of TCB))) then (* PSH this segment to make sure it gets through to the remote process) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.PSH))) (UNINTERRUPTABLY (replace TCB.SND.SEGMENT of TCB with NIL) (replace CBUFSIZE of STREAM with 0) (replace COFFSET of STREAM with 0) (replace CPPTR of STREAM with NIL) (add (fetch (TCPSTREAM BYTECOUNT) of STREAM) LENGTH)) (add (fetch (IP IPTOTALLENGTH) of SEGMENT) LENGTH) (\TCP.SEND.DATA TCB SEGMENT LENGTH FLAGS)))))
)

(\TCP.FORCEOUTPUT
(LAMBDA (STREAM WAITFLG) (* ejs%: "27-May-86 14:36") (* just call \TCP.FLUSH with no flags -- to implement WAITFLG we should wait for SND.UNA to overtake the current SND.NXT) (COND ((NEQ STREAM (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of (fetch (TCPSTREAM TCB) of STREAM))) (\TCP.FLUSH (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of (fetch (TCPSTREAM TCB) of STREAM)))) (T (\TCP.FLUSH STREAM))))
)

(TCP.URGENT.MARK
(LAMBDA (STREAM) (* ecc " 7-May-84 14:17") (* mark the current point in the output stream as the end of urgent data) (\TCP.FLUSH STREAM \TCP.CTRL.URG))
)

(\TCP.FILL.IN.SEGMENT
(LAMBDA (STREAM OPTIONS) (* ejs%: "22-Jun-85 03:18") (* * set up a new segment to be filled by the output stream. OPTIONS, if supplied, is in PLIST format) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM)) SEGMENT) (SETQ SEGMENT (\TCP.SETUP.SEGMENT (\LOCAL.IP.ADDRESS) (fetch TCB.SRC.PORT of TCB) (fetch TCB.DST.HOST of TCB) (fetch TCB.DST.PORT of TCB))) (COND (OPTIONS (\TCP.SETUP.SEGMENT.OPTIONS SEGMENT OPTIONS))) (UNINTERRUPTABLY (replace TCB.SND.SEGMENT of TCB with SEGMENT) (replace CPPTR of STREAM with (fetch TCP.CONTENTS of SEGMENT)) (replace COFFSET of STREAM with 0) (replace CBUFSIZE of STREAM with (fetch TCB.MAXSEG of TCB)) (replace CBUFMAXSIZE of STREAM with (fetch TCB.MAXSEG of TCB))) (RETURN SEGMENT)))
)

(\TCP.CLOSE
(LAMBDA (STREAM) (* ejs%: "29-Jan-85 17:19") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (FMEMB (fetch TCB.STATE of TCB) (QUOTE (CLOSED TIME.WAIT)))) then (RETURN)) (if (NOT (fetch TCB.CLOSEDFLG of TCB)) then (TCP.CLOSE.SENDER (fetch TCB.SND.STREAM of TCB))) (if (EQ STREAM (fetch TCB.RCV.STREAM of TCB)) then (while (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB)) do (* gobble remaining segments from remote end) (\TCP.GET.SEGMENT STREAM)))))
)

(\TCP.RESETCLOSE
(LAMBDA (STREAM) (* ejs%: "27-May-86 11:55") (\TCP.CLOSE STREAM)))

(TCP.CLOSE.SENDER
(LAMBDA (STREAM) (* ecc " 7-May-84 13:44") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (fetch TCB.CLOSEDFLG of TCB)) then (RETURN)) (WITH.MONITOR (fetch TCB.LOCK of TCB) (replace TCB.CLOSEDFLG of TCB with T) (SELECTQ (fetch TCB.STATE of TCB) ((LISTEN SYN.SENT) (\TCP.CONNECTION.DROPPED TCB "closed")) ((SYN.RECEIVED ESTABLISHED) (\TCP.TRACE.TRANSITION TCB (QUOTE FIN.WAIT.1)) (replace TCB.STATE of TCB with (QUOTE FIN.WAIT.1)) (\TCP.FLUSH STREAM \TCP.CTRL.FIN)) (CLOSE.WAIT (\TCP.TRACE.TRANSITION TCB (QUOTE LAST.ACK)) (replace TCB.STATE of TCB with (QUOTE LAST.ACK)) (* There is an inconsistency in the spec about this transition%: the description of the CLOSE operation says to go to the CLOSING state, while the diagram shows a transition to the LAST.ACK state. Since the LAST.ACK state avoids the 2MSL wait, we use it.) (\TCP.FLUSH STREAM \TCP.CTRL.FIN)) NIL) (while (NOT (OR (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (\TCP.OUR.FIN.IS.ACKED TCB))) do (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.FINACKED.EVENT of TCB))))))
)

(TCP.DESTADDRESS
(LAMBDA (STREAM) (* ejs%: "27-May-86 11:53") (\IP.ADDRESS.TO.STRING (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST) of (fetch (TCPSTREAM TCB) of STREAM))))
)

(TCP.STOP
(LAMBDA NIL (* ejs%: "28-Dec-84 18:02") (MAPC \TCP.CONTROL.BLOCKS (FUNCTION \TCP.DELETE.TCB)) (SETQ \TCP.CONTROL.BLOCKS NIL) (\IP.DELETE.PROTOCOL \TCP.PROTOCOL))
)
)



(* ;; "well-known ports for network standard functions")


(RPAQQ \TCP.ASSIGNED.PORTS 
       (\TCP.ECHO.PORT \TCP.SINK.PORT \TCP.SYSTAT.PORT \TCP.DAYTIME.PORT \TCP.NETSTAT.PORT 
              \TCP.FAUCET.PORT \TCP.FTP.PORT \TCP.TELNET.PORT \TCP.SMTP.PORT \TCP.TIME.PORT 
              \TCP.NAME.PORT \TCP.WHOIS.PORT \TCP.NAMESERVER.PORT \TCP.FINGER.PORT \TCP.TTYLINK.PORT
              \TCP.SUPDUP.PORT \TCP.HOSTNAMES.PORT \TCP.UNIXEXEC.PORT \TCP.UNIXLOGIN.PORT 
              \TCP.UNIXSHELL.PORT))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TCP.ECHO.PORT 7)

(RPAQQ \TCP.SINK.PORT 9)

(RPAQQ \TCP.SYSTAT.PORT 11)

(RPAQQ \TCP.DAYTIME.PORT 13)

(RPAQQ \TCP.NETSTAT.PORT 15)

(RPAQQ \TCP.FAUCET.PORT 19)

(RPAQQ \TCP.FTP.PORT 21)

(RPAQQ \TCP.TELNET.PORT 23)

(RPAQQ \TCP.SMTP.PORT 25)

(RPAQQ \TCP.TIME.PORT 37)

(RPAQQ \TCP.NAME.PORT 42)

(RPAQQ \TCP.WHOIS.PORT 43)

(RPAQQ \TCP.NAMESERVER.PORT 53)

(RPAQQ \TCP.FINGER.PORT 79)

(RPAQQ \TCP.TTYLINK.PORT 87)

(RPAQQ \TCP.SUPDUP.PORT 95)

(RPAQQ \TCP.HOSTNAMES.PORT 101)

(RPAQQ \TCP.UNIXEXEC.PORT 512)

(RPAQQ \TCP.UNIXLOGIN.PORT 513)

(RPAQQ \TCP.UNIXSHELL.PORT 514)


(CONSTANTS \TCP.ECHO.PORT \TCP.SINK.PORT \TCP.SYSTAT.PORT \TCP.DAYTIME.PORT \TCP.NETSTAT.PORT 
       \TCP.FAUCET.PORT \TCP.FTP.PORT \TCP.TELNET.PORT \TCP.SMTP.PORT \TCP.TIME.PORT \TCP.NAME.PORT 
       \TCP.WHOIS.PORT \TCP.NAMESERVER.PORT \TCP.FINGER.PORT \TCP.TTYLINK.PORT \TCP.SUPDUP.PORT 
       \TCP.HOSTNAMES.PORT \TCP.UNIXEXEC.PORT \TCP.UNIXLOGIN.PORT \TCP.UNIXSHELL.PORT)
)



(* ;; "Stub for debugging")


(RPAQ? \TCP.DEBUGGABLE )

(RPAQ? TCPTRACEFLG )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCP.DEBUGGABLE TCPTRACEFLG)
)
(DEFINEQ

(PPTCB
(LAMBDA (TCB FILE) (* ejs%: " 5-Feb-85 16:47") (DECLARE (GLOBALVARS \TCP.DEBUGGABLE)) (COND (\TCP.DEBUGGABLE (printout FILE "TCP connection from " %# (\IP.PRINT.ADDRESS (\LOCAL.IP.ADDRESS) FILE) ":" (fetch TCB.SRC.PORT of TCB) " to " %# (\IP.PRINT.ADDRESS (fetch TCB.DST.HOST of TCB) FILE) ":" (fetch TCB.DST.PORT of TCB) " " (fetch TCB.STATE of TCB) T) (printout FILE " iss " (fetch TCB.ISS of TCB) " window " (fetch TCB.SND.UNA of TCB) ".." (IPLUS (fetch TCB.SND.UNA of TCB) (fetch TCB.SND.WND of TCB)) " next " (fetch TCB.SND.NXT of TCB)) (if (fetch TCB.FINSEQ of TCB) then (printout FILE " fin " (fetch TCB.FINSEQ of TCB))) (printout FILE " rto " (fetch TCB.RTO of TCB) T) (printout FILE " irs " (fetch TCB.IRS of TCB) " next " (fetch TCB.RCV.NXT of TCB) " window " (fetch TCB.RCV.NXT of TCB) ".." (IPLUS (fetch TCB.RCV.NXT of TCB) (fetch TCB.RCV.WND of TCB)) T) (\TCP.PRINT.SEGMENT.QUEUE "retransmit queue" (fetch TCB.REXMT.QUEUE of TCB) FILE) (\TCP.PRINT.SEGMENT.QUEUE "input queue" (fetch TCB.INPUT.QUEUE of TCB) FILE))))
)

(\TCP.TRACE.SEGMENT
(LAMBDA (CALLER SEGMENT) (* ejs%: " 5-Feb-85 16:50") (DECLARE (GLOBALVARS \TCP.DEBUGGABLE TCPTRACEFLG)) (if (AND \TCP.DEBUGGABLE (MEMB CALLER TCPTRACEFLG)) then (printout TCPTRACEFILE .TAB0 0 %# (\TCP.PRINT.ELAPSED.TIME TCPTRACEFILE) CALLER ": " %# (TCP.PRINT.SEGMENT SEGMENT TCPTRACEFILE NIL (MEMB (QUOTE CONTENTS) TCPTRACEFLG)))))
)

(\TCP.TRACE.TRANSITION
(LAMBDA (TCB NEWSTATE) (* ejs%: " 5-Feb-85 16:51") (DECLARE (GLOBALVARS \TCP.DEBUGGABLE)) (if (AND \TCP.DEBUGGABLE (MEMB (QUOTE TRANSITION) TCPTRACEFLG) (NEQ (fetch TCB.STATE of TCB) NEWSTATE)) then (printout TCPTRACEFILE .TAB0 0 %# (\TCP.PRINT.ELAPSED.TIME TCPTRACEFILE) (fetch TCB.SRC.PORT of TCB) "/" (fetch TCB.DST.PORT of TCB) ": " (fetch TCB.STATE of TCB) " ---> " NEWSTATE)))
)
)



(* ;; "TCP initialization")

(DEFINEQ

(\TCP.INIT
(LAMBDA NIL (* ; "Edited 11-Aug-88 14:32 by atm") (COND ((NULL \TCP.DEVICE) (SETQ \TCP.DEVICE (create FDEV FDBINABLE _ T FDBOUTABLE _ T BUFFERED _ T CLOSEFILE _ (FUNCTION \TCP.CLOSE) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM) OPENP _ (FUNCTION \GENERIC.OPENP) BIN _ (FUNCTION \BUFFERED.BIN) BOUT _ (FUNCTION \BUFFERED.BOUT) BLOCKIN _ (FUNCTION \BUFFERED.BINS) BLOCKOUT _ (FUNCTION \TCP.BOUTS) PEEKBIN _ (FUNCTION \BUFFERED.PEEKBIN) READP _ (FUNCTION \TCP.READP) FORCEOUTPUT _ (FUNCTION \TCP.FORCEOUTPUT) GETNEXTBUFFER _ (FUNCTION \TCP.GETNEXTBUFFER) BACKFILEPTR _ (FUNCTION \TCP.BACKFILEPTR) GETFILEPTR _ (FUNCTION \TCP.GETFILEPTR) EOFP _ (FUNCTION \TCP.EOFP) DEVICENAME _ (QUOTE TCP) EVENTFN _ (FUNCTION NILL))) (\DEFINEDEVICE (QUOTE TCP) \TCP.DEVICE))) (SETQ \TCP.LOCK (CREATE.MONITORLOCK)) (COND ((NULL \TCP.PSEUDOHEADER) (SETQ \TCP.PSEUDOHEADER (create TCP.PSEUDOHEADER)))) (OR \IPFLG (\IPINIT)) (\IP.ADD.PROTOCOL \TCP.PROTOCOL (FUNCTION \TCP.PORTCOMPARE) (FUNCTION \TCP.NOSOCKETFN) NIL (FUNCTION \TCP.HANDLE.ICMP)) (SETQ \TCP.MASTER.SOCKET (\IP.FIND.PROTOCOL \TCP.PROTOCOL)))
)
)

(\TCP.INIT)
(PUTPROPS TCP COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986 1901 1900 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (8342 9364 (SET.IP.ADDRESS 8352 . 8622) (STRING.TO.IP.ADDRESS 8624 . 8865) (
IP.ADDRESS.TO.STRING 8867 . 9091) (\LOCAL.IP.ADDRESS 9093 . 9362)) (14232 14439 (\TCP.SELECT.ISS 14242
 . 14437)) (28588 34348 (\TCP.CREATE.TCB 28598 . 29684) (\TCP.SELECT.PORT 29686 . 29968) (
\TCP.LOOKUP.TCB 29970 . 30867) (\TCP.DELETE.TCB 30869 . 32537) (\TCP.NOSOCKETFN 32539 . 33367) (
\TCP.PORTCOMPARE 33369 . 34346)) (36215 38810 (\COMPUTE.CHECKSUM 36225 . 36891) (
\TCP.CHECKSUM.INCOMING 36893 . 37989) (\TCP.CHECKSUM.OUTGOING 37991 . 38808)) (39315 77802 (\TCP.ACK# 
39325 . 39782) (\TCP.PACKET.FILTER 39784 . 40055) (\TCP.SETUP.SEGMENT 40057 . 40587) (
\TCP.RELEASE.SEGMENT 40589 . 40843) (\TCP.CONNECTION 40845 . 44136) (\TCP.FIX.INCOMING.SEGMENT 44138
 . 44766) (\TCP.DATA.LENGTH 44768 . 45096) (\TCP.SYN.OR.FIN 45098 . 45438) (\TCP.INPUT 45440 . 48309) 
(\TCP.INPUT.INITIAL 48311 . 49094) (\TCP.INPUT.UNSYNC 49096 . 49466) (\TCP.INPUT.LISTEN 49468 . 50911)
 (\TCP.INPUT.SYN.SENT 50913 . 52778) (\TCP.CHECK.WINDOW 52780 . 53628) (\TCP.CHECK.RESET 53630 . 54398
) (\TCP.CHECK.SECURITY 54400 . 54600) (\TCP.CHECK.NO.SYN 54602 . 55166) (\TCP.CHECK.ACK 55168 . 55443)
 (\TCP.HANDLE.ACK 55445 . 56750) (\TCP.HANDLE.URG 56752 . 57345) (\TCP.QUEUE.INPUT 57347 . 61011) (
\TCP.HANDLE.FIN 61013 . 62109) (\TCP.OUR.FIN.IS.ACKED 62111 . 62378) (\TCP.SIGNAL.URGENT.DATA 62380 . 
62586) (\TCP.PROCESS 62588 . 65394) (\TCP.TEMPLATE 65396 . 66104) (\TCP.SETUP.SEGMENT.OPTIONS 66106 . 
67362) (\TCP.SEND.CONTROL 67364 . 68215) (\TCP.SEND.ACK 68217 . 68655) (\TCP.SEND.RESET 68657 . 69371)
 (\TCP.FIX.OUTGOING.SEGMENT 69373 . 70111) (\TCP.SEND.DATA 70113 . 72955) (\TCP.SEND.SEGMENT 72957 . 
73305) (\TCP.NEW.TEMPLATE 73307 . 73432) (\TCP.START.PROBE.TIMER 73434 . 73897) (\TCP.RETRANSMIT 73899
 . 75994) (\TCP.START.TIME.WAIT 75996 . 76281) (\TCP.CONNECTION.DROPPED 76283 . 76787) (
\TCP.CHECK.OPTIONS 76789 . 77047) (\TCP.PROCESS.OPTIONS 77049 . 77800)) (78261 78997 (\TCP.HANDLE.ICMP
 78271 . 78995)) (79035 93181 (TCP.OPEN 79045 . 79822) (TCP.OTHER.STREAM 79824 . 80161) (\TCP.BOUTS 
80163 . 80384) (\TCP.OTHER.BIN 80386 . 80485) (\TCP.OTHER.BOUT 80487 . 80597) (\TCP.BIN 80599 . 80952)
 (\TCP.BACKFILEPTR 80954 . 81210) (\TCP.GETNEXTBUFFER 81212 . 81725) (\TCP.GET.SEGMENT 81727 . 85444) 
(\TCP.PEEKBIN 85446 . 85802) (\TCP.GETFILEPTR 85804 . 85955) (\TCP.READP 85957 . 86354) (\TCP.EOFP 
86356 . 87244) (TCP.URGENTP 87246 . 87703) (TCP.URGENT.EVENT 87705 . 87911) (\TCP.BOUT 87913 . 88223) 
(\TCP.FLUSH 88225 . 89779) (\TCP.FORCEOUTPUT 89781 . 90199) (TCP.URGENT.MARK 90201 . 90375) (
\TCP.FILL.IN.SEGMENT 90377 . 91122) (\TCP.CLOSE 91124 . 91604) (\TCP.RESETCLOSE 91606 . 91693) (
TCP.CLOSE.SENDER 91695 . 92828) (TCP.DESTADDRESS 92830 . 93000) (TCP.STOP 93002 . 93179)) (94939 96765
 (PPTCB 94949 . 95990) (\TCP.TRACE.SEGMENT 95992 . 96350) (\TCP.TRACE.TRANSITION 96352 . 96763)) (
96802 97966 (\TCP.INIT 96812 . 97964)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPCHAT b/obsolete/tcp/TCPCHAT
deleted file mode 100644
index 0c4735fc..00000000
--- a/obsolete/tcp/TCPCHAT
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jun-90 16:10:42" {DSK}<usr>local>lde>lispcore>library>TCPCHAT.;3 11300  

      changes to%:  (FILES TCP)
                    (VARS TCPCHATCOMS)

      previous date%: "15-Feb-90 13:09:03" {DSK}<usr>local>lde>lispcore>library>TCPCHAT.;2)


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

(PRETTYCOMPRINT TCPCHATCOMS)

(RPAQQ TCPCHATCOMS
       [(FNS TCPCHAT.BIN TCPCHAT.HOST.FILTER TCPCHAT.NEGOTIATE TCPCHAT.OPEN TCPCHAT.OPTION.COMMAND 
             TCPCHAT.OPTION.INPUT TCPCHAT.OPTION.OUTPUT TCPCHAT.OPTION.TRACE TCPCHAT.TERMINAL.TYPE)
        (VARS TCPCHAT.TELNET.TTY.TYPES TELNET.OPTIONS)
        (INITVARS (TCPCHAT.TRACEFLG)
               (TCPCHAT.TRACEFILE))
        (FILES (SYSLOAD)
               TCP CHAT)
        (DECLARE%: EVAL@COMPILE DONTCOPY (FILES CHATDECLS)
               (COMS (CONSTANTS * TELNET.COMMANDS)
                     (CONSTANTS * TELNET.MARKS))
               (RECORDS TELNET.OPTION TELNET.OPTIONSTATE)
               (GLOBALVARS TCPCHAT.TELNET.TTY.TYPES TELNET.OPTIONS TELNET.MARKS))
        (DECLARE%: DONTEVAL@LOAD DOCOPY 

               (* ;; "Tell Chat we exist ")

               (ADDVARS (CHAT.PROTOCOLTYPES (TCP . TCPCHAT.HOST.FILTER))
                      (CHAT.PROTOCOL.ABBREVS (N . TCP)
                             (T . TCP])
(DEFINEQ

(TCPCHAT.BIN
(LAMBDA (STREAM) (* ; "Edited  7-Jul-88 18:03 by atm") (bind CHAR while (AND (EQ (SETQ CHAR (\BUFFERED.BIN STREAM)) TELNET.IAC) (NEQ (SETQ CHAR (\BUFFERED.BIN STREAM)) TELNET.IAC)) do (TCPCHAT.NEGOTIATE CHAR STREAM) finally (RETURN CHAR)))
)

(TCPCHAT.HOST.FILTER
(LAMBDA (HOST) (* ; "Edited 12-Apr-88 17:14 by bvm") (COND ((AND \IPFLG (DODIP.HOSTP HOST)) (LIST HOST (FUNCTION TCPCHAT.OPEN)))))
)

(TCPCHAT.NEGOTIATE
(LAMBDA (COMMAND STREAM) (* ; "Edited  7-Jul-88 18:03 by atm") (TCPCHAT.OPTION.INPUT (TCP.OTHER.STREAM STREAM) COMMAND (\BUFFERED.BIN STREAM)))
)

(TCPCHAT.OPEN
(LAMBDA (HOST) (* ; "Edited 17-Apr-87 10:06 by jrb:") (PROG ((STREAM (TCP.OPEN (DODIP.HOSTP HOST) \TCP.TELNET.PORT NIL (QUOTE ACTIVE) (QUOTE INPUT))) (OSTYPE (OR (AND (GETHASH (U-CASE HOST) \IP.HOSTNAMES) (fetch (HOSTS.TXT.ENTRY HTE.OS.TYPE) of (GETHASH (U-CASE HOST) \IP.HOSTNAMES))) (GETHOSTINFO HOST (QUOTE OSTYPE)))) OUTPUTSTREAM) (COND (STREAM (replace (STREAM BINABLE) of STREAM with NIL) (* ; "Can't run microcoded") (replace (STREAM STRMBINFN) of STREAM with (FUNCTION TCPCHAT.BIN)) (STREAMPROP STREAM (QUOTE SETDISPLAYTYPE) (FUNCTION NILL)) (COND ((EQ OSTYPE (QUOTE INTERLISP)) (RETURN (CONS STREAM (TCP.OTHER.STREAM STREAM))))) (* ; "(STREAMPROP STREAM (QUOTE SETDISPLAYTYPE) (FUNCTION TCPCHAT.TERMINAL.TYPE))") (SETQ OUTPUTSTREAM (TCP.OTHER.STREAM STREAM)) (STREAMPROP OUTPUTSTREAM (QUOTE OPTIONSTATES) (for OPTION in TELNET.OPTIONS collect (create TELNET.OPTIONSTATE OPTION _ (fetch (TELNET.OPTION OPTION) of OPTION)))) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.DO TELNET.ECHO) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.DO TELNET.SUPPRESS.GOAHEAD) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.WILL TELNET.SUPPRESS.GOAHEAD) (COND ((NEQ OSTYPE (QUOTE UNIX)) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.DO TELNET.BINARY) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.WILL TELNET.BINARY))) (RETURN (CONS STREAM OUTPUTSTREAM))))))
)

(TCPCHAT.OPTION.COMMAND
(LAMBDA (OUTPUTSTREAM COMMAND OPTION TRACECAPTION) (* ; "Edited 24-Aug-87 16:58 by scp") (LET ((OPTIONSTATE (FASSOC OPTION (STREAMPROP OUTPUTSTREAM (QUOTE OPTIONSTATES)))) GO.AHEAD.WITH.COMMAND) (COND ((NULL OPTIONSTATE) (SETQ GO.AHEAD.WITH.COMMAND T)) (T (SELECTC COMMAND (TELNET.DO (COND ((NEQ (fetch (TELNET.OPTIONSTATE DOING) of OPTIONSTATE) (QUOTE YES)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE DOING) of OPTIONSTATE with (QUOTE YES))))) (TELNET.WILL (COND ((NEQ (fetch (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE) (QUOTE YES)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE with (QUOTE YES))))) (TELNET.DONT (COND ((NEQ (fetch (TELNET.OPTIONSTATE DOING) of OPTIONSTATE) (QUOTE NO)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE DOING) of OPTIONSTATE with (QUOTE NO))))) (TELNET.WONT (COND ((NEQ (fetch (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE) (QUOTE NO)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE with (QUOTE NO))))) NIL))) (COND (GO.AHEAD.WITH.COMMAND (BOUT OUTPUTSTREAM TELNET.IAC) (BOUT OUTPUTSTREAM COMMAND) (BOUT OUTPUTSTREAM OPTION) (FORCEOUTPUT OUTPUTSTREAM) (TCPCHAT.OPTION.TRACE COMMAND OPTION (OR TRACECAPTION (QUOTE SEND)))))))
)

(TCPCHAT.OPTION.INPUT
(LAMBDA (OUTPUTSTREAM COMMAND OPTION) (* ; "Edited 16-Apr-87 13:30 by jrb:") (LET ((OPTIONRECORD (FASSOC OPTION TELNET.OPTIONS))) (COND (OPTIONRECORD (SELECTC COMMAND (TELNET.DO (TCPCHAT.OPTION.TRACE (QUOTE DO) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.DO) of OPTIONRECORD) OPTION)) (TELNET.DONT (TCPCHAT.OPTION.TRACE (QUOTE DONT) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.DONT) of OPTIONRECORD) OPTION)) (TELNET.WILL (TCPCHAT.OPTION.TRACE (QUOTE WILL) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.WILL) of OPTIONRECORD) OPTION)) (TELNET.WONT (TCPCHAT.OPTION.TRACE (QUOTE WONT) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.WONT) of OPTIONRECORD) OPTION)) (TELNET.SB (TCPCHAT.OPTION.TRACE (QUOTE SB) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.SB) of OPTIONRECORD) OPTION)) COMMAND)) (T (TCPCHAT.OPTION.TRACE COMMAND OPTION) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (QUOTE WONT) OPTION)))))
)

(TCPCHAT.OPTION.OUTPUT
(LAMBDA (OUTPUTSTREAM COMMAND OPTION) (* ; "Edited 17-Apr-87 16:34 by jrb:") (LET (CMDNUM) (COND ((NULL COMMAND)) ((SETQ CMDNUM (CDR (FASSOC COMMAND (BQUOTE ((WILL \, TELNET.WILL) (WONT \, TELNET.WONT) (DO \, TELNET.DO) (DONT \, TELNET.DONT)))))) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM CMDNUM OPTION (QUOTE SENDBACK))) (T (APPLY* COMMAND (TCP.OTHER.STREAM OUTPUTSTREAM))))))
)

(TCPCHAT.OPTION.TRACE
(LAMBDA (COMMAND OPTION PREFIX) (* ejs%: "22-Apr-85 16:41") (DECLARE (GLOBALVARS TCPCHAT.TRACEFLG TCPCHAT.TRACEFILE)) (COND (TCPCHAT.TRACEFLG (COND ((SMALLP COMMAND) (SETQ COMMAND (SELECTC COMMAND (TELNET.DO (QUOTE DO)) (TELNET.DONT (QUOTE DONT)) (TELNET.WILL (QUOTE WILL)) (TELNET.WONT (QUOTE WONT)) COMMAND)))) (printout TCPCHAT.TRACEFILE PREFIX ": " COMMAND " ") (PRINTCONSTANT OPTION TELNET.MARKS TCPCHAT.TRACEFILE) (TERPRI TCPCHAT.TRACEFILE))))
)

(TCPCHAT.TERMINAL.TYPE
(LAMBDA (INPUTSTREAM) (* ; "Edited 20-Apr-87 13:42 by jrb:") (LET ((COMMAND)) (SELECTC (\BUFFERED.BIN INPUTSTREAM) (TELNET.SEND (* ; "OK, should be followed by IAC SE") (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE "REQUEST IS SEND")) (IF (EQ (SETQ COMMAND (\BUFFERED.BIN INPUTSTREAM)) TELNET.IAC) THEN (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE " IAC")) ELSE (IF TCPCHAT.TRACEFLG THEN (printout " EXPECTED IAC, GOT " COMMAND))) (IF (EQ (SETQ COMMAND (\BUFFERED.BIN INPUTSTREAM)) TELNET.SE) THEN (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE " SE")) ELSE (IF TCPCHAT.TRACEFLG THEN (printout " EXPECTED SE, GOT " COMMAND))) (IF TCPCHAT.TRACEFLG THEN (TERPRI TCPCHAT.TRACEFILE)) (LET* ((OUTPUTSTREAM (TCP.OTHER.STREAM INPUTSTREAM)) (DISPLAYTYPE (OR (CDR (FASSOC (fetch (CHATDISPLAYTYPE DPYNAME) of (STREAMPROP INPUTSTREAM (QUOTE DISPLAYTYPE))) TCPCHAT.TELNET.TTY.TYPES)) (CDR (FASSOC (fetch (CHATDISPLAYTYPE DPYNAME) of (STREAMPROP OUTPUTSTREAM (QUOTE DISPLAYTYPE))) TCPCHAT.TELNET.TTY.TYPES))))) (BOUT OUTPUTSTREAM TELNET.IAC) (BOUT OUTPUTSTREAM TELNET.SB) (BOUT OUTPUTSTREAM TELNET.TERMINAL.TYPE) (BOUT OUTPUTSTREAM TELNET.IS) (PRIN1 DISPLAYTYPE OUTPUTSTREAM) (BOUT OUTPUTSTREAM TELNET.IAC) (BOUT OUTPUTSTREAM TELNET.SE) (FORCEOUTPUT OUTPUTSTREAM) (COND (TCPCHAT.TRACEFLG (printout TCPCHAT.TRACEFILE "SEND(BACK) IAC SB TERMINAL-TYPE IS " DISPLAYTYPE " IAC SE" T))))) (TELNET.IS (* ; "We told them we couldn't handle this - or would have had they asked...") (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE "REQUEST IS IS, which is an error: rest of command is:" T)) (WHILE (NEQ (SETQ COMMAND (\BUFFERED.BIN INPUTSTREAM)) TELNET.SE) DO (IF TCPCHAT.TRACEFLG THEN (PRIN1 (CHARACTER COMMAND) TCPCHAT.TRACEFILE))) (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE " SE" T))) (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE "REQUEST IS " COMMAND ", which is an error" T)))))
)
)

(RPAQQ TCPCHAT.TELNET.TTY.TYPES ((DM2500 . DATAMEDIA-2500)
                                     (VT100 . DEC-VT100)))

(RPAQQ TELNET.OPTIONS
       ((94 WONT WONT DONT DONT)
        (0 WILL WONT NIL DONT)
        (1 WONT WONT DO DO)
        (3 WILL WILL NIL NIL)
        (5 WONT WONT DONT DONT)
        (6 WILL NIL NIL NIL)
        (24 WILL NIL DONT NIL TCPCHAT.TERMINAL.TYPE)))

(RPAQ? TCPCHAT.TRACEFLG )

(RPAQ? TCPCHAT.TRACEFILE )

(FILESLOAD (SYSLOAD)
       TCP CHAT)
(DECLARE%: EVAL@COMPILE DONTCOPY 

(FILESLOAD CHATDECLS)


(RPAQQ TELNET.COMMANDS ((TELNET.SE 240)
                            (TELNET.SB 250)
                            (TELNET.WILL 251)
                            (TELNET.WONT 252)
                            (TELNET.DO 253)
                            (TELNET.DONT 254)
                            (TELNET.IAC 255)
                            (TELNET.SEND 1)
                            (TELNET.IS 0)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ TELNET.SE 240)

(RPAQQ TELNET.SB 250)

(RPAQQ TELNET.WILL 251)

(RPAQQ TELNET.WONT 252)

(RPAQQ TELNET.DO 253)

(RPAQQ TELNET.DONT 254)

(RPAQQ TELNET.IAC 255)

(RPAQQ TELNET.SEND 1)

(RPAQQ TELNET.IS 0)


(CONSTANTS (TELNET.SE 240)
       (TELNET.SB 250)
       (TELNET.WILL 251)
       (TELNET.WONT 252)
       (TELNET.DO 253)
       (TELNET.DONT 254)
       (TELNET.IAC 255)
       (TELNET.SEND 1)
       (TELNET.IS 0))
)

(RPAQQ TELNET.MARKS ((TELNET.BINARY 0)
                         (TELNET.ECHO 1)
                         (TELNET.SUPPRESS.GOAHEAD 3)
                         (TELNET.STATUS 5)
                         (TELNET.TIMING.MARK 6)
                         (TELNET.TERMINAL.TYPE 24)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ TELNET.BINARY 0)

(RPAQQ TELNET.ECHO 1)

(RPAQQ TELNET.SUPPRESS.GOAHEAD 3)

(RPAQQ TELNET.STATUS 5)

(RPAQQ TELNET.TIMING.MARK 6)

(RPAQQ TELNET.TERMINAL.TYPE 24)


(CONSTANTS (TELNET.BINARY 0)
       (TELNET.ECHO 1)
       (TELNET.SUPPRESS.GOAHEAD 3)
       (TELNET.STATUS 5)
       (TELNET.TIMING.MARK 6)
       (TELNET.TERMINAL.TYPE 24))
)

(DECLARE%: EVAL@COMPILE

(RECORD TELNET.OPTION (OPTION ON.DO ON.DONT ON.WILL ON.WONT ON.SB))

(RECORD TELNET.OPTIONSTATE (OPTION WILLING DOING))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS TCPCHAT.TELNET.TTY.TYPES TELNET.OPTIONS TELNET.MARKS)
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(ADDTOVAR CHAT.PROTOCOLTYPES (TCP . TCPCHAT.HOST.FILTER))

(ADDTOVAR CHAT.PROTOCOL.ABBREVS (N . TCP)
                                    (T . TCP))
)
(PUTPROPS TCPCHAT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1430 8610 (TCPCHAT.BIN 1440 . 1698) (TCPCHAT.HOST.FILTER 1700 . 1857) (
TCPCHAT.NEGOTIATE 1859 . 2027) (TCPCHAT.OPEN 2029 . 3387) (TCPCHAT.OPTION.COMMAND 3389 . 4679) (
TCPCHAT.OPTION.INPUT 4681 . 5785) (TCPCHAT.OPTION.OUTPUT 5787 . 6188) (TCPCHAT.OPTION.TRACE 6190 . 
6667) (TCPCHAT.TERMINAL.TYPE 6669 . 8608)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPCONFIG b/obsolete/tcp/TCPCONFIG
deleted file mode 100644
index 257f8dd5..00000000
--- a/obsolete/tcp/TCPCONFIG
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP")
(FILECREATED "12-Jun-90 16:11:50" {DSK}<usr>local>lde>lispcore>library>TCPCONFIG.;2 18742  

      changes to%:  (VARS TCPCONFIGCOMS)

      previous date%: "18-Apr-88 21:05:32" {DSK}<usr>local>lde>lispcore>library>TCPCONFIG.;1)


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

(PRETTYCOMPRINT TCPCONFIGCOMS)

(RPAQQ TCPCONFIGCOMS
       ((PROP MAKEFILE-ENVIRONMENT TCPCONFIG)
        (DECLARE%: EVAL@COMPILE DONTCOPY (COMS (RECORDS IPINIT))
               (GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY \IP.INIT.FILE \IP.SUBNET.MASKS 
                      \PROCESS.AFTEREXIT.EVENT \PROC.READY \AR.IP.TO.10MB.ALIST))
        (COMS (* TCP configuration module)
              (EXPORT (RECORDS IPINIT))
              (INITVARS (\IP.DEFAULT.CONFIGURATION (create IPINIT))
                     (\IPFLG NIL))
              (FILES TCPLLIP)
              (FNS TCP.CONFIGURE TCP.LIMITCHARS \TCPCONFIG.RESETFN \TCPCONFIG.QUITFN 
                   TCP.ALPHA.LIMITCHARS \TCPCONFIG.APPLYFN))))

(PUTPROPS TCPCONFIG MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP"))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD IPINIT (LOCAL.ADDRESSES LOCAL.NETWORKS DEFAULT.GATEWAY HTE.FILE HOSTNAME SUBNETMASK 
                          DOMAIN.SERVERS LOCAL.DOMAIN LOCAL.NSHOSTNUMBER))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY \IP.INIT.FILE \IP.SUBNET.MASKS 
       \PROCESS.AFTEREXIT.EVENT \PROC.READY \AR.IP.TO.10MB.ALIST)
)
)



(* TCP configuration module)

(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(RECORD IPINIT (LOCAL.ADDRESSES LOCAL.NETWORKS DEFAULT.GATEWAY HTE.FILE HOSTNAME SUBNETMASK 
                          DOMAIN.SERVERS LOCAL.DOMAIN LOCAL.NSHOSTNUMBER))
)

(* "END EXPORTED DEFINITIONS")


(RPAQ? \IP.DEFAULT.CONFIGURATION (create IPINIT))

(RPAQ? \IPFLG NIL)

(FILESLOAD TCPLLIP)
(DEFINEQ

(TCP.CONFIGURE
  [LAMBDA NIL
    (DECLARE (GLOBALVARS \IP.DEFAULT.CONFIGURATION)) (* ; "Edited 18-Mar-88 15:41 by bvm")
    (LET* ((CONFIG (OR (AND (INFILEP '{DSK}IP.INIT)
                            (\IP.READ.INIT.FILE '{DSK}IP.INIT))
                       \IP.DEFAULT.CONFIGURATION
                       (create IPINIT)))
           (TCP.FREEMENU
            (FREEMENU `((PROPS FONT (GACHA 12 BOLD))
                        ((PROPS BOX 2)
                         (LABEL " " TYPE DISPLAY)
                         (LABEL "Apply!" TYPE MOMENTARY SELECTEDFN \TCPCONFIG.APPLYFN)
                         (LABEL "     " TYPE DISPLAY)
                         (LABEL "Reset!" TYPE MOMENTARY SELECTEDFN \TCPCONFIG.RESETFN)
                         (LABEL "     " TYPE DISPLAY)
                         (LABEL "Quit!" TYPE MOMENTARY SELECTEDFN \TCPCONFIG.QUITFN)
                         (LABEL " " TYPE DISPLAY))
                        ((LABEL "" TYPE DISPLAY))
                        ((LABEL "      Host Name:" TYPE EDITSTART MESSAGE 
                                "Enter the name of this host" LINKS (EDIT HOST.NAME))
                         (LABEL ,(OR (fetch (IPINIT HOSTNAME) of CONFIG)
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID HOST.NAME LIMITCHARS TCP.ALPHA.LIMITCHARS))
                        ((LABEL "   Host Address:" TYPE EDITSTART MESSAGE 
                                "Enter the IP address of this host. Format: 13.0.10.5" LINKS
                                (EDIT ADDRESS))
                         (LABEL ,(OR (CAR (fetch (IPINIT LOCAL.ADDRESSES) of CONFIG))
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID ADDRESS LIMITCHARS TCP.LIMITCHARS))
                        ((LABEL "Network Address:" TYPE EDITSTART MESSAGE 
     "Enter the IP address of the local network.  Format: 13.0.0.0  Leave the host address fields 0." 
                                LINKS (EDIT NETWORK.ADDRESS))
                         (LABEL ,(OR (CAAR (fetch (IPINIT LOCAL.NETWORKS) of CONFIG))
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID NETWORK.ADDRESS LIMITCHARS TCP.LIMITCHARS))
                        ((LABEL "    Subnet mask:" TYPE EDITSTART MESSAGE "Enter the subnet mask.  Format: 13.255.252.0  If the bitwise-AND of this address and any destination IP address is not equal to the bitwise-AND of this address and the host's local IP address, the destination IP address will be considered to be on another (sub)network" 
                                LINKS (EDIT SUBNET.MASK))
                         (LABEL ,(OR (CAR (fetch (IPINIT SUBNETMASK) of CONFIG))
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID SUBNET.MASK LIMITCHARS TCP.LIMITCHARS))
                        ((LABEL "Default Gateway:" TYPE EDITSTART MESSAGE 
                      "Enter the IP address of the default gateway for this host.  Format 13.0.10.34" 
                                LINKS (EDIT DEFAULT.GATEWAY))
                         (LABEL ,(OR (fetch (IPINIT DEFAULT.GATEWAY) of CONFIG)
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID DEFAULT.GATEWAY LIMITCHARS TCP.ALPHA.LIMITCHARS))
                        ((LABEL "   Local Domain:" TYPE EDITSTART MESSAGE 
                                "Enter the name of the Internet domain in which this host resides" 
                                LINKS (EDIT LOCAL.DOMAIN))
                         (LABEL ,(OR (fetch (IPINIT LOCAL.DOMAIN) of CONFIG)
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID LOCAL.DOMAIN LIMITCHARS TCP.ALPHA.LIMITCHARS))
                        ((LABEL " Domain servers:" TYPE EDITSTART MESSAGE 
              "Enter the IP addresses of the local domain servers.  Format 13.0.10.21 12.0.15.22 ..." 
                                LINKS (EDIT DOMAIN.SERVERS))
                         (LABEL ,(if (fetch (IPINIT DOMAIN.SERVERS) of CONFIG)
                                     then (for ADDRESS in (fetch (IPINIT 
                                                                                       DOMAIN.SERVERS
                                                                                        )
                                                                         of CONFIG)
                                                 bind (STRING _ "")
                                                 do (SETQ STRING (CONCAT STRING ADDRESS " "))
                                                 finally (RETURN (SUBSTRING STRING 1 -2)))
                                   else "") FONT (GACHA 12)
                                TYPE EDIT ID DOMAIN.SERVERS LIMITCHARS TCP.ALPHA.LIMITCHARS))
                        ((LABEL " Hosts.txt file:" TYPE EDITSTART MESSAGE 
 "Enter the name of the Hosts.txt file to be used for translating IP hostnames to IP host addresses." 
                                LINKS (EDIT HOSTS.FILE))
                         (LABEL ,(OR (fetch (IPINIT HTE.FILE) of CONFIG)
                                     "") FONT (GACHA 12)
                                TYPE EDIT ID HOSTS.FILE LIMITCHARS TCP.ALPHA.LIMITCHARS))) 
                   "TCP Configuration"))
           (REG (WINDOWPROP TCP.FREEMENU 'REGION))
           (WIDTH (fetch (REGION WIDTH) of REG))
           (HEIGHT (fetch (REGION HEIGHT) of REG)))
          (WINDOWPROP TCP.FREEMENU 'MINSIZE (CONS WIDTH HEIGHT))
          (WINDOWPROP TCP.FREEMENU 'MAXSIZE (CONS 65535 HEIGHT))
          (MOVEW TCP.FREEMENU (GETBOXPOSITION WIDTH HEIGHT))
          (OPENW TCP.FREEMENU)
          NIL])

(TCP.LIMITCHARS
  [LAMBDA (ITEM WINDOW CHARACTER)                        (* ; "Edited 20-Jan-88 15:37 by Snow")
          
          (* ;; "allows numbers or periods until a CR then skips to the next item in the menu.")

    (COND
       ((FMEMB CHARACTER '(0 1 2 3 4 5 6 7 8 9 %.))
        T)
       ((EQ (CHARACTER (CHARCODE EOL))
            CHARACTER)
        (FM.SKIPNEXT WINDOW))
       (T NIL])

(\TCPCONFIG.RESETFN
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 18-Jan-88 18:32 by Briggs") (AND (GETPROMPTWINDOW WINDOW) (CLEARW (GETPROMPTWINDOW WINDOW))) (FM.RESETMENU WINDOW))
)

(\TCPCONFIG.QUITFN
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 18-Jan-88 15:40 by Briggs") (FM.ENDEDIT WINDOW) (CLOSEW WINDOW))
)

(TCP.ALPHA.LIMITCHARS
  [LAMBDA (ITEM WINDOW CHAR)                             (* ; "Edited 20-Jan-88 15:32 by Snow")
          
          (* ;; "This function will allow all characters until a CR then call Fm.Skipnext to move on to the next entry in the table.")

    (IF (EQ (CHARACTER (CHARCODE CR))
                CHAR)
        THEN (FM.SKIPNEXT WINDOW)
      ELSE T])

(\TCPCONFIG.APPLYFN
  [LAMBDA (ITEM WINDOW BUTTONS)                          (* ; "Edited 18-Mar-88 18:37 by bvm")
          (* ;; "Before reseting any of the parameters, verify their validity")

    (FM.ENDEDIT WINDOW)
    (PROG ((STATE (FM.GETSTATE WINDOW))
           (FMPROMPTWINDOW (GETPROMPTWINDOW WINDOW 3))
           (CONFIG (create IPINIT
                          LOCAL.NSHOSTNUMBER _ \MY.NSHOSTNUMBER))
           IPADDRESS SCRATCH)
          (* ;; "Before reseting any of the parameters, verify their validity")

          (CLEARW FMPROMPTWINDOW)
          (* ;; "So we don't have to check later...")

          (if (NOT (OR \10MBLOCALNDB \3MBLOCALNDB))
              then (printout FMPROMPTWINDOW "This machine doesn't appear to be on any networks!")
                    (RETURN))
          (* ;; "")
          (* ;; "Host name is required")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'HOST.NAME))
          (if (STRING-EQUAL SCRATCH "")
              then (printout FMPROMPTWINDOW "Host name is required!")
                    (FM.EDITITEM (FM.GETITEM 'HOST.NAME NIL WINDOW)
                           WINDOW)
                    (RETURN))
          (replace (IPINIT HOSTNAME) of CONFIG with SCRATCH)
          (* ;; "")
          (* ;; " Verify host address")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'ADDRESS))
          (if (STRING-EQUAL SCRATCH "")
              then (printout FMPROMPTWINDOW "Host address is required!")
                    (FM.EDITITEM (FM.GETITEM 'ADDRESS NIL WINDOW)
                           WINDOW)
                    (RETURN)
            elseif (OR (NULL (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH)))
                           (ZEROP (\IPNETADDRESS IPADDRESS)))
              then (printout FMPROMPTWINDOW "Malformed host address: " SCRATCH)
                    (FM.EDITITEM (FM.GETITEM 'ADDRESS NIL WINDOW)
                           WINDOW)
                    (RETURN))
          (replace (IPINIT LOCAL.ADDRESSES) of CONFIG with (LIST (\IP.ADDRESS.TO.STRING
                                                                              IPADDRESS)))
          (* ;; "")
          (* ;; "Verify network address.  The list is an alist keyed by network address, and containing the atom 10 or 3 indicating the kind of network.  We assume the host is only on one network.")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'NETWORK.ADDRESS))
          (if (STRING-EQUAL SCRATCH "")
              then (printout FMPROMPTWINDOW "Network address is required!")
                    (FM.EDITITEM (FM.GETITEM 'NETWORK.ADDRESS NIL WINDOW)
                           WINDOW)
                    (RETURN)
            elseif (OR (NULL (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH)))
                           (ZEROP (\IPNETADDRESS IPADDRESS)))
              then (printout FMPROMPTWINDOW "Malformed network address: " SCRATCH)
                    (FM.EDITITEM (FM.GETITEM 'NETWORK.ADDRESS NIL WINDOW)
                           WINDOW)
                    (RETURN))
          [replace (IPINIT LOCAL.NETWORKS) of CONFIG
             with (LIST (CONS (\IP.ADDRESS.TO.STRING IPADDRESS)
                                  (if \10MBLOCALNDB
                                      then 10
                                    else 3]
          (* ;; "")
          (* ;; " Verify subnet mask")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'SUBNET.MASK))
          (if (STRING-EQUAL SCRATCH "")
              then (printout FMPROMPTWINDOW "Subnet mask is required!")
                    (FM.EDITITEM (FM.GETITEM 'SUBNET.MASK NIL WINDOW)
                           WINDOW)
                    (RETURN)
            elseif (OR (NULL (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH)))
                           (ZEROP (\IPNETADDRESS IPADDRESS)))
              then (printout FMPROMPTWINDOW "Malformed subnet mask: " SCRATCH)
                    (FM.EDITITEM (FM.GETITEM 'SUBNET.MASK NIL WINDOW)
                           WINDOW)
                    (RETURN))
          (replace (IPINIT SUBNETMASK) of CONFIG with (LIST (\IP.ADDRESS.TO.STRING 
                                                                               IPADDRESS)))
          (* ;; "")
          (* ;; "Verify default gateway, may be empty if none.")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'DEFAULT.GATEWAY))
          (if (STRING-EQUAL SCRATCH "")
              then (SETQ IPADDRESS NIL)
            elseif (NOT (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH)))
              then (printout FMPROMPTWINDOW "Malformed default gateway address: " SCRATCH)
                    (FM.EDITITEM (FM.GETITEM 'DEFAULT.GATEWAY NIL WINDOW)
                           WINDOW)
                    (RETURN))
          (replace (IPINIT DEFAULT.GATEWAY) of CONFIG with (AND IPADDRESS (
                                                                                \IP.ADDRESS.TO.STRING
                                                                                       IPADDRESS)))
          (* ;; "")
          (* ;; "Local domain.  May be empty.")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'LOCAL.DOMAIN))
          (if (STRING-EQUAL SCRATCH "")
              then (SETQ SCRATCH NIL))
          (replace (IPINIT LOCAL.DOMAIN) of CONFIG with SCRATCH)
          (* ;; "")
          (* ;; "Verify domain server address(es) are well formed.")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'DOMAIN.SERVERS))
          (if (STRING-EQUAL SCRATCH "")
              then (SETQ IPADDRESS NIL)
            else [SETQ IPADDRESS (bind (END _ 0)
                                            (BITTABLE _ (MAKEBITTABLE (LIST (CHARCODE SPACE))
                                                               T))
                                            (START _ NIL)
                                        eachtime [SETQ START (STRPOSL BITTABLE SCRATCH
                                                                        (ADD1 (OR END 65534]
                                              (SETQ END (STRPOS " " SCRATCH START))
                                        until (NULL START)
                                        collect (\IP.READ.STRING.ADDRESS (SUBSTRING SCRATCH
                                                                                    (OR START 1)
                                                                                    END]
                  (if (FMEMB NIL IPADDRESS)
                      then (printout FMPROMPTWINDOW "Malformed domain server addresses: " SCRATCH
                                      )
                            (FM.EDITITEM (FM.GETITEM 'DOMAIN.SERVERS NIL WINDOW)
                                   WINDOW)
                            (RETURN)))
          [replace (IPINIT DOMAIN.SERVERS) of CONFIG with
                                                             (AND IPADDRESS
                                                                  (for ADDR in IPADDRESS
                                                                     collect (
                                                                                \IP.ADDRESS.TO.STRING
                                                                                  ADDR]
          (* ;; "")
          (* ;; "Hosts.txt file (may not yet exist)")
          (* ;; "")

          (SETQ SCRATCH (LISTGET STATE 'HOSTS.FILE))
          (if (if (NOT (STRING-EQUAL SCRATCH ""))
                    elseif (NOT *IP-DEFAULT-HOSTS-FILE*)
                      then                               (* ; 
                               "If there's a site default, we can leave this empty for flexibility")
                            (FM.CHANGESTATE (FM.GETITEM 'HOSTS.FILE NIL WINDOW)
                                   (SETQ SCRATCH "{DSK}HOSTS.TXT")
                                   WINDOW)
                            T)
              then (replace (IPINIT HTE.FILE) of CONFIG with SCRATCH))
          (* ;; "")
          (* ;; "write the information back on the IP.INIT file")
          (* ;; "")

          (printout FMPROMPTWINDOW "Writing {dsk}ip.init... ")
          [LET ((*UPPER-CASE-FILE-NAMES* NIL))
               (CL:WITH-OPEN-FILE (STREAM '{DSK}IP.INIT :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
                      (PRIN2 CONFIG STREAM (FIND-READTABLE "INTERLISP"]
          (printout FMPROMPTWINDOW "done.")
          (* ;; "")
          (* ;; "See if they want to restart TCP with the new configuration.")
          (* ;; "")

          (COND
             ((AND \IPFLG (MOUSECONFIRM "Restart TCP with the new values?" NIL FMPROMPTWINDOW T))
                                                             (* ; 
                                                       "tcp is running and they want it restarted.")
              (PRINTOUT FMPROMPTWINDOW T "Restarting...")
              (STOPIP)
              (SETQ \IP.DEFAULT.CONFIGURATION NIL)
              (\IPINIT)
          (* ;; "let the user know we are done.")

              (PRINTOUT FMPROMPTWINDOW "done."])
)
(PUTPROPS TCPCONFIG COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2032 18633 (TCP.CONFIGURE 2042 . 7956) (TCP.LIMITCHARS 7958 . 8375) (\TCPCONFIG.RESETFN
 8377 . 8561) (\TCPCONFIG.QUITFN 8563 . 8695) (TCP.ALPHA.LIMITCHARS 8697 . 9098) (\TCPCONFIG.APPLYFN 
9100 . 18631)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPDEBUG b/obsolete/tcp/TCPDEBUG
deleted file mode 100644
index 1b0b73dd..00000000
--- a/obsolete/tcp/TCPDEBUG
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "23-Aug-90 17:10:14" {DSK}<LISPFILES>TCP>TCPDEBUG.;2 27328  

      changes to%:  (VARS TCPDEBUGCOMS)

      previous date%: "15-Feb-89 13:41:39" {DSK}<LISPFILES>TCP>TCPDEBUG.;1)


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

(PRETTYCOMPRINT TCPDEBUGCOMS)

(RPAQQ TCPDEBUGCOMS ((COMS 
                               (* ;; "standard TCP small servers")

                               (FNS TCP.SINK.SERVER TCP.TELNET.SERVER \TCP.SINK.PROCESS 
                                    TCP.ECHO.SERVER \TCP.ECHO.PROCESS))
                         (COMS 
                               (* ;; "TCP tracing and debugging info")

                               (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                                                       TCP)
                                      (CONSTANTS LIGHTGRAYSHADE))
                               (GLOBALVARS TCPTRACEFLG TCPTRACEFILE TCPTRACEMENU \TCP.ELAPSED.TIME 
                                      \TCP.DEBUGGABLE)
                               (INITVARS TCPTRACEFLG TCPTRACEFILE TCPTRACEMENU \TCP.ELAPSED.TIME 
                                      NETTRACETITLEREG)
                               (VARS (\TCP.DEBUGGABLE T))
                               (BITMAPS NETTRACEICON NETTRACEMASK)
                               (FILES (SYSLOAD)
                                      TCP)
                               (FNS TCP.PRINT.SEGMENT \TCP.PRINT.OPTIONS \TCP.PRINT.ELAPSED.TIME 
                                    \TCP.PRINT.SEGMENT.QUEUE TCPTRACE \TCPTRACEMENU.ITEMFN 
                                    \TCPTRACEMENU.DISPLAYFN TCP.DRIBBLE))
                         (COMS 
                               (* ;; "miscellaneous TCP debugging")

                               (GLOBALVARS \TCP.LOSSAGE \TCP.LOOPBACK.QUEUE \TCP.LOOPBACK.EVENT 
                                      \TCP.MASTER.SOCKET)
                               (INITVARS \TCP.LOSSAGE \TCP.LOOPBACK.QUEUE \TCP.LOOPBACK.EVENT)
                               (FNS TCP.DEBUG TCP.WATCHER DUMMY\IP\Transmit\Packet 
                                    \TCP.CHECK.INPUT.QUEUE TCP.FAUCET TCP.ECHOTEST TCP.QUIET.ECHOTEST
                                    TCP.SINKTEST GENERATE.RANDOM.CHARS COPYBYTESTREAM 
                                    TCP.COPYTOWINDOW TEST.CHECKSUM))))



(* ;; "standard TCP small servers")

(DEFINEQ

(TCP.SINK.SERVER
  [LAMBDA (PORT)                                             (* ecc "14-May-84 16:32")
    (bind STREAM do (if (SETQ STREAM (TCP.OPEN NIL NIL (OR PORT \TCP.SINK.PORT)
                                            'PASSIVE
                                            'INPUT T))
                        then (ADD.PROCESS `(\TCP.SINK.PROCESS %, STREAM) 'NAME "TCP Sink"])

(TCP.TELNET.SERVER
  [LAMBDA NIL                                                (* ejs%: "20-Jun-85 12:38")
    (LET ((INSTREAM (TCP.OPEN NIL NIL \TCP.TELNET.PORT 'PASSIVE 'INPUT))
          OUTSTREAM)
         (COND
            (INSTREAM (SETQ OUTSTREAM (TCP.OTHER.STREAM INSTREAM))
                   (ADD.PROCESS (LIST '\TCP.ECHO.PROCESS (KWOTE INSTREAM)
                                      (KWOTE OUTSTREAM))
                          'NAME "Telnet echo")
                   (ADD.PROCESS '(TCP.TELNET.SERVER))
                   (GENERATE.RANDOM.CHARS OUTSTREAM])

(\TCP.SINK.PROCESS
  [LAMBDA (STREAM)                                           (* ejs%: " 7-Jun-85 13:11")
    (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                         STREAM))
    (replace (STREAM ENDOFSTREAMOP) of STREAM with (FUNCTION NILL))
    (until (EOFP STREAM) do (BIN STREAM])

(TCP.ECHO.SERVER
  [LAMBDA (PORT)                                             (* ecc "14-May-84 16:35")
    (bind STREAM do (if (SETQ STREAM (TCP.OPEN NIL NIL (OR PORT \TCP.ECHO.PORT)
                                            'PASSIVE
                                            'INPUT T))
                        then (ADD.PROCESS `(\TCP.ECHO.PROCESS %, STREAM %, (TCP.OTHER.STREAM STREAM))
                                    'NAME "TCP Echo"])

(\TCP.ECHO.PROCESS
  [LAMBDA (INSTR OUTSTR)                                     (* ejs%: "25-Mar-86 18:07")
    (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                         INSTR))
    (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                         OUTSTR))
    (bind C until (OR (NOT (OPENP INSTR 'INPUT))
                      (EOFP INSTR)) do [COND
                                          [(CAR (NLSETQ (READP INSTR)))
                                           (SETQ C (CAR (NLSETQ (BIN INSTR]
                                          (T (FORCEOUTPUT OUTSTR)
                                             (SETQ C (CAR (NLSETQ (BIN INSTR]
                                       [COND
                                          (C (NLSETQ (BOUT OUTSTR C]
                                       (if (OR (NOT (NLSETQ (READP INSTR)))
                                               (NOT (OPENP INSTR 'INPUT))
                                               (EOFP INSTR))
                                           then (NLSETQ (FORCEOUTPUT OUTSTR])
)



(* ;; "TCP tracing and debugging info")

(DECLARE%: EVAL@COMPILE DONTCOPY 

(FILESLOAD (LOADCOMP)
       TCP)

(DECLARE%: EVAL@COMPILE 

(RPAQQ LIGHTGRAYSHADE 1025)


(CONSTANTS LIGHTGRAYSHADE)
)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS TCPTRACEFLG TCPTRACEFILE TCPTRACEMENU \TCP.ELAPSED.TIME \TCP.DEBUGGABLE)
)

(RPAQ? TCPTRACEFLG NIL)

(RPAQ? TCPTRACEFILE NIL)

(RPAQ? TCPTRACEMENU NIL)

(RPAQ? \TCP.ELAPSED.TIME NIL)

(RPAQ? NETTRACETITLEREG NIL)

(RPAQQ \TCP.DEBUGGABLE T)

(RPAQQ NETTRACEICON #*(72 72)AOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOON@@@G@@@@@@@@@@@@@@@G@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@G@@@@@@@@@@@@@@@G@@@COOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@F@@@DIBDL@@@@@@@@@@@F@@@DIBDL@@@@@@@@@@@F@@@DIBDL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@F@@@@@@@L@@@@@L@@@@@F@@@@@@@L@@@@@N@@@@@F@@@@@@@L@@@@@K@@@@@GH@@@@@CLCOOOOIH@@@@F@@@@@@@LGOOOOHL@@@@F@@@@@@@LD@@@@@F@@@@F@@@@@@@LD@@@@@C@@@@GOOOOOOOLD@@@@@A@@@@F@@@@@@@LD@@@@@B@@@@F@@@@@@@LD@@@@@D@@@@F@@@@@@@LGOOOOHH@@@@GH@@@@@CL@@@@@I@@@@@F@@@@@@@L@@@@@J@@@@@F@@@@@@@L@@@@@L@@@@@F@@@@@@@L@@@@@H@@@@@GH@@@@@CL@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@GOOOOOOOL@@D@@@@@@@@F@@@@@@@L@@L@@@@@@@@F@@@@@@@L@AL@@@@@@@@F@@@@@@@L@BL@@@@@@@@GH@@@@@CL@DOOOOOH@@@F@@@@@@@L@HOOOOOH@@@F@@@@@@@LA@@@@@AH@@@F@@@@@@@LB@@@@@AH@@@GOOOOOOOLD@@@@@AH@@@F@@@@@@@LB@@@@@AH@@@F@@@D@@@LA@@@@@AH@@@F@@@D@@@L@HOOOOO@@@@F@@@@@@@L@DL@@@@@@@@F@@@D@@@L@BL@@@@@@@@F@@@D@@@L@AL@@@@@@@@F@@@@@@@L@@H@@@@@@@@F@@@D@@@L@@@@@@@@@@@F@@@D@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@
)

(RPAQQ NETTRACEMASK #*(72 72)AOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOON@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@L@@@@@GOOOOOOOL@@@@@N@@@@@GOOOOOOOL@@@@@O@@@@@GOOOOOOOLCOOOOOH@@@@GOOOOOOOLGOOOOOL@@@@GOOOOOOOLGOOOOON@@@@GOOOOOOOLGOOOOOO@@@@GOOOOOOOLGOOOOOO@@@@GOOOOOOOLGOOOOON@@@@GOOOOOOOLGOOOOOL@@@@GOOOOOOOLGOOOOOH@@@@GOOOOOOOL@@@@@O@@@@@GOOOOOOOL@@@@@N@@@@@GOOOOOOOL@@@@@L@@@@@GOOOOOOOL@@@@@H@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@D@@@@@@@@GOOOOOOOL@@L@@@@@@@@GOOOOOOOL@AL@@@@@@@@GOOOOOOOL@CL@@@@@@@@GOOOOOOOL@GOOOOOH@@@GOOOOOOOL@OOOOOOH@@@GOOOOOOOLAOOOOOOH@@@GOOOOOOOLCOOOOOOH@@@GOOOOOOOLGOOOOOOH@@@GOOOOOOOLCOOOOOOH@@@GOOOOOOOLAOOOOOOH@@@GOOOOOOOL@OOOOOO@@@@GOOOOOOOL@GL@@@@@@@@GOOOOOOOL@CL@@@@@@@@GOOOOOOOL@AL@@@@@@@@GOOOOOOOL@@H@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@
)

(FILESLOAD (SYSLOAD)
       TCP)
(DEFINEQ

(TCP.PRINT.SEGMENT
  [LAMBDA (SEGMENT FILE NOFROMTOFLG DATAFLG)                 (* ejs%: "20-Jun-85 16:06")
    (PROG ((SEPR "")
           (COMMA ",")
           (SEQ (fetch TCP.SEQ of SEGMENT))
           (LEN (\TCP.DATA.LENGTH SEGMENT))
           (FLAGS (fetch TCP.CTRL of SEGMENT))
           TOP BASE)
          (if (NOT NOFROMTOFLG)
              then (printout FILE "from " %# (\IP.PRINT.ADDRESS (fetch TCP.SRC.ADDR of SEGMENT)
                                                    FILE)
                          ":"
                          (fetch TCP.SRC.PORT of SEGMENT)
                          " to " %# (\IP.PRINT.ADDRESS (fetch TCP.DST.ADDR of SEGMENT)
                                           FILE)
                          ":"
                          (fetch TCP.DST.PORT of SEGMENT)
                          T))
          (printout FILE SEQ)
          [SETQ TOP (SUB1 (IPLUS SEQ LEN (\TCP.SYN.OR.FIN FLAGS T]
          (if (\32BIT.LT SEQ TOP)
              then (printout FILE ".." TOP))
          (printout FILE "/" (fetch TCP.ACK of SEGMENT)
                 " [")
          (if (BITTEST FLAGS \TCP.CTRL.URG)
              then (printout FILE SEPR "URG")
                   (SETQ SEPR COMMA))
          (if (BITTEST FLAGS \TCP.CTRL.ACK)
              then (printout FILE SEPR "ACK")
                   (SETQ SEPR COMMA))
          (if (BITTEST FLAGS \TCP.CTRL.PSH)
              then (printout FILE SEPR "PSH")
                   (SETQ SEPR COMMA))
          (if (BITTEST FLAGS \TCP.CTRL.RST)
              then (printout FILE SEPR "RST")
                   (SETQ SEPR COMMA))
          (if (BITTEST FLAGS \TCP.CTRL.SYN)
              then (printout FILE SEPR "SYN")
                   (SETQ SEPR COMMA))
          (if (BITTEST FLAGS \TCP.CTRL.FIN)
              then (printout FILE SEPR "FIN")
                   (SETQ SEPR COMMA))
          (printout FILE "] window = " (fetch TCP.WINDOW of SEGMENT)
                 " checksum = "
                 (fetch TCP.CHECKSUM of SEGMENT)
                 " length = " LEN T)
          (if (IGREATERP (fetch TCP.DATA.OFFSET of SEGMENT)
                     \TCP.MIN.DATA.OFFSET)
              then (\TCP.PRINT.OPTIONS SEGMENT FILE))
          (if (AND DATAFLG (NOT (ZEROP LEN)))
              then (printout FILE "Contents:")
                   (SETQ BASE (fetch TCP.CONTENTS of SEGMENT))
                   (for (I _ 0) to (SUB1 LEN) do (PRIN1 (CHARACTER (\GETBASEBYTE BASE I))
                                                        FILE))
                   (TERPRI FILE])

(\TCP.PRINT.OPTIONS
  [LAMBDA (SEGMENT FILE)                                     (* ejs%: "20-Jun-85 13:22")
          
          (* * Process the options in a TCP header)

    (printout FILE "Options: ")
    (bind (OPTIONBASE _ (fetch (TCPSEGMENT TCP.OPTIONS) of SEGMENT))
          (OPTIONOFFSET _ 0)
          OPTION eachtime (SETQ OPTION (\GETBASEBYTE OPTIONBASE OPTIONOFFSET))
       until (EQ OPTION \TCPOPT.END)
       do (SELECTC OPTION
              (\TCPOPT.END (printout FILE "end")
                           (add OPTIONOFFSET 1))
              (\TCPOPT.NOP (printout FILE "nop")
                           (add OPTIONOFFSET 1))
              (\TCPOPT.MAXSEG 
                   [printout FILE "maxseg: " (LOGOR (LLSH (\GETBASEBYTE OPTIONBASE (IPLUS 
                                                                                         OPTIONOFFSET 
                                                                                          2))
                                                          BITSPERBYTE)
                                                    (\GETBASEBYTE OPTIONBASE (IPLUS OPTIONOFFSET 3]
                   (add OPTIONOFFSET (\GETBASEBYTE OPTIONBASE (ADD1 OPTIONOFFSET))))
              (RETURN))
          (printout FILE " "])

(\TCP.PRINT.ELAPSED.TIME
  [LAMBDA (FILE)                                             (* ecc "23-Apr-84 12:32")
    (if (MEMB 'TIME TCPTRACEFLG)
        then (PROG ((NOW (SETUPTIMER 0 NIL 'MILLISECONDS))
                    INTERVAL)
                   (SETQ INTERVAL (IDIFFERENCE NOW (OR \TCP.ELAPSED.TIME NOW)))
                   (SETQ \TCP.ELAPSED.TIME NOW)
                   (printout FILE (IQUOTIENT INTERVAL 1000)
                          "." |.I3..T| (IMOD INTERVAL 1000)
                          " "])

(\TCP.PRINT.SEGMENT.QUEUE
  [LAMBDA (CALLER QUEUE FILE)                                (* ecc "18-Apr-84 14:38")
    (PROG ((SEGMENT (fetch SYSQUEUEHEAD of QUEUE)))
          (printout FILE .TAB0 0 CALLER ":" T)
          (while SEGMENT do (TCP.PRINT.SEGMENT SEGMENT FILE T)
                            (SETQ SEGMENT (fetch QLINK of SEGMENT])

(TCPTRACE
  [LAMBDA NIL                                                (* ; "Edited 15-Apr-87 15:22 by jrb:")
    (PROG (MW)
          (if (WINDOWP TCPTRACEFILE)
              then (TOTOPW TCPTRACEFILE)
                   (RETURN))
          (SETQ TCPTRACEFILE (CREATEW))
          [WINDOWADDPROP TCPTRACEFILE 'CLOSEFN (FUNCTION (LAMBDA (WINDOW)
                                                           (if (EQ WINDOW TCPTRACEFILE)
                                                               then (SETQ TCPTRACEFLG NIL)
                                                                    (SETQ TCPTRACEFILE T]
          (DSPFONT (FONTCREATE 'GACHA 8)
                 TCPTRACEFILE)
          (DSPSCROLL T TCPTRACEFILE)
          [if (NOT (type? MENU TCPTRACEMENU))
              then (SETQ TCPTRACEMENU (create MENU
                                             TITLE _ "TCP Trace Window"
                                             ITEMS _ '(("Incoming" RECV "Trace incoming segments")
                                                       ("Time" TIME 
                                                              "Print elapsed time between events")
                                                       ("Transitions" TRANSITION 
                                                              "Trace connection state transitions")
                                                       ("Outgoing" SEND "Trace outgoing segments")
                                                       ("Contents" CONTENTS 
                                                            "Print contents of segments when tracing"
                                                              )
                                                       ("Checksums" CHECKSUM 
                                                              "Trace segments with bad checksums"))
                                             MENUROWS _ 2
                                             CENTERFLG _ T
                                             WHENSELECTEDFN _ (FUNCTION \TCPTRACEMENU.ITEMFN)))
            else (FOR ITEM IN (FETCH (MENU ITEMS) OF TCPTRACEMENU)
                    DO (IF (MEMB (CADR ITEM)
                                 TCPTRACEFLG)
                           THEN (SHADEITEM ITEM TCPTRACEMENU LIGHTGRAYSHADE)
                         ELSE (SHADEITEM ITEM TCPTRACEMENU WHITESHADE]
          (ATTACHMENU TCPTRACEMENU TCPTRACEFILE 'TOP)
          [SETQ MW (CAR (WINDOWPROP TCPTRACEFILE 'ATTACHEDWINDOWS]
          (WINDOWADDPROP MW 'REPAINTFN (FUNCTION \TCPTRACEMENU.DISPLAYFN))
          (WINDOWADDPROP MW 'RESHAPEFN (FUNCTION \TCPTRACEMENU.DISPLAYFN])

(\TCPTRACEMENU.ITEMFN
  [LAMBDA (ITEM MENU MOUSEKEY)                               (* ecc "23-Apr-84 13:37")
    (PROG (FLG)
          (if (NULL ITEM)
              then (RETURN))
          (SETQ FLG (CADR ITEM))
          (if (MEMB FLG TCPTRACEFLG)
              then (SHADEITEM ITEM MENU WHITESHADE)
                   (SETQ TCPTRACEFLG (DREMOVE FLG TCPTRACEFLG))
            else (SHADEITEM ITEM MENU LIGHTGRAYSHADE)
                 (SETQ TCPTRACEFLG (CONS FLG TCPTRACEFLG])

(\TCPTRACEMENU.DISPLAYFN
  [LAMBDA (WINDOW)                                           (* ecc "23-Apr-84 13:49")
    (PROG [(MENU (CAR (WINDOWPROP WINDOW 'MENU]
          (for ITEM in (fetch ITEMS of MENU) when (MEMB (CADR ITEM)
                                                        TCPTRACEFLG)
             do (SHADEITEM ITEM MENU LIGHTGRAYSHADE])

(TCP.DRIBBLE
  [LAMBDA (FORM FILE)                                        (* ecc "18-Apr-84 14:39")
    (if (NULL FILE)
        then (SETQ FILE '{DSK}TCP.Transcript))
    (RESETLST (RESETSAVE TCPTRACEFILE (OPENFILE FILE 'OUTPUT))
           (RESETSAVE TCPTRACEFLG T)
           (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                TCPTRACEFILE))
           (PRINT FORM TCPTRACEFILE)
           (TERPRI TCPTRACEFILE)
           (EVAL FORM])
)



(* ;; "miscellaneous TCP debugging")

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCP.LOSSAGE \TCP.LOOPBACK.QUEUE \TCP.LOOPBACK.EVENT \TCP.MASTER.SOCKET)
)

(RPAQ? \TCP.LOSSAGE NIL)

(RPAQ? \TCP.LOOPBACK.QUEUE NIL)

(RPAQ? \TCP.LOOPBACK.EVENT NIL)
(DEFINEQ

(TCP.DEBUG
  [LAMBDA (ON?)                                              (* edited%: "21-May-84 13:56")
    (if ON?
        then (TCP.STOP)
             (if (NOT (DEFINEDP 'REAL\IP\Transmit\Packet))
                 then (MOVD 'IP\Transmit\Packet 'REAL\IP\Transmit\Packet))
             (MOVD 'DUMMY\IP\Transmit\Packet 'IP\Transmit\Packet)
             (if (NULL \TCP.LOOPBACK.EVENT)
                 then (SETQ \TCP.LOOPBACK.EVENT (CREATE.EVENT)))
             (if (NULL \TCP.LOOPBACK.QUEUE)
                 then (SETQ \TCP.LOOPBACK.QUEUE (create SYSQUEUE)))
             [if (NOT (FIND.PROCESS 'TCP.WATCHER))
                 then (ADD.PROCESS '(TCP.WATCHER]
      else (if (DEFINEDP 'REAL\IP\Transmit\Packet)
               then (MOVD 'REAL\IP\Transmit\Packet 'IP\Transmit\Packet))
           (DEL.PROCESS 'TCP.WATCHER)
           (\TCP.INIT])

(TCP.WATCHER
  [LAMBDA NIL                                                (* ecc " 3-May-84 11:10")
                                                             (* process to handle software loopback 
                                                             of segments)
    (RESETSAVE NIL (LIST (FUNCTION \FLUSH.PACKET.QUEUE)
                         \TCP.LOOPBACK.QUEUE))
    (bind SEGMENT do (SETQ SEGMENT (\DEQUEUE \TCP.LOOPBACK.QUEUE))
                     (if SEGMENT
                         then (\TCP.PACKET.FILTER SEGMENT \TCP.PROTOCOL)
                       else (AWAIT.EVENT \TCP.LOOPBACK.EVENT])

(DUMMY\IP\Transmit\Packet
  [LAMBDA (EPKT)                                             (* ejs%: " 5-Jan-85 16:57")
                                                             (* Software loopback.)
    (PROG ([OK (NOT (AND \TCP.LOSSAGE (EQ (RAND 1 \TCP.LOSSAGE)
                                          1]
           SEGMENT)
          (CHECK (OR (NULL (fetch QLINK of EPKT))
                     (SHOULDNT "transmitting queued segment")))
          (if OK
              then (SETQ SEGMENT (\ALLOCATE.ETHERPACKET))
                   (\BLT (\IPDATABASE SEGMENT)
                         (\IPDATABASE EPKT)
                         (FOLDHI (ADD1 (fetch (IP IPTOTALLENGTH) of EPKT))
                                BYTESPERWORD)))
          (if (EQ (fetch EPREQUEUE of EPKT)
                  'FREE)
              then (\RELEASE.ETHERPACKET EPKT)
            elseif (type? SYSQUEUE (fetch EPREQUEUE of EPKT))
              then (\ENQUEUE (fetch EPREQUEUE of EPKT)
                          EPKT))
          (if OK
              then (\ENQUEUE \TCP.LOOPBACK.QUEUE SEGMENT)
                   (NOTIFY.EVENT \TCP.LOOPBACK.EVENT])

(\TCP.CHECK.INPUT.QUEUE
  [LAMBDA (TCB)                                              (* edited%: "22-May-84 15:32")
                                                             (* perform consistency check on the 
                                                             input queue)
    (PROG ((QUEUE (fetch TCB.INPUT.QUEUE of TCB))
           CURSEG SEQ1 TOP1 NEXTSEG SEQ2 TOP2)
          (SETQ CURSEG (fetch SYSQUEUEHEAD of QUEUE))
      LOOP
          (if (NULL CURSEG)
              then (RETURN T))
          (SETQ SEQ1 (fetch TCP.SEQ of CURSEG))
          (SETQ TOP1 (IPLUS SEQ1 (fetch TCP.DATA.LENGTH of CURSEG)))
          (if (AND (\32BIT.LEQ SEQ1 (fetch TCB.RCV.NXT of TCB))
                   (\32BIT.GT TOP1 (fetch TCB.RCV.NXT of TCB)))
              then (SHOULDNT "incorrect RCV.NXT")
                   (RETURN NIL))
          (SETQ NEXTSEG (fetch QLINK of CURSEG))
          (if (NULL NEXTSEG)
              then (RETURN T))
          (SETQ SEQ2 (fetch TCP.SEQ of NEXTSEG))
          (SETQ TOP2 (IPLUS SEQ2 (fetch TCP.DATA.LENGTH of NEXTSEG)))
          (if (\32BIT.LT SEQ2 SEQ1)
              then (SHOULDNT "input queue out of order")
                   (RETURN NIL))
          (SETQ CURSEG NEXTSEG)
          (GO LOOP])

(TCP.FAUCET
  [LAMBDA (HOST PORT NLINES)                                 (* ejs%: "20-Jun-85 12:20")
    (PROG [(STREAM (if HOST
                       then (TCP.OPEN HOST (OR PORT \TCP.SINK.PORT)
                                   NIL
                                   'ACTIVE
                                   'OUTPUT)
                     else (TCP.OPEN NIL NIL (OR PORT \TCP.SINK.PORT)
                                 'PASSIVE
                                 'OUTPUT]
          (RESETLST (RESETSAVE NIL (LIST (FUNCTION CLOSEF)
                                         STREAM))
                 (GENERATE.RANDOM.CHARS STREAM NLINES])

(TCP.ECHOTEST
  [LAMBDA (HOST NLINES)                                      (* ecc "14-May-84 17:07")
    (PROG [(STREAM (TCP.OPEN HOST \TCP.ECHO.PORT NIL 'ACTIVE 'OUTPUT]
          (ADD.PROCESS (BQUOTE (TCP.COPYTOWINDOW %, (TCP.OTHER.STREAM STREAM))
                              'NAME "TCP Echo Tester"))
          (GENERATE.RANDOM.CHARS STREAM NLINES)
          (TCP.CLOSE.SENDER STREAM])

(TCP.QUIET.ECHOTEST
  [LAMBDA (HOST NLINES)                                      (* ecc "25-May-84 13:24")
    (PROG [(STREAM (TCP.OPEN HOST \TCP.ECHO.PORT NIL 'ACTIVE 'OUTPUT]
          (ADD.PROCESS (BQUOTE (\TCP.SINK.PROCESS %, (TCP.OTHER.STREAM STREAM))
                              'NAME "TCP Echo Tester"))
          (GENERATE.RANDOM.CHARS STREAM NLINES)
          (TCP.CLOSE.SENDER STREAM])

(TCP.SINKTEST
  [LAMBDA (PORT VISIBLEFLG)                                  (* ecc "14-May-84 17:28")
    (TCP.COPYTOWINDOW (TCP.OPEN NIL NIL (OR PORT \TCP.SINK.PORT)
                             'PASSIVE
                             'INPUT)
           VISIBLEFLG])

(GENERATE.RANDOM.CHARS
  [LAMBDA (STREAM NLINES)                                    (* ejs%: " 7-Jun-85 12:34")
    (bind (N _ 0) while (NEQ N NLINES) do (add N 1)
                                          (printout STREAM "This is byte number " (GETFILEPTR STREAM)
                                                 "." T)
                                          (BLOCK])

(COPYBYTESTREAM
  [LAMBDA (INSTR OUTSTR VISIBLEFLG)                          (* ejs%: " 7-Jun-85 13:44")
    (if VISIBLEFLG
        then (bind (N _ 1)
                   (C _ NIL) while (OPENP INSTR 'INPUT)
                do (SETQ C (BIN INSTR))
                   (printout OUTSTR N ": " C)
                   (if (AND (ILEQ C 127)
                            (IGEQ C 32))
                       then (printout OUTSTR " (" %# (BOUT OUTSTR C)
                                   ")"))
                   (TERPRI OUTSTR)
                   (add N 1))
      else (bind C while (AND (OPENP INSTR 'INPUT)
                              (NOT (EOFP INSTR))) do (COND
                                                        ((SETQ C (BIN INSTR))
                                                         (BOUT OUTSTR C])

(TCP.COPYTOWINDOW
  [LAMBDA (STREAM VISIBLEFLG)                                (* ejs%: "13-Apr-85 16:01")
    (RESETLST (RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
                                   STREAM))
           (PROG ((WIN (CREATEW NIL "Stream Output")))
                 (DSPSCROLL T WIN)
                 (COPYBYTESTREAM STREAM WIN VISIBLEFLG)
                 (printout WIN .TAB0 0 "[End of stream]"])

(TEST.CHECKSUM
  [LAMBDA (STR STR2)                                         (* ecc "24-Apr-84 13:11")
    (if (NULL STR2)
        then (\COMPUTE.CHECKSUM (\ADDBASE (fetch (STRINGP BASE) of STR)
                                       (fetch (STRINGP OFFST) of STR))
                    (fetch (STRINGP LENGTH) of STR))
      else (\16BIT.COMPLEMENT (\16BIT.1C.PLUS (\COMPUTE.CHECKSUM (\ADDBASE (fetch (STRINGP BASE)
                                                                              of STR)
                                                                        (fetch (STRINGP OFFST)
                                                                           of STR))
                                                     (fetch (STRINGP LENGTH) of STR)
                                                     T)
                                     (\COMPUTE.CHECKSUM (\ADDBASE (fetch (STRINGP BASE) of STR2)
                                                               (fetch (STRINGP OFFST) of STR2))
                                            (fetch (STRINGP LENGTH) of STR2)
                                            T])
)
(PUTPROPS TCPDEBUG COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2530 5441 (TCP.SINK.SERVER 2540 . 2955) (TCP.TELNET.SERVER 2957 . 3546) (
\TCP.SINK.PROCESS 3548 . 3874) (TCP.ECHO.SERVER 3876 . 4356) (\TCP.ECHO.PROCESS 4358 . 5439)) (8951 
18060 (TCP.PRINT.SEGMENT 8961 . 11702) (\TCP.PRINT.OPTIONS 11704 . 13026) (\TCP.PRINT.ELAPSED.TIME 
13028 . 13561) (\TCP.PRINT.SEGMENT.QUEUE 13563 . 13945) (TCPTRACE 13947 . 16678) (\TCPTRACEMENU.ITEMFN
 16680 . 17190) (\TCPTRACEMENU.DISPLAYFN 17192 . 17578) (TCP.DRIBBLE 17580 . 18058)) (18333 27228 (
TCP.DEBUG 18343 . 19261) (TCP.WATCHER 19263 . 19916) (DUMMY\IP\Transmit\Packet 19918 . 21136) (
\TCP.CHECK.INPUT.QUEUE 21138 . 22505) (TCP.FAUCET 22507 . 23175) (TCP.ECHOTEST 23177 . 23587) (
TCP.QUIET.ECHOTEST 23589 . 24006) (TCP.SINKTEST 24008 . 24288) (GENERATE.RANDOM.CHARS 24290 . 24690) (
COPYBYTESTREAM 24692 . 25563) (TCP.COPYTOWINDOW 25565 . 25990) (TEST.CHECKSUM 25992 . 27226)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPDOMAIN b/obsolete/tcp/TCPDOMAIN
deleted file mode 100644
index 1e9b8354..00000000
--- a/obsolete/tcp/TCPDOMAIN
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jun-90 16:18:18" {DSK}<usr>local>lde>lispcore>library>TCPDOMAIN.;3 66928  

      changes to%:  (VARS TCPDOMAINCOMS)

      previous date%: "28-Feb-89 18:35:51" {DSK}<usr>local>lde>lispcore>library>TCPDOMAIN.;2)


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

(PRETTYCOMPRINT TCPDOMAINCOMS)

(RPAQQ TCPDOMAINCOMS
       ((COMS 
              (* ;; "TCP/IP Domain resolver implementation.  RFC882, RFC883, RFC973")
)
        (COMS 
              (* ;; "UDP protocol functions")

              (DECLARE%: DONTCOPY (EXPORT (CONSTANTS (\UDPDOMAIN.WDS 6))
                                         (RECORDS DOMAIN.HEADER)))
              (INITVARS (\UDPDOMAIN.IPSOCKET))
              (GLOBALVARS \UDPDOMAIN.IPSOCKET)
              (FILES (SYSLOAD)
                     TCPUDP)
              (FNS \UDPDOM.PROCESS.RESPONSE \UDPDOM.QUERY \UDPDOM.IPSOCKET))
        (COMS 
              (* ;; "Protocol independent functions")

              [DECLARE%: DONTCOPY (EXPORT (CONSTANTS * DOMAIN.OPCODES)
                                         (CONSTANTS * DOMAIN.RCODES)
                                         (CONSTANTS * DOMAIN.RRTYPES)
                                         (CONSTANTS * DOMAIN.CLASSTYPES)
                                         (CONSTANTS (\DOMAIN.PORT 53]
              (INITVARS (\DOMAIN.DEFAULT.SERVER))
              (GLOBALVARS \DOMAIN.DEFAULT.SERVER)
              (FNS \DOMAIN.NAME \DOMAIN.PACK.NAME.LIST \DOMAIN.PARSE.NAME \DOMAIN.RCODE.ERROR 
                   \DOMAIN.PROCESS.REDIRECT \DOMAIN.PROCESS.RESPONSE \DOMAIN.PROCESS.RR 
                   \DOMAIN.READ.ADDRESS \DOMAIN.READ.NAME.FROM.STREAM \DOMAIN.READ.STRING.FROM.STREAM
                   \DOMAIN.SEARCH.FOR.CANONICAL.NAME \DOMAIN.SKIP.NAME.IN.STREAM 
                   \DOMAIN.SKIP.QUESTION \DOMAIN.SKIP.RR))
        (COMS 
              (* ;; "Functions to maintain the domain tree structure")

              (RECORDS DOMAIN.TREE.NODE DOMAIN.SERVER)
              (INITRECORDS DOMAIN.TREE.NODE)
              (FNS USTRINGHASHBITS)
              (INITVARS (\DOMAIN.ROOT (create DOMAIN.TREE.NODE NAME _ ""))
                     (\DOMAIN.NAMESERVERS (HASHARRAY 50 1.2 (FUNCTION USTRINGHASHBITS)
                                                 (FUNCTION STRING-EQUAL)))
                     (\DOMAIN.UNKNOWN.DOMAINS)
                     (\DOMAIN.GC.INTERVAL 600000)
                     (\DOMAIN.GC.TIMER (SETUPTIMER \DOMAIN.GC.INTERVAL)))
              (GLOBALVARS \DOMAIN.ROOT \DOMAIN.NAMESERVERS \DOMAIN.UNKNOWN.DOMAINS \DOMAIN.GC.TIMER 
                     \DOMAIN.GC.INTERVAL)
              (FNS \DOMAIN.ADD.NEW.DOMAIN \DOMAIN.ADD.NAMESERVER \DOMAIN.AUGMENT.TREE 
                   \DOMAIN.CHOOSE.BEST.SERVERS \DOMAIN.FIND.DOMAIN.IN.TREE \DOMAIN.INIT 
                   \DOMAIN.INSERT.IN.TREE \DOMAIN.PATH \DOMAIN.SEARCH.RESOURCE.LIST 
                   \DOMAIN.DELETE.NAMESERVER \DOMAIN.AROUND.EXIT \DOMAIN.DELETE.TREE 
                   \DOMAIN.BACKGROUND \DOMAIN.GC.NAMESERVERS \DOMAIN.SORT.BY.SVC.TIME)
              (ADDVARS (BACKGROUNDFNS \DOMAIN.BACKGROUND)))
        (COMS 
              (* ;; "Programmer's interface")

              (INITVARS (DOMAIN.TRACE.FLG)
                     (DOMAIN.TRACE.FILE)
                     (INTERNET.LOCAL.DOMAIN))
              (GLOBALVARS DOMAIN.TRACE.FLG DOMAIN.TRACE.FILE INTERNET.LOCAL.DOMAIN)
              (FNS DOMAIN.INIT DOMAIN.LOOKUP.ADDRESS DOMAIN.LOOKUP.NAMESERVER DOMAIN.LOOKUP.OSTYPE 
                   DOMAIN.LOOKUP DOMAIN.GRAPH DOMAIN.NAME.EQUAL DOMAIN.TRACE 
                   DOMAIN.TRACEWINDOW.BUTTONFN))
        (P (DOMAIN.INIT))))



(* ;; "TCP/IP Domain resolver implementation.  RFC882, RFC883, RFC973")




(* ;; "UDP protocol functions")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \UDPDOMAIN.WDS 6)


(CONSTANTS (\UDPDOMAIN.WDS 6))
)
(DECLARE%: EVAL@COMPILE

(BLOCKRECORD DOMAIN.HEADER ((ID WORD)
                                (RESPONSEFLG FLAG)
                                (OPCODE BITS 4)
                                (AUTHORITYFLG FLAG)
                                (TRUNCATEDFLG FLAG)
                                (WANTRECURSEFLG FLAG)
                                (CANRECURSEFLG FLAG)
                                (NIL BITS 3)
                                (RESPONSECODE BITS 4)
                                (QDCOUNT WORD)
                                (ANCOUNT WORD)
                                (NSCOUNT WORD)
                                (ARCOUNT WORD)))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? \UDPDOMAIN.IPSOCKET )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \UDPDOMAIN.IPSOCKET)
)

(FILESLOAD (SYSLOAD)
       TCPUDP)
(DEFINEQ

(\UDPDOM.PROCESS.RESPONSE
  [LAMBDA (DOMAIN.PATH RESPONSE)                         (* ejs%: " 5-Nov-86 13:38")
          
          (* * This function parses a query reponse packet)

    (LET ((RESPONSEBASE (fetch (UDP UDPCONTENTS) of RESPONSE)))
         (COND
            ((NEQ 0 (fetch (DOMAIN.HEADER ANCOUNT) of RESPONSEBASE))
          
          (* * The response packet has the information we requested)

             (PROG1 (\DOMAIN.PROCESS.RESPONSE (\MAKEBASEBYTESTREAM RESPONSEBASE 0
                                                         (IDIFFERENCE (fetch (UDP UDPLENGTH)
                                                                         of RESPONSE)
                                                                \UDPOVLEN)
                                                         'INPUT))
                    (\RELEASE.ETHERPACKET RESPONSE)))
            ((OR (NEQ 0 (fetch (DOMAIN.HEADER NSCOUNT) of RESPONSEBASE))
                 (NEQ 0 (fetch (DOMAIN.HEADER ARCOUNT) of RESPONSEBASE)))
          
          (* * The server we asked didn't know, but did tell us the name of a server 
        which might know)

             (PROG1 (\DOMAIN.PROCESS.REDIRECT (\MAKEBASEBYTESTREAM RESPONSEBASE 0
                                                         (IDIFFERENCE (fetch (UDP UDPLENGTH)
                                                                         of RESPONSE)
                                                                \UDPOVLEN)
                                                         'INPUT))
                    (\RELEASE.ETHERPACKET RESPONSE)))
            (T (\RELEASE.ETHERPACKET RESPONSE)
               'FAILED])

(\UDPDOM.QUERY
  [LAMBDA (DOMAIN TYPE CLASS SERVER)                     (* ejs%: " 5-Nov-86 13:40")
          
          (* * Make a domain query. Argument semantics should be self-evident if you've 
        read RFC882 and RFC883. Returns a list of answers, or atoms to indicate 
        failure--USE.TCP, etc)

    (LET* ((QUERY (\ALLOCATE.ETHERPACKET))
           (ID (RAND 1 65534))
           ANSWER DOMAINBASE)
          
          (* * Do basic QUERY initialization)

          (UDP.SETUP QUERY (OR SERVER \DOMAIN.DEFAULT.SERVER)
                 \DOMAIN.PORT ID (\UDPDOM.IPSOCKET))
          (SETQ DOMAINBASE (fetch (UDP UDPCONTENTS) of QUERY))
          
          (* * Format header section)

          (replace (DOMAIN.HEADER ID) of DOMAINBASE with ID)
          (replace (DOMAIN.HEADER RESPONSEFLG) of DOMAINBASE with NIL)
          (replace (DOMAIN.HEADER AUTHORITYFLG) of DOMAINBASE with NIL)
          (replace (DOMAIN.HEADER TRUNCATEDFLG) of DOMAINBASE with NIL)
          (replace (DOMAIN.HEADER WANTRECURSEFLG) of DOMAINBASE with NIL)
          (replace (DOMAIN.HEADER CANRECURSEFLG) of DOMAINBASE with NIL)
          (replace (DOMAIN.HEADER OPCODE) of DOMAINBASE with DOMAIN.QUERY)
          (replace (DOMAIN.HEADER RESPONSECODE) of DOMAINBASE with 0)
          (replace (DOMAIN.HEADER QDCOUNT) of DOMAINBASE with 1)
          (replace (DOMAIN.HEADER ANCOUNT) of DOMAINBASE with 0)
          (replace (DOMAIN.HEADER NSCOUNT) of DOMAINBASE with 0)
          (replace (DOMAIN.HEADER ARCOUNT) of DOMAINBASE with 0)
          (UDP.INCREMENT.LENGTH QUERY (UNFOLD \UDPDOMAIN.WDS BYTESPERWORD))
          
          (* * Add Query)

          [COND
             ((AND (NOT (NULL DOMAIN))
                   (NLISTP DOMAIN))
              (SETQ DOMAIN (\DOMAIN.PARSE.NAME DOMAIN]
          (for NAME in DOMAIN do (UDP.APPEND.BYTE QUERY (NCHARS NAME))
                                            (UDP.APPEND.STRING QUERY (MKSTRING NAME))
             finally (UDP.APPEND.BYTE QUERY 0))
          (UDP.APPEND.WORD QUERY TYPE)
          (UDP.APPEND.WORD QUERY CLASS)
          
          (* * Do the query)

          (bind RESPONSE RESPONSEBASE for I from 1 to \MAXETHERTRIES
             do (COND
                       [(SETQ RESPONSE (UDP.EXCHANGE (\UDPDOM.IPSOCKET)
                                              QUERY 10000))
                        (SETQ RESPONSEBASE (fetch (UDP UDPCONTENTS) of RESPONSE))
                        (COND
                           [(AND (EQ (fetch (DOMAIN.HEADER ID) of RESPONSEBASE)
                                     ID)
                                 (fetch (DOMAIN.HEADER RESPONSEFLG) of RESPONSEBASE))
                            (COND
                               ((AND (fetch (DOMAIN.HEADER TRUNCATEDFLG) of RESPONSEBASE)
                                     (EQ (fetch (DOMAIN.HEADER ANCOUNT) of RESPONSEBASE)
                                         0)
                                     (EQ (fetch (DOMAIN.HEADER NSCOUNT) of RESPONSEBASE)
                                         0)
                                     (EQ (fetch (DOMAIN.HEADER RESPONSECODE) of RESPONSEBASE)
                                         RCODE.OK))
                                (SETQ ANSWER 'USE.TCP)
                                (\RELEASE.ETHERPACKET RESPONSE)
                                (GO $$OUT))
                               ((NEQ (fetch (DOMAIN.HEADER RESPONSECODE) of RESPONSEBASE)
                                     RCODE.OK)
                                (SETQ ANSWER (\DOMAIN.RCODE.ERROR (fetch (DOMAIN.HEADER
                                                                                  RESPONSECODE)
                                                                         of RESPONSEBASE)))
                                (COND
                                   (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                                          (printout DOMAIN.TRACE.FILE "Error on query: " ANSWER)))
                                (\RELEASE.ETHERPACKET RESPONSE)
                                (GO $$OUT))
                               (T (SETQ ANSWER (\UDPDOM.PROCESS.RESPONSE DOMAIN RESPONSE))
                                  (GO $$OUT]
                           (T (\RELEASE.ETHERPACKET RESPONSE]
                       (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                              (printout DOMAIN.TRACE.FILE "Query to " (\IP.ADDRESS.TO.STRING
                                                                       (fetch (IP 
                                                                                 IPDESTINATIONADDRESS
                                                                                      ) of QUERY)
                                                                       )
                                     " timed out."))) finally (\RELEASE.ETHERPACKET QUERY)
                                                            (RETURN ANSWER])

(\UDPDOM.IPSOCKET
  [LAMBDA NIL                                            (* ejs%: "12-Apr-86 20:39")
    [COND
       ((NULL \UDPDOMAIN.IPSOCKET)
        (SETQ \UDPDOMAIN.IPSOCKET (UDP.OPEN.SOCKET)))
       ((NOT (\IP.FIND.SOCKET (fetch (IPSOCKET IPSOCKET) of \UDPDOMAIN.IPSOCKET)
                    (\IP.FIND.PROTOCOL \UDP.PROTOCOL)))
        (SETQ \UDPDOMAIN.IPSOCKET (UDP.OPEN.SOCKET NIL 'ACCEPT]
    \UDPDOMAIN.IPSOCKET])
)



(* ;; "Protocol independent functions")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")


(RPAQQ DOMAIN.OPCODES ((DOMAIN.QUERY 0)
                           (DOMAIN.IQUERY 1)
                           (DOMAIN.CQUERYM 2)
                           (DOMAIN.CQUERYU 3)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ DOMAIN.QUERY 0)

(RPAQQ DOMAIN.IQUERY 1)

(RPAQQ DOMAIN.CQUERYM 2)

(RPAQQ DOMAIN.CQUERYU 3)


(CONSTANTS (DOMAIN.QUERY 0)
       (DOMAIN.IQUERY 1)
       (DOMAIN.CQUERYM 2)
       (DOMAIN.CQUERYU 3))
)

(RPAQQ DOMAIN.RCODES ((RCODE.OK 0)
                          (RCODE.FORMATERROR 1)
                          (RCODE.SERVERFAILED 2)
                          (RCODE.NAMEERROR 3)
                          (RCODE.NOTIMPLEMENTED 4)
                          (RCODE.REFUSED 5)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ RCODE.OK 0)

(RPAQQ RCODE.FORMATERROR 1)

(RPAQQ RCODE.SERVERFAILED 2)

(RPAQQ RCODE.NAMEERROR 3)

(RPAQQ RCODE.NOTIMPLEMENTED 4)

(RPAQQ RCODE.REFUSED 5)


(CONSTANTS (RCODE.OK 0)
       (RCODE.FORMATERROR 1)
       (RCODE.SERVERFAILED 2)
       (RCODE.NAMEERROR 3)
       (RCODE.NOTIMPLEMENTED 4)
       (RCODE.REFUSED 5))
)

(RPAQQ DOMAIN.RRTYPES
       ((RRTYPE.A 1)
        (RRTYPE.NS 2)
        (RRTYPE.MD 3)
        (RRTYPE.MF 4)
        (RRTYPE.CNAME 5)
        (RRTYPE.SOA 6)
        (RRTYPE.MB 7)
        (RRTYPE.MG 8)
        (RRTYPE.MR 9)
        (RRTYPE.NULL 10)
        (RRTYPE.WKS 11)
        (RRTYPE.PTR 12)
        (RRTYPE.HINFO 13)
        (RRTYPE.MINFO 14)
        (RRTYPE.MX 15)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ RRTYPE.A 1)

(RPAQQ RRTYPE.NS 2)

(RPAQQ RRTYPE.MD 3)

(RPAQQ RRTYPE.MF 4)

(RPAQQ RRTYPE.CNAME 5)

(RPAQQ RRTYPE.SOA 6)

(RPAQQ RRTYPE.MB 7)

(RPAQQ RRTYPE.MG 8)

(RPAQQ RRTYPE.MR 9)

(RPAQQ RRTYPE.NULL 10)

(RPAQQ RRTYPE.WKS 11)

(RPAQQ RRTYPE.PTR 12)

(RPAQQ RRTYPE.HINFO 13)

(RPAQQ RRTYPE.MINFO 14)

(RPAQQ RRTYPE.MX 15)


(CONSTANTS (RRTYPE.A 1)
       (RRTYPE.NS 2)
       (RRTYPE.MD 3)
       (RRTYPE.MF 4)
       (RRTYPE.CNAME 5)
       (RRTYPE.SOA 6)
       (RRTYPE.MB 7)
       (RRTYPE.MG 8)
       (RRTYPE.MR 9)
       (RRTYPE.NULL 10)
       (RRTYPE.WKS 11)
       (RRTYPE.PTR 12)
       (RRTYPE.HINFO 13)
       (RRTYPE.MINFO 14)
       (RRTYPE.MX 15))
)

(RPAQQ DOMAIN.CLASSTYPES ((CLASSTYPE.IN 1)
                              (CLASSTYPE.CSNET 2)
                              (CLASSTYPE.CHAOS 3)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ CLASSTYPE.IN 1)

(RPAQQ CLASSTYPE.CSNET 2)

(RPAQQ CLASSTYPE.CHAOS 3)


(CONSTANTS (CLASSTYPE.IN 1)
       (CLASSTYPE.CSNET 2)
       (CLASSTYPE.CHAOS 3))
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \DOMAIN.PORT 53)


(CONSTANTS (\DOMAIN.PORT 53))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? \DOMAIN.DEFAULT.SERVER )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \DOMAIN.DEFAULT.SERVER)
)
(DEFINEQ

(\DOMAIN.NAME
  [LAMBDA (DOMAIN.TREE.NODE)                             (* ejs%: "13-Apr-86 15:38")
          
          (* * Generate a list of domain names along the path to the root of the domain 
        tree)

    (COND
       ((NULL (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of DOMAIN.TREE.NODE))
        NIL)
       (T (LET [(SUFFIX (\DOMAIN.NAME (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of 
                                                                                     DOMAIN.TREE.NODE
                                                 ]
               (COND
                  (SUFFIX (CONCAT (fetch (DOMAIN.TREE.NODE NAME) of DOMAIN.TREE.NODE)
                                 "." SUFFIX))
                  (T (fetch (DOMAIN.TREE.NODE NAME) of DOMAIN.TREE.NODE])

(\DOMAIN.PACK.NAME.LIST
  [LAMBDA (LIST)                                         (* ejs%: "12-Apr-86 20:29")
    (COND
       ((LISTP LIST)
        (LET [(DOMAIN.NAME (ALLOCSTRING (IPLUS (SUB1 (LENGTH LIST))
                                               (for NAME in LIST sum (NCHARS NAME]
             [bind (I _ 1) for NAME in LIST do (RPLSTRING DOMAIN.NAME I NAME)
                                                              (add I (NCHARS NAME))
                                                              (COND
                                                                 ((ILESSP I (NCHARS DOMAIN.NAME))
                                                                  (RPLCHARCODE DOMAIN.NAME I
                                                                         (CHARCODE %.))
                                                                  (add I 1]
             DOMAIN.NAME))
       (T (ALLOCSTRING 0])

(\DOMAIN.PARSE.NAME
  [LAMBDA (NAME)                                         (* ejs%: "12-Apr-86 18:11")
          
          (* * This function parses a domain name
        (e.g. SUMEX.STANFORD.EDU)%, and returns a list of domain labels
        (SUMEX STANFORD EDU))

    (bind (SCRATCHSTRING _ (CONSTANT (ALLOCSTRING 63)))
           NAMELIST
           (LENGTH _ 0) for CHAR instring (MKSTRING NAME)
       do (COND
                 [(EQ CHAR (CHARCODE %.))
                  (COND
                     ((NEQ 0 LENGTH)
                      [SETQ NAMELIST (NCONC1 NAMELIST (CONCAT (SUBSTRING SCRATCHSTRING 1 LENGTH]
                      (SETQ LENGTH 0]
                 ((IGREATERP LENGTH 63)
                  (ERROR "Domain name too long" SCRATCHSTRING))
                 (T (RPLCHARCODE SCRATCHSTRING (add LENGTH 1)
                           CHAR))) finally (RETURN (COND
                                                          [(NEQ LENGTH 0)
                                                           (NCONC1 NAMELIST
                                                                  (CONCAT (SUBSTRING SCRATCHSTRING 1 
                                                                                 LENGTH]
                                                          (T NAMELIST])

(\DOMAIN.RCODE.ERROR
  [LAMBDA (CODE)                                         (* ejs%: "12-Apr-86 19:15")
    (SELECTC CODE
        (RCODE.OK 'OK)
        (RCODE.FORMATERROR 
             'FORMAT.ERROR)
        (RCODE.SERVERFAILED 
             'SERVER.FAILED)
        (RCODE.NAMEERROR 
             'NAME.ERROR)
        (RCODE.NOTIMPLEMENTED 
             'NOT.IMPLEMENTED)
        (RCODE.REFUSED 'REFUSED)
        NIL])

(\DOMAIN.PROCESS.REDIRECT
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 21:04")
          
          (* * Skip past the header and query section to get to the answer section)
          
          (* * Past ID and flags in header)

    (\WIN STREAM)
    (\WIN STREAM)
    (LET ((%#QUESTIONS (\WIN STREAM))
          (%#ANSWERS (\WIN STREAM))
          (%#NSERVERS (\WIN STREAM))
          (%#ADDITIONAL (\WIN STREAM)))
          
          (* * Past questions)

         (for I from 1 to %#QUESTIONS do (\DOMAIN.SKIP.QUESTION STREAM))
          
          (* * Collect answers)

         (for I from 1 to %#ANSWERS collect (\DOMAIN.SKIP.RR STREAM))
          
          (* * Collect rest)

         (APPEND (for I from 1 to %#NSERVERS collect (\DOMAIN.PROCESS.RR STREAM))
                (for I from 1 to %#ADDITIONAL collect (\DOMAIN.PROCESS.RR STREAM])

(\DOMAIN.PROCESS.RESPONSE
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 19:58")
          
          (* * Skip past the header and query section to get to the answer section)
          
          (* * Past ID and flags in header)

    (\WIN STREAM)
    (\WIN STREAM)
    (LET ((%#QUESTIONS (\WIN STREAM))
          (%#ANSWERS (\WIN STREAM)))
          
          (* * Past rest of header)

         (\WIN STREAM)
         (\WIN STREAM)
          
          (* * Past questions)

         (for I from 1 to %#QUESTIONS do (\DOMAIN.SKIP.QUESTION STREAM))
          
          (* * Collect answers)

         (for I from 1 to %#ANSWERS collect (\DOMAIN.PROCESS.RR STREAM])

(\DOMAIN.PROCESS.RR
  [LAMBDA (STREAM)                                       (* ejs%: "13-Apr-86 17:09")
          
          (* * Process a resource record beginning at the current point in the stream)

    (LET ((NAME (\DOMAIN.READ.NAME.FROM.STREAM STREAM))
          (TYPE (\WIN STREAM))
          (CLASS (\WIN STREAM))
          (TTL (\MAKENUMBER (\WIN STREAM)
                      (\WIN STREAM)))
          (RDLEN (\WIN STREAM))
          ANSWER)
         [SETQ ANSWER `(NAME %, NAME TYPE %, TYPE CLASS %, CLASS TTL %, TTL DATA %,
                             (SELECTC TYPE
                                 (RRTYPE.A (\DOMAIN.READ.ADDRESS STREAM CLASS (FOLDLO RDLEN 
                                                                                         BYTESPERCELL
                                                                                         )))
                                 ((LIST RRTYPE.CNAME RRTYPE.NS) 
                                      (\DOMAIN.READ.NAME.FROM.STREAM STREAM))
                                 (RRTYPE.HINFO (CONS (\DOMAIN.READ.STRING.FROM.STREAM STREAM)
                                                     (\DOMAIN.READ.STRING.FROM.STREAM STREAM)))
                                 (PROGN (for I from 1 to RDLEN do (BIN STREAM))
                                        NIL]
         [COND
            (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE (printout DOMAIN.TRACE.FILE 
                                                                  "Answer received: " ANSWER]
         ANSWER])

(\DOMAIN.READ.ADDRESS
  [LAMBDA (STREAM CLASS %#ADDRESSES)                     (* ejs%: "12-Apr-86 20:56")
    (SELECTC CLASS
        (CLASSTYPE.IN [COND
                         ((EQ %#ADDRESSES 0)
                          NIL)
                         [(NEQ %#ADDRESSES 1)
                          (for I from 1 to %#ADDRESSES collect (\MAKENUMBER
                                                                                (\WIN STREAM)
                                                                                (\WIN STREAM]
                         (T (\MAKENUMBER (\WIN STREAM)
                                   (\WIN STREAM])
        NIL])

(\DOMAIN.READ.NAME.FROM.STREAM
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 20:54")
    (bind NAMELEN NAMELST until (EQ 0 (SETQ NAMELEN (BIN STREAM)))
       do [COND
                 [(EQ 3 (LRSH NAMELEN 6))
          
          (* * Process a pointer redirection)

                  (LET ((CONTINUATIONADDR (create WORD
                                                 HIBYTE _ (LOGAND NAMELEN (MASK.1'S 0 6))
                                                 LOBYTE _ (BIN STREAM)))
                        (STREAMPTR (GETFILEPTR STREAM)))
                       (SETFILEPTR STREAM CONTINUATIONADDR)
                       (RETURN (PROG1 (COND
                                         (NAMELST (CONCAT (\DOMAIN.PACK.NAME.LIST (DREVERSE
                                                                                       NAMELST))
                                                         "."
                                                         (\DOMAIN.READ.NAME.FROM.STREAM STREAM)))
                                         (T (\DOMAIN.READ.NAME.FROM.STREAM STREAM)))
                                      (SETFILEPTR STREAM STREAMPTR]
                 (T 
          
          (* * Normal name segment)

                    (LET ((NAME (ALLOCSTRING NAMELEN)))
                         (\BINS STREAM (fetch (STRINGP BASE) of NAME)
                                (fetch (STRINGP OFFST) of NAME)
                                NAMELEN)
                         (push NAMELST NAME] finally (RETURN (\DOMAIN.PACK.NAME.LIST
                                                                      (DREVERSE NAMELST])

(\DOMAIN.READ.STRING.FROM.STREAM
  [LAMBDA (STREAM)                                       (* ejs%: "13-Apr-86 02:33")
    (LET* ((NAMELEN (BIN STREAM))
           (STRING (ALLOCSTRING NAMELEN)))
          (for I from 1 to NAMELEN do (RPLCHARCODE STRING I (BIN STREAM)))
          STRING])

(\DOMAIN.SEARCH.FOR.CANONICAL.NAME
  [LAMBDA (NAME RRLST)                                   (* ejs%: "14-Nov-86 14:44")
    (bind FOUNDIT DATA for RR in RRLST thereis (AND (EQ RRTYPE.CNAME
                                                                        (LISTGET RR 'TYPE))
                                                                    (DOMAIN.NAME.EQUAL
                                                                     (LISTGET RR 'NAME)
                                                                     NAME)
                                                                    (SETQ FOUNDIT T))
       finally (RETURN (AND FOUNDIT (LISTGET RR 'DATA])

(\DOMAIN.SKIP.NAME.IN.STREAM
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 21:06")
    (bind NAMELEN NAMELST until (EQ 0 (SETQ NAMELEN (BIN STREAM)))
       do (COND
                 ((EQ 3 (LRSH NAMELEN 6))
          
          (* * Process a pointer redirection)

                  (BIN STREAM))
                 (T 
          
          (* * Normal name segment)

                    (for I from 1 to NAMELEN do (BIN STREAM])

(\DOMAIN.SKIP.QUESTION
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 21:06")
          
          (* * Skip over a question section--composed of compressed name, QTYPE, and 
        QCLASS fields)

    (\DOMAIN.SKIP.NAME.IN.STREAM STREAM)
    (\WIN STREAM)
    (\WIN STREAM])

(\DOMAIN.SKIP.RR
  [LAMBDA (STREAM)                                       (* ejs%: "12-Apr-86 21:10")
          
          (* * Skip a resource record beginning at the current point in the stream)
          
          (* * Name)

    (\DOMAIN.SKIP.NAME.IN.STREAM STREAM)
          
          (* * Type)

    (\WIN STREAM)
          
          (* * Class)

    (\WIN STREAM)
          
          (* * Time to Live)

    (\WIN STREAM)
    (\WIN STREAM)
          
          (* * RDATA Length)

    (for I from 0 to (\WIN STREAM) do (BIN STREAM])
)



(* ;; "Functions to maintain the domain tree structure")

(DECLARE%: EVAL@COMPILE

(DATATYPE DOMAIN.TREE.NODE ((NAME POINTER)               (* The name of this domain)
                                (SUBDOMAINS POINTER)         (* List of domains inferior to this 
                                                           one)
                                (SUPERDOMAIN POINTER)        (* The domain of which this domain 
                                                           is a part)
                                (NAMESERVERS POINTER)        (* The list of designated name 
                                                           servers for this domain)
                                ))

(RECORD DOMAIN.SERVER (NAME ADDRESSES EXPIRATION.DATE FOR.DOMAINS AVG.SVC.TIME)
                          AVG.SVC.TIME _ 0)
)

(/DECLAREDATATYPE 'DOMAIN.TREE.NODE '(POINTER POINTER POINTER POINTER)
       '((DOMAIN.TREE.NODE 0 POINTER)
         (DOMAIN.TREE.NODE 2 POINTER)
         (DOMAIN.TREE.NODE 4 POINTER)
         (DOMAIN.TREE.NODE 6 POINTER))
       '8)

(/DECLAREDATATYPE 'DOMAIN.TREE.NODE '(POINTER POINTER POINTER POINTER)
       '((DOMAIN.TREE.NODE 0 POINTER)
         (DOMAIN.TREE.NODE 2 POINTER)
         (DOMAIN.TREE.NODE 4 POINTER)
         (DOMAIN.TREE.NODE 6 POINTER))
       '8)
(DEFINEQ

(USTRINGHASHBITS
  [LAMBDA (STRING)                                       (* ejs%: " 5-Nov-86 13:20")
    (for C inthinstring (MKSTRING STRING) bind (HASHBITS _ 0)
       do [SETQ HASHBITS (IPLUS16 (ELT UPPERCASEARRAY C)
                                    (IPLUS16 (SETQ HASHBITS (IPLUS16 HASHBITS (LLSH (LOGAND HASHBITS 
                                                                                           4095)
                                                                                    2)))
                                           (LLSH (LOGAND HASHBITS 255)
                                                 8] finally (RETURN HASHBITS])
)

(RPAQ? \DOMAIN.ROOT (create DOMAIN.TREE.NODE NAME _ ""))

(RPAQ? \DOMAIN.NAMESERVERS (HASHARRAY 50 1.2 (FUNCTION USTRINGHASHBITS)
                                      (FUNCTION STRING-EQUAL)))

(RPAQ? \DOMAIN.UNKNOWN.DOMAINS )

(RPAQ? \DOMAIN.GC.INTERVAL 600000)

(RPAQ? \DOMAIN.GC.TIMER (SETUPTIMER \DOMAIN.GC.INTERVAL))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \DOMAIN.ROOT \DOMAIN.NAMESERVERS \DOMAIN.UNKNOWN.DOMAINS \DOMAIN.GC.TIMER 
       \DOMAIN.GC.INTERVAL)
)
(DEFINEQ

(\DOMAIN.ADD.NEW.DOMAIN
  [LAMBDA (NODE DOMAIN NAMESERVER ADDRESSES TTL)         (* ejs%: "25-Apr-86 12:25")
          
          (* * Add DOMAIN as a subdomain of NODE, with name service by NAMESERVER, at 
        addresses ADDRESSES, with expiration TTL seconds from now)

    (LET ((SUBDOMAIN (create DOMAIN.TREE.NODE
                            SUPERDOMAIN _ NODE
                            NAME _ DOMAIN)))
         (push (fetch (DOMAIN.TREE.NODE SUBDOMAINS) of NODE)
                SUBDOMAIN)
         [COND
            (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                   (printout DOMAIN.TRACE.FILE "Adding " DOMAIN " as subdomain of " (\DOMAIN.NAME
                                                                                     NODE]
         (COND
            (NAMESERVER                                      (* Add name server information to 
                                                           new subdomain)
                   (COND
                      (DOMAIN.TRACE.FLG (printout DOMAIN.TRACE.FILE " with name server " NAMESERVER))
                      )
                   (\DOMAIN.ADD.NAMESERVER SUBDOMAIN NAMESERVER ADDRESSES TTL])

(\DOMAIN.ADD.NAMESERVER
  [LAMBDA (NODE NAMESERVER ADDRESSES TTL)                (* ejs%: "25-Apr-86 12:34")
          
          (* * Function called to add name server information to a node in the domain 
        tree. If ADDRESSES is NIL, this function will query the internet to resolve 
        the information)

    (COND
       (NAMESERVER (LET [(DOMAIN.SERVER (OR (GETHASH NAMESERVER \DOMAIN.NAMESERVERS)
                                            (PUTHASH NAMESERVER
                                                   (create DOMAIN.SERVER
                                                          NAME _ NAMESERVER
                                                          ADDRESSES _ ADDRESSES
                                                          EXPIRATION.DATE _
                                                          (IPLUS (IDATE)
                                                                 (OR (NUMBERP TTL)
                                                                     3600)))
                                                   \DOMAIN.NAMESERVERS]
                        [COND
                           ([AND (NULL ADDRESSES)
                                 (NULL (SETQ ADDRESSES (fetch (DOMAIN.SERVER ADDRESSES)
                                                          of DOMAIN.SERVER]
                            (SETQ ADDRESSES (replace (DOMAIN.SERVER ADDRESSES) of 
                                                                                        DOMAIN.SERVER
                                               with (OR ADDRESSES (DOMAIN.LOOKUP.ADDRESS
                                                                       NAMESERVER NIL T]
                        (COND
                           [ADDRESSES (COND
                                         ((NOT (for SERVER in (fetch (DOMAIN.TREE.NODE
                                                                                  NAMESERVERS)
                                                                         of NODE)
                                                  thereis (STRING-EQUAL SERVER NAMESERVER)))
                                          [COND
                                             (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                                                    (printout DOMAIN.TRACE.FILE "Adding " NAMESERVER 
                                                           " as new name server for " (\DOMAIN.NAME
                                                                                       NODE]
                                          (push (fetch (DOMAIN.TREE.NODE NAMESERVERS)
                                                       of NODE)
                                                 NAMESERVER)
                                          (push (fetch (DOMAIN.SERVER FOR.DOMAINS)
                                                       of DOMAIN.SERVER)
                                                 NODE]
                           (T (PUTHASH NAMESERVER NIL \DOMAIN.NAMESERVERS])

(\DOMAIN.AUGMENT.TREE
  [LAMBDA (RRLST)                                        (* ejs%: "14-Nov-86 14:30")
          
          (* * RRLST is a list of RRTYPE.NS and/or RRTYPE.A records.
        Build up our model of the internet domain tree by processing the information 
        in RRLST)

    (bind NAMESERVER for RR in RRLST do (COND
                                                           ((EQ (LISTGET RR 'TYPE)
                                                                RRTYPE.NS)
                                                            (SETQ NAMESERVER (LISTGET RR 'DATA))
                                                            (\DOMAIN.INSERT.IN.TREE
                                                             (LISTGET RR 'NAME)
                                                             NAMESERVER
                                                             (\DOMAIN.SEARCH.RESOURCE.LIST RRLST 
                                                                    NAMESERVER RRTYPE.A NIL)
                                                             (LISTGET RR 'TTL])

(\DOMAIN.CHOOSE.BEST.SERVERS
  [LAMBDA (DOMAIN)                                       (* ejs%: " 1-May-86 17:15")
          
          (* * This function chooses the best servers for a query to resolve DOMAIN)

    (LET* [(PATH (COND
                    ((AND (NLISTP DOMAIN)
                          DOMAIN)
                     (DREVERSE (\DOMAIN.PARSE.NAME DOMAIN)))
                    (T DOMAIN)))
           (BEST.CHOICE (bind NEXT (CURRENT _ \DOMAIN.ROOT) for NAME in PATH
                           while [SETQ NEXT (for SUBDOMAIN in (fetch (
                                                                                     DOMAIN.TREE.NODE
                                                                                      SUBDOMAINS)
                                                                             of CURRENT)
                                                   thereis (STRING-EQUAL NAME (fetch
                                                                                   (DOMAIN.TREE.NODE
                                                                                    NAME)
                                                                                     of SUBDOMAIN
                                                                                   ]
                           do (SETQ CURRENT NEXT) finally (RETURN CURRENT]
          [while BEST.CHOICE do (COND
                                           ((fetch (DOMAIN.TREE.NODE NAMESERVERS) of 
                                                                                          BEST.CHOICE
                                                   )
                                            (RETURN))
                                           (T (SETQ BEST.CHOICE (fetch (DOMAIN.TREE.NODE 
                                                                                  SUPERDOMAIN)
                                                                   of BEST.CHOICE]
          [COND
             ((EQ BEST.CHOICE \DOMAIN.ROOT)
          
          (* Here we have a problem. Is the request for a subdomain of ROOT
        (e.g. COM, GOV, EDU, etc)%, or for a local name in our own domain?)

              (COND
                 [(AND (EQLENGTH PATH 1)
                       (for SUBDOMAIN in (fetch (DOMAIN.TREE.NODE SUBDOMAINS)
                                                    of \DOMAIN.ROOT)
                          thereis (STRING-EQUAL (CAR PATH)
                                             (fetch (DOMAIN.TREE.NODE NAME) of SUBDOMAIN]
                 (T 
          
          (* Heuristic%: If the domain doesn't appear to be a subdomain of the root, 
        assume that the local domain server will know it.
        If we're wrong, the local name server will tell us)

                    (SETQ BEST.CHOICE NIL]
          (COND
             [(NULL BEST.CHOICE)
              (COND
                 ((OR (EQLENGTH PATH 1)
                      (NULL (fetch (DOMAIN.TREE.NODE NAMESERVERS) of \DOMAIN.ROOT)))
                  (COND
                     (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                            (printout DOMAIN.TRACE.FILE "Best choice for " DOMAIN 
                                   " is our local server: " \DOMAIN.DEFAULT.SERVER)))
                  (SORT (MKLIST \DOMAIN.DEFAULT.SERVER)
                        (FUNCTION \DOMAIN.SORT.BY.SVC.TIME)))
                 (T (COND
                       (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                              (printout DOMAIN.TRACE.FILE "Best choice for " DOMAIN 
                                     " is the root server")))
                    (SORT (fetch (DOMAIN.TREE.NODE NAMESERVERS) of \DOMAIN.ROOT)
                          (FUNCTION \DOMAIN.SORT.BY.SVC.TIME]
             (T [COND
                   (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                          (printout DOMAIN.TRACE.FILE "Best choice(s) for " DOMAIN ": "
                                 (fetch (DOMAIN.TREE.NODE NAMESERVERS) of BEST.CHOICE]
                (SORT (fetch (DOMAIN.TREE.NODE NAMESERVERS) of BEST.CHOICE)
                      (FUNCTION \DOMAIN.SORT.BY.SVC.TIME])

(\DOMAIN.FIND.DOMAIN.IN.TREE
  [LAMBDA (NAME)                                         (* ejs%: "13-Apr-86 01:25")
    (COND
       ((STREQUAL NAME "")
        \DOMAIN.ROOT)
       (T (LET ([PATH (COND
                         ((LISTP NAME)
                          (REVERSE NAME))
                         (T (DREVERSE (\DOMAIN.PARSE.NAME NAME]
                (CURRENT \DOMAIN.ROOT))
               (bind NEXT for NODE on PATH
                  do (COND
                            ([NOT (SETQ NEXT (for SUBDOMAIN in (fetch (DOMAIN.TREE.NODE
                                                                                   SUBDOMAINS)
                                                                          of CURRENT)
                                                thereis (STRING-EQUAL (CAR NODE)
                                                                   (fetch (DOMAIN.TREE.NODE
                                                                               NAME) of SUBDOMAIN
                                                                          ]
                             (RETURN (CONS CURRENT NODE)))
                            (T (SETQ CURRENT NEXT))) finally (RETURN CURRENT])

(\DOMAIN.INIT
  [LAMBDA (EVENT)                                        (* ejs%: " 1-May-86 15:46")
    (SETQ \DOMAIN.DEFAULT.SERVER
     (bind NAME for SERVER in (fetch (IPINIT DOMAIN.SERVERS) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                 ) as SERVER# from 1
        collect (SETQ NAME (CONCAT "Local-Domain-Server-" SERVER#))
              (PUTHASH NAME (create DOMAIN.SERVER
                                   NAME _ NAME
                                   EXPIRATION.DATE _ MAX.FIXP
                                   ADDRESSES _ (LIST (\IP.READ.STRING.ADDRESS SERVER)))
                     \DOMAIN.NAMESERVERS)
              NAME])

(\DOMAIN.INSERT.IN.TREE
  [LAMBDA (DOMAIN NAMESERVER ADDRESSES TTL)              (* ejs%: "25-Apr-86 12:21")
          
          (* * Given information from an RRTYPE.NS record, add an entry to the domain 
        tree)

    (LET ((PARTIAL.PATH (\DOMAIN.FIND.DOMAIN.IN.TREE DOMAIN)))
         (COND
            ((type? DOMAIN.TREE.NODE PARTIAL.PATH)       (* Found it)
             (\DOMAIN.ADD.NAMESERVER PARTIAL.PATH NAMESERVER ADDRESSES TTL))
            ((EQLENGTH PARTIAL.PATH 2)                       (* Only one away from previous 
                                                           knowledge?)
             (\DOMAIN.ADD.NEW.DOMAIN (CAR PARTIAL.PATH)
                    (CADR PARTIAL.PATH)
                    NAMESERVER ADDRESSES TTL))
            (T 
          
          (* Some number of domains between our deepest knowledge and the desired 
        domain)

               (\DOMAIN.ADD.NEW.DOMAIN (CAR PARTIAL.PATH)
                      (CADR PARTIAL.PATH))
               (\DOMAIN.INSERT.IN.TREE DOMAIN NAMESERVER ADDRESSES TTL])

(\DOMAIN.PATH
  [LAMBDA (DOMAIN.TREE.NODE)                             (* ejs%: "13-Apr-86 14:44")
          
          (* * Generate a list of domain names along the path to the root of the domain 
        tree)

    (COND
       ((NULL (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of DOMAIN.TREE.NODE))
        NIL)
       (T (CONS (fetch (DOMAIN.TREE.NODE NAME) of DOMAIN.TREE.NODE)
                (\DOMAIN.PATH (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of DOMAIN.TREE.NODE])

(\DOMAIN.SEARCH.RESOURCE.LIST
  [LAMBDA (RRLST NAME TYPE OK.TO.RETURN.NAME)            (* ejs%: "14-Nov-86 14:40")
    (LET [(ANSWER (bind DATA for RR in RRLST collect (SETQ DATA (LISTGET RR
                                                                                       'DATA))
                                                               (COND
                                                                  ((AND DATA (EQ TYPE RRTYPE.A)
                                                                        OK.TO.RETURN.NAME)
                                                                   (LISTGET RR 'NAME))
                                                                  (T DATA))
                     when (AND (EQ TYPE (LISTGET RR 'TYPE))
                                   (DOMAIN.NAME.EQUAL (LISTGET RR 'NAME)
                                          NAME]
         (COND
            (ANSWER)
            (T (LET [(CANONICAL.NAME (bind FOUNDIT DATA for RR in RRLST
                                        thereis (AND (EQ RRTYPE.CNAME (LISTGET RR 'TYPE))
                                                         (DOMAIN.NAME.EQUAL (LISTGET RR
                                                                                       'NAME)
                                                                NAME)
                                                         (SETQ FOUNDIT T))
                                        finally (RETURN (AND FOUNDIT (LISTGET RR 'DATA]
                    (COND
                       (CANONICAL.NAME (\DOMAIN.SEARCH.RESOURCE.LIST RRLST CANONICAL.NAME TYPE 
                                              OK.TO.RETURN.NAME])

(\DOMAIN.DELETE.NAMESERVER
  [LAMBDA (NAMESERVER)                                   (* ejs%: "13-Apr-86 18:35")
    (LET ((DOMAIN.SERVER (GETHASH NAMESERVER \DOMAIN.NAMESERVERS)))
         (COND
            (DOMAIN.SERVER [bind NAMESERVERS for DOMAIN in (fetch (DOMAIN.SERVER
                                                                                   FOR.DOMAINS)
                                                                          of DOMAIN.SERVER)
                              do (SETQ NAMESERVERS (fetch (DOMAIN.TREE.NODE NAMESERVERS)
                                                          of DOMAIN))
                                    (bind for NAME in NAMESERVERS
                                       when (STRING-EQUAL NAME NAMESERVER)
                                       do (replace (DOMAIN.TREE.NODE NAMESERVERS)
                                                 of DOMAIN with (DREMOVE NAME NAMESERVERS]
                   (PUTHASH NAMESERVER NIL \DOMAIN.NAMESERVERS])

(\DOMAIN.AROUND.EXIT
  [LAMBDA (EVENT)                                        (* ejs%: "13-Apr-86 18:30")
    (SELECTQ EVENT
        ((NIL AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) 
             (\DOMAIN.DELETE.TREE))
        NIL])

(\DOMAIN.DELETE.TREE
  [LAMBDA NIL                                            (* ejs%: "13-Apr-86 17:39")
          
          (* * Undoes circularity in pointers between levels of the tree)

    (bind (OPEN _ (LIST \DOMAIN.ROOT))
           CLOSED CURRENT while OPEN do (SETQ CURRENT (pop OPEN))
                                               (SETQ OPEN (APPEND (fetch (DOMAIN.TREE.NODE 
                                                                                    SUBDOMAINS)
                                                                     of CURRENT)
                                                                 OPEN))
                                               (replace (DOMAIN.TREE.NODE SUBDOMAINS)
                                                  of CURRENT with NIL)
                                               (replace (DOMAIN.TREE.NODE NAME) of CURRENT
                                                  with NIL)
                                               (replace (DOMAIN.TREE.NODE NAMESERVERS)
                                                  of CURRENT with NIL)
                                               (replace (DOMAIN.TREE.NODE SUPERDOMAIN)
                                                  of CURRENT with NIL))
    [MAPHASH \DOMAIN.NAMESERVERS (FUNCTION (LAMBDA (DOMAIN.SERVER NAME)
                                             (replace (DOMAIN.SERVER FOR.DOMAINS) of 
                                                                                        DOMAIN.SERVER
                                                with NIL]
    (CLRHASH \DOMAIN.NAMESERVERS)
    NIL])

(\DOMAIN.BACKGROUND
  [LAMBDA NIL                                            (* ejs%: "13-Apr-86 18:24")
    (COND
       ((TIMEREXPIRED? \DOMAIN.GC.TIMER)
        (\DOMAIN.GC.NAMESERVERS)
        (SETQ \DOMAIN.GC.TIMER (SETUPTIMER \DOMAIN.GC.INTERVAL \DOMAIN.GC.TIMER])

(\DOMAIN.GC.NAMESERVERS
  [LAMBDA NIL                                            (* ; "Edited 11-Feb-89 12:36 by akw:")

         (* * This function maps over the name server hash array, and removes old 
       servers which have timed out)

    (LET ((TIME (IDATE)))
         (DECLARE (SPECVARS TIME))
         [MAPHASH \DOMAIN.NAMESERVERS (FUNCTION (LAMBDA (DOMAIN.SERVER NAME)
                                                  (DECLARE (USEDFREE TIME))
                                                  (COND
                                                     ((MEMBER NAME (fetch (IPINIT DOMAIN.SERVERS)
                                                                      of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                                          ))
                                                      T)
                                                     ((ILESSP (fetch (DOMAIN.SERVER 
                                                                                EXPIRATION.DATE)
                                                                 of DOMAIN.SERVER)
                                                             TIME)
                                                      (COND
                                                         (DOMAIN.TRACE.FLG (FRESHLINE 
                                                                                  DOMAIN.TRACE.FILE)
                                                                (printout DOMAIN.TRACE.FILE 
                                                                       "Name server " NAME 
                                                                       " has expired; deleting...")))
                                                      (\DOMAIN.DELETE.NAMESERVER NAME]
         NIL])

(\DOMAIN.SORT.BY.SVC.TIME
  [LAMBDA (NAME1 NAME2)                                  (* ejs%: "13-Apr-86 18:14")
    (LET ((R1 (GETHASH NAME1 \DOMAIN.NAMESERVERS))
          (R2 (GETHASH NAME2 \DOMAIN.NAMESERVERS)))
         (ILESSP (OR (fetch (DOMAIN.SERVER AVG.SVC.TIME) of R1)
                     0)
                (OR (fetch (DOMAIN.SERVER AVG.SVC.TIME) of R2)
                    0])
)

(ADDTOVAR BACKGROUNDFNS \DOMAIN.BACKGROUND)



(* ;; "Programmer's interface")


(RPAQ? DOMAIN.TRACE.FLG )

(RPAQ? DOMAIN.TRACE.FILE )

(RPAQ? INTERNET.LOCAL.DOMAIN )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DOMAIN.TRACE.FLG DOMAIN.TRACE.FILE INTERNET.LOCAL.DOMAIN)
)
(DEFINEQ

(DOMAIN.INIT
  [LAMBDA NIL                                            (* ; "Edited 15-Feb-88 17:26 by Snow")
          
          (* ;; "Called to initialize the domain service for this host")

    (DECLARE (GLOBALVARS \DOMAIN.DEFAULT.SERVER INTERNET.LOCAL.DOMAIN))
    (if (NOT \IP.DEFAULT.CONFIGURATION)
        then (PROMPTPRINT "Internet domain code is loaded, but disabled.")
      else (LET [(LOCAL.DOMAIN.SERVERS (fetch (IPINIT DOMAIN.SERVERS) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                  ))
                     (LOCAL.DOMAIN (MKSTRING (fetch (IPINIT LOCAL.DOMAIN) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                    ]
                    (COND
                       ((AND LOCAL.DOMAIN.SERVERS LOCAL.DOMAIN)
                        (SETQ \DOMAIN.DEFAULT.SERVER (for ADDR inside LOCAL.DOMAIN.SERVERS
                                                        collect (MKSTRING ADDR)))
                        (SETQ INTERNET.LOCAL.DOMAIN LOCAL.DOMAIN)
                        (for NAMESERVER in LOCAL.DOMAIN.SERVERS
                           do (\DOMAIN.INSERT.IN.TREE LOCAL.DOMAIN (MKSTRING NAMESERVER)
                                         (LIST (DODIP.HOSTP NAMESERVER))
                                         MAX.FIXP)))
                       (T (PROMPTPRINT "Internet domain code is loaded, but disabled."])

(DOMAIN.LOOKUP.ADDRESS
  [LAMBDA (NAME SERVER DONT.GET.OSTYPE)                  (* ; "Edited 15-Feb-89 15:14 by welch")

         (* * Programmer's interface to lookup IP Internet host name using the domain 
       system)

    (bind (OPEN _ (OR (MKLIST SERVER)
                          (\DOMAIN.CHOOSE.BEST.SERVERS NAME)))
           CANONICAL.NAME CLOSED ADDRESSES THIS.SERVER ANSWER OSTYPE (ATOMIC-NAME _
                                                                            (MKATOM (U-CASE NAME)))
       while OPEN do (SETQ THIS.SERVER (pop OPEN))
                            (push CLOSED THIS.SERVER)
                            (SETQ ANSWER (DOMAIN.LOOKUP NAME RRTYPE.A THIS.SERVER))
                            (COND
                               ((SETQ ADDRESSES (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER NAME 
                                                       RRTYPE.A))
                                (\DOMAIN.AUGMENT.TREE ANSWER)
                                [SETQ OSTYPE (COND
                                                (DONT.GET.OSTYPE NIL)
                                                (T (DOMAIN.LOOKUP.OSTYPE NAME]
                                (PUTHASH ATOMIC-NAME (create HOSTS.TXT.ENTRY
                                                            HTE.TYPE _ 'HOST
                                                            HTE.ADDRESSES _ ADDRESSES
                                                            HTE.NAMES _ (LIST ATOMIC-NAME)
                                                            HTE.OS.TYPE _ OSTYPE)
                                       \IP.HOSTNAMES)
                                (RETURN ADDRESSES))
                               (ANSWER (COND
                                          ([SETQ CANONICAL.NAME (MKATOM (U-CASE (
                                                                  \DOMAIN.SEARCH.FOR.CANONICAL.NAME
                                                                                 NAME ANSWER]
                                           (SETQ ADDRESSES (DOMAIN.LOOKUP.ADDRESS CANONICAL.NAME
                                                                  SERVER))
                                           (PUTHASH ATOMIC-NAME (GETHASH CANONICAL.NAME \IP.HOSTNAMES
                                                                       )
                                                  \IP.HOSTNAMES)
                                           (RETURN ADDRESSES))
                                          (T (\DOMAIN.AUGMENT.TREE ANSWER)
                                             (SETQ OPEN (APPEND (for NEXT.SERVER
                                                                   in (
                                                                       \DOMAIN.SEARCH.RESOURCE.LIST
                                                                           ANSWER
                                                                           '* RRTYPE.A T)
                                                                   when (NOT (MEMBER NEXT.SERVER
                                                                                        CLOSED))
                                                                   collect NEXT.SERVER)
                                                               OPEN])

(DOMAIN.LOOKUP.NAMESERVER
  [LAMBDA (NAME SERVER)                                  (* ejs%: "25-Apr-86 12:55")
          
          (* * Programmer's interface to lookup IP Internet host name using the domain 
        system)

    (bind (OPEN _ (OR (MKLIST SERVER)
                          (\DOMAIN.CHOOSE.BEST.SERVERS NAME)))
           CLOSED NAMESERVERS THIS.SERVER ANSWER while OPEN
       do (SETQ THIS.SERVER (pop OPEN))
             (push CLOSED THIS.SERVER)
             (SETQ ANSWER (DOMAIN.LOOKUP NAME RRTYPE.NS THIS.SERVER))
             (COND
                ((SETQ NAMESERVERS (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER NAME RRTYPE.NS))
                 (\DOMAIN.AUGMENT.TREE ANSWER)
                 (RETURN NAMESERVERS))
                (ANSWER (\DOMAIN.AUGMENT.TREE ANSWER)
                       (SETQ OPEN (APPEND (for NEXT.SERVER in (\DOMAIN.SEARCH.RESOURCE.LIST
                                                                       ANSWER
                                                                       '* RRTYPE.A T)
                                             when (NOT (MEMBER NEXT.SERVER CLOSED)) collect
                                                                                        NEXT.SERVER)
                                         OPEN])

(DOMAIN.LOOKUP.OSTYPE
  [LAMBDA (NAME SERVER)                                  (* ejs%: "14-Nov-86 14:46")
          
          (* * Programmer's interface to lookup IP Internet host name using the domain 
        system)

    (bind (OPEN _ (OR (MKLIST SERVER)
                          (\DOMAIN.CHOOSE.BEST.SERVERS NAME)))
           CANONICAL.NAME CLOSED CPU.OSTYPES THIS.SERVER ANSWER while OPEN
       do (SETQ THIS.SERVER (pop OPEN))
             (push CLOSED THIS.SERVER)
             (SETQ ANSWER (DOMAIN.LOOKUP NAME RRTYPE.HINFO THIS.SERVER))
             (COND
                [(SETQ CPU.OSTYPES (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER NAME RRTYPE.HINFO))
                 (\DOMAIN.AUGMENT.TREE ANSWER)
                 (RETURN (MKATOM (U-CASE (CDAR CPU.OSTYPES]
                (ANSWER (COND
                           ((SETQ CANONICAL.NAME (\DOMAIN.SEARCH.FOR.CANONICAL.NAME NAME ANSWER))
                            (RETURN (DOMAIN.LOOKUP.OSTYPE CANONICAL.NAME SERVER)))
                           (T (\DOMAIN.AUGMENT.TREE ANSWER)
                              (SETQ OPEN (APPEND (for NEXT.SERVER
                                                    in (\DOMAIN.SEARCH.RESOURCE.LIST
                                                            ANSWER
                                                            '* RRTYPE.A T)
                                                    when (NOT (MEMBER NEXT.SERVER CLOSED))
                                                    collect NEXT.SERVER)
                                                OPEN])

(DOMAIN.LOOKUP
  [LAMBDA (NAME TYPE SERVER)                             (* ; "Edited 15-Feb-88 17:24 by Snow")

(* ;;; "Programmer's interface to lookup IP Internet host name using the domain system")

    (PROG ((DOMAIN.PATH (\DOMAIN.PARSE.NAME NAME))
           (RETRYCOUNT 0)
           ANSWER ADDRESS TIMINGFLG START.TIME)
          (OR TYPE (SETQ TYPE RRTYPE.A))
          [COND
             [(LISTP SERVER)
              (SETQ ADDRESS (COND
                               [(LISTP (CAR SERVER))         (* ; 
                                                          "Handles a list of DOMAIN.SERVER records")

                                (CAR (fetch (DOMAIN.SERVER ADDRESSES) of (CAR SERVER]
                               (T                            (* ; "Handles a list of addresses")

                                  (CAR SERVER]
             (SERVER                                         (* ; "Handles a single address")

                    (SETQ ADDRESS SERVER))
             (T (SETQ SERVER \DOMAIN.DEFAULT.SERVER)
                (SETQ ADDRESS (CAR SERVER]
          [COND
             ((STRINGP ADDRESS)
              (SETQ ADDRESS (CAR (fetch (DOMAIN.SERVER ADDRESSES) of (SETQ TIMINGFLG
                                                                              (GETHASH ADDRESS 
                                                                                  \DOMAIN.NAMESERVERS
                                                                                     ]
          (COND
             (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE)
                    (PRIN1 "Type " DOMAIN.TRACE.FILE)
                    (PRINTCONSTANT TYPE DOMAIN.RRTYPES DOMAIN.TRACE.FILE)
                    (printout DOMAIN.TRACE.FILE " query to " (COND
                                                                ((NUMBERP SERVER)
                                                                 (\IP.ADDRESS.TO.STRING SERVER))
                                                                (T SERVER))
                           " for " NAME T)))
      LOOP
          (add RETRYCOUNT 1)
          [COND
             (TIMINGFLG (SETQ START.TIME (IDATE]
          [SETQ ANSWER (COND
                          ((NULL ANSWER)
                           (\UDPDOM.QUERY DOMAIN.PATH TYPE CLASSTYPE.IN ADDRESS))
                          ((EQ ANSWER 'USE.TCP)
                           (\TCPDOM.QUERY DOMAIN.PATH TYPE CLASSTYPE.IN ADDRESS]
          [COND
             (TIMINGFLG (replace (DOMAIN.SERVER AVG.SVC.TIME) of TIMINGFLG
                           with (IDIFFERENCE (IDATE)
                                           START.TIME]
          (COND
             ((LITATOM ANSWER)
              (SELECTQ ANSWER
                  (NIL (COND
                          ((LISTP SERVER)
                           (SETQ SERVER (CDR SERVER))
                           [SETQ ADDRESS (CAR (fetch (DOMAIN.SERVER ADDRESSES)
                                                 of (CAR SERVER]
                           (SETQ RETRYCOUNT 0)
                           (GO LOOP))
                          (T (RETURN ANSWER))))
                  (NAME.ERROR (RETURN NIL))
                  (USE.TCP (COND
                              ((EQ RETRYCOUNT 1)
                               (GO LOOP))
                              (T (RETURN NIL))))
                  (RETURN ANSWER)))
             (T (RETURN ANSWER])

(DOMAIN.GRAPH
  [LAMBDA (WINDOW)                                       (* ; "Edited 19-Mar-87 16:58 by FS")

    (LET ((OPENLIST (LIST \DOMAIN.ROOT))
          NODELST)
         (bind NODE while OPENLIST do (SETQ NODE (pop OPENLIST))
                                                 (push NODELST
                                                        (create GRAPHNODE
                                                               NODELABEL _
                                                               (COND
                                                                  ((NULL (fetch (DOMAIN.TREE.NODE
                                                                                     SUPERDOMAIN)
                                                                            of NODE))
                                                                   "*ROOT*")
                                                                  (T (fetch (DOMAIN.TREE.NODE
                                                                                 NAME) of NODE)))
                                                               NODEID _ NODE
                                                               TONODES _ (fetch (DOMAIN.TREE.NODE
                                                                                     SUBDOMAINS)
                                                                            of NODE)))
                                                 (SETQ OPENLIST (APPEND (fetch (DOMAIN.TREE.NODE
                                                                                    SUBDOMAINS)
                                                                           of NODE)
                                                                       OPENLIST)))
         (SHOWGRAPH (LAYOUTGRAPH NODELST (LIST \DOMAIN.ROOT)
                           'HORIZONTAL)
                WINDOW
                (FUNCTION (LAMBDA (NODE W)
                            (COND
                               (NODE (INSPECT (fetch (GRAPHNODE NODEID) of NODE)))
                               (T (DOMAIN.GRAPH W])

(DOMAIN.NAME.EQUAL
  [LAMBDA (NAME1 NAME2)                                  (* ejs%: "13-Apr-86 17:23")
    (COND
       ((OR (EQ NAME1 '*)
            (EQ NAME2 '*))
        T)
       (T (OR (LISTP NAME1)
              (SETQ NAME1 (\DOMAIN.PARSE.NAME NAME1)))
          (OR (LISTP NAME2)
              (SETQ NAME2 (\DOMAIN.PARSE.NAME NAME2)))
          (COND
             ((OR (AND (NULL NAME1)
                       NAME2)
                  (AND (NULL NAME2)
                       NAME1))
              NIL)
             (T (for X in NAME1 as Y in NAME2 always (STRING-EQUAL X Y])

(DOMAIN.TRACE
  [LAMBDA (MODE)                                         (* ejs%: "13-Apr-86 16:12")
    [COND
       ((WINDOWP DOMAIN.TRACE.FILE)
        (OPENW DOMAIN.TRACE.FILE))
       (T (SETQ DOMAIN.TRACE.FILE (CREATEW NIL "Domain Trace File"))
          (DSPSCROLL 'ON DOMAIN.TRACE.FILE)
          (DSPFONT '(GACHA 8) DOMAIN.TRACE.FILE)
          (WINDOWPROP DOMAIN.TRACE.FILE 'BUTTONEVENTFN (FUNCTION DOMAIN.TRACEWINDOW.BUTTONFN))
          (WINDOWPROP DOMAIN.TRACE.FILE 'CLOSEFN (FUNCTION (LAMBDA NIL
                                                             (SETQ DOMAIN.TRACE.FLG NIL)
                                                             (SETQ DOMAIN.TRACE.FILE]
    (SETQ DOMAIN.TRACE.FLG MODE])

(DOMAIN.TRACEWINDOW.BUTTONFN
  [LAMBDA (WINDOW)                                       (* ejs%: "13-Apr-86 15:49")
    (COND
       ((MOUSESTATE (NOT UP))
        (SETQ DOMAIN.TRACE.FLG (SELECTQ DOMAIN.TRACE.FLG
                                   (NIL T)
                                   (T NIL)
                                   NIL))
        (printout WINDOW T "[Tracing " (SELECTQ DOMAIN.TRACE.FLG
                                           (T "on")
                                           "off")
               "]" T])
)

(DOMAIN.INIT)
(PUTPROPS TCPDOMAIN COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4891 12420 (\UDPDOM.PROCESS.RESPONSE 4901 . 6651) (\UDPDOM.QUERY 6653 . 11968) (
\UDPDOM.IPSOCKET 11970 . 12418)) (15354 27202 (\DOMAIN.NAME 15364 . 16190) (\DOMAIN.PACK.NAME.LIST 
16192 . 17169) (\DOMAIN.PARSE.NAME 17171 . 18511) (\DOMAIN.RCODE.ERROR 18513 . 18946) (
\DOMAIN.PROCESS.REDIRECT 18948 . 19944) (\DOMAIN.PROCESS.RESPONSE 19946 . 20717) (\DOMAIN.PROCESS.RR 
20719 . 22311) (\DOMAIN.READ.ADDRESS 22313 . 22999) (\DOMAIN.READ.NAME.FROM.STREAM 23001 . 24730) (
\DOMAIN.READ.STRING.FROM.STREAM 24732 . 25048) (\DOMAIN.SEARCH.FOR.CANONICAL.NAME 25050 . 25758) (
\DOMAIN.SKIP.NAME.IN.STREAM 25760 . 26267) (\DOMAIN.SKIP.QUESTION 26269 . 26599) (\DOMAIN.SKIP.RR 
26601 . 27200)) (28554 29256 (USTRINGHASHBITS 28564 . 29254)) (29754 50847 (\DOMAIN.ADD.NEW.DOMAIN 
29764 . 30996) (\DOMAIN.ADD.NAMESERVER 30998 . 34156) (\DOMAIN.AUGMENT.TREE 34158 . 35305) (
\DOMAIN.CHOOSE.BEST.SERVERS 35307 . 39679) (\DOMAIN.FIND.DOMAIN.IN.TREE 39681 . 40954) (\DOMAIN.INIT 
40956 . 41749) (\DOMAIN.INSERT.IN.TREE 41751 . 42869) (\DOMAIN.PATH 42871 . 43387) (
\DOMAIN.SEARCH.RESOURCE.LIST 43389 . 45139) (\DOMAIN.DELETE.NAMESERVER 45141 . 46218) (
\DOMAIN.AROUND.EXIT 46220 . 46475) (\DOMAIN.DELETE.TREE 46477 . 48201) (\DOMAIN.BACKGROUND 48203 . 
48489) (\DOMAIN.GC.NAMESERVERS 48491 . 50427) (\DOMAIN.SORT.BY.SVC.TIME 50429 . 50845)) (51144 66800 (
DOMAIN.INIT 51154 . 52770) (DOMAIN.LOOKUP.ADDRESS 52772 . 56193) (DOMAIN.LOOKUP.NAMESERVER 56195 . 
57556) (DOMAIN.LOOKUP.OSTYPE 57558 . 59197) (DOMAIN.LOOKUP 59199 . 62699) (DOMAIN.GRAPH 62701 . 64901)
 (DOMAIN.NAME.EQUAL 64903 . 65527) (DOMAIN.TRACE 65529 . 66257) (DOMAIN.TRACEWINDOW.BUTTONFN 66259 . 
66798)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPEXPORTS b/obsolete/tcp/TCPEXPORTS
deleted file mode 100644
index f700b47b..00000000
--- a/obsolete/tcp/TCPEXPORTS
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(LISPXPRIN1 "EXPORTS GATHERED FROM {ERIS}<LispCore>Library>TCP*.; ON 11-Sep-89 16:08:46"  T)
(LISPXTERPRI T)
(RPAQQ \TCP.CTRL.ACK 16)
(RPAQQ \TCP.CTRL.FIN 1)
(RPAQQ \TCP.CTRL.PSH 8)
(RPAQQ \TCP.CTRL.RST 4)
(RPAQQ \TCP.CTRL.SYN 2)
(RPAQQ \TCP.CTRL.URG 32)
(CONSTANTS \TCP.CTRL.ACK \TCP.CTRL.FIN \TCP.CTRL.PSH \TCP.CTRL.RST \TCP.CTRL.SYN \TCP.CTRL.URG)
(RPAQQ \TCPOPT.END 0)
(RPAQQ \TCPOPT.NOP 1)
(RPAQQ \TCPOPT.MAXSEG 2)
(CONSTANTS \TCPOPT.END \TCPOPT.NOP \TCPOPT.MAXSEG)
(RPAQQ \TCP.PROTOCOL 6)
(CONSTANTS \TCP.PROTOCOL)
(RPAQQ \TCP.HEADER.LENGTH 20)
(CONSTANTS \TCP.HEADER.LENGTH)
(RPAQQ \TCP.MIN.DATA.OFFSET 5)
(CONSTANTS \TCP.MIN.DATA.OFFSET)
(RPAQQ \TCP.DEFAULT.MAXSEG 536)
(CONSTANTS \TCP.DEFAULT.MAXSEG)
(ACCESSFNS TCPSEGMENT ((TCPHEADER (\IPDATABASE DATUM))) (BLOCKRECORD TCPHEADER ((TCP.SRC.PORT WORD) (
TCP.DST.PORT WORD) (TCP.SEQ FIXP) (TCP.ACK FIXP) (TCP.DATA.OFFSET BITS 4) (TCP.MBZ BITS 6) (TCP.CTRL 
BITS 6) (TCP.WINDOW WORD) (TCP.CHECKSUM WORD) (TCP.URG.PTR WORD))) (ACCESSFNS TCPSEGMENT ((
TCP.DATA.LENGTH (fetch (IP IPHEADERCHECKSUM) of DATUM) (replace (IP IPHEADERCHECKSUM) of DATUM with 
NEWVALUE)) (TCP.SRC.ADDR (fetch (IP IPSOURCEADDRESS) of DATUM) (replace (IP IPSOURCEADDRESS) of DATUM 
with NEWVALUE)) (TCP.DST.ADDR (fetch (IP IPDESTINATIONADDRESS) of DATUM) (replace (IP 
IPDESTINATIONADDRESS) of DATUM with NEWVALUE)) (TCP.HEADER.LENGTH (LLSH (fetch TCP.DATA.OFFSET of 
DATUM) 2)) (TCP.CONTENTS (\ADDBASE (fetch TCPHEADER of DATUM) (UNFOLD (fetch TCP.DATA.OFFSET of DATUM)
 WORDSPERCELL))) (TCP.OPTIONS (\ADDBASE (fetch TCPHEADER of DATUM) (UNFOLD \TCP.MIN.DATA.OFFSET 
WORDSPERCELL))))))
(DATATYPE TCP.CONTROL.BLOCK ((TCB.LOCK POINTER) (* ; "monitor lock for synchronizing access") (
TCB.STATE POINTER) (* ; 
"one of CLOSED LISTEN SYN.SENT SYN.RECEIVED ESTABLISHED FIN.WAIT.1 FIN.WAIT.2 CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT"
) (TCB.SND.STREAM POINTER) (* ; "user's send stream") (TCB.SND.SEGMENT POINTER) (* ; 
"current output packet being filled") (TCB.RCV.STREAM POINTER) (* ; "user's receive stream") (
TCB.RCV.SEGMENT POINTER) (* ; "current input packet being read") (TCB.2MSL.TIMER POINTER) (* ; 
"2*MSL quiet time") (TCB.MAXSEG POINTER) (* ; "maximum segment size") (TCB.CLOSEDFLG POINTER) (* ; 
"T if user has initiated close (no more data to send)") (TCB.FINSEQ POINTER) (* ; 
"one past the sequence number of the FIN we sent") (TCB.ACKFLG POINTER) (* ; 
"when to ACK peer: NOW or LATER") (TCB.TEMPLATE POINTER) (* ; "TCP header template") (TCB.PH POINTER) 
(* ; "TCP pseudo-header for checksumming") (TCB.SRC.PORT WORD) (* ; "local port") (TCB.DST.PORT WORD) 
(* ; "remote port") (TCB.DST.HOST FIXP) (* ; "remote host address") (TCB.INPUT.QUEUE POINTER) (* ; 
"queue of received segments to be read") (TCB.REXMT.QUEUE POINTER) (* ; 
"queue of unacked segments to be retransmitted") (TCB.SND.UNA FIXP) (* ; 
"first unacknowledged sequence number") (TCB.SND.NXT FIXP) (* ; "next sequence number to be sent") (
TCB.SND.UP FIXP) (* ; "send urgent pointer") (TCB.SND.WL1 FIXP) (* ; 
"segment sequence number used for last window update") (TCB.SND.WL2 FIXP) (* ; 
"segment acknowledgment number used for last window update") (TCB.ISS FIXP) (* ; 
"initial send sequence number") (TCB.SND.WND WORD) (* ; "send window") (TCB.RCV.WND WORD) (* ; 
"receive window") (TCB.RCV.NXT FIXP) (* ; "next sequence number expected") (TCB.RCV.UP FIXP) (* ; 
"receive urgent pointer") (TCB.IRS FIXP) (* ; "initial receive sequence number") (TCB.USER.TIMEOUT 
POINTER) (* ; "in milliseconds") (TCB.ESTABLISHED POINTER) (* ; 
"processes waiting for this event are notified when the connection becomes established") (
TCB.SND.EVENT POINTER) (* ; 
"processes waiting for this event are notified when the send window opens up") (TCB.RCV.EVENT POINTER)
 (* ; "processes waiting for this event are notified when data is received") (TCB.URGENT.EVENT POINTER
) (* ; "processes waiting for this event are notified when urgent data is received") (
TCB.FINACKED.EVENT POINTER) (* ; 
"processes waiting for this event are notified when our FIN has been acked") (TCB.MODE POINTER) (* ; 
"ACTIVE or PASSIVE") (TCB.RTFLG POINTER) (* ; "T if round trip time being measured") (TCB.RTSEQ 
POINTER) (* ; "sequence number being timed") (TCB.RTTIMER POINTER) (* ; "round trip timer") (TCB.SRTT 
POINTER) (* ; "smoothed round trip time") (TCB.RTO POINTER) (* ; 
"retransmission timeout based on smoothed round trip time") (TCB.PROBE.TIMER POINTER) (* ; 
"timer for delayed ACKs and window probes") (TCB.IPSOCKET POINTER) (* ; 
"Pointer to open IP socket for this connection") (TCB.PROCESS POINTER) (* ; 
"TCP monitor process for this connection") (TCB.SENT.ZERO FLAG) (* ; 
"Sent a zero allocation last time") (TCB.OUTPUT.HELD FLAG) (* ; "True if output window shut") (
TCB.NO.IDLE.PROBING FLAG) (* ; "True if we don't probe when nothing to output") (NIL BITS 5) (
TCB.OUR.MAXSEG WORD) (TCB.LAST.SENT.RCV.WND WORD) (* ; "The value of the last rcv window we sent")) 
TCB.LOCK _ (CREATE.MONITORLOCK) TCB.STATE _ (QUOTE CLOSED) TCB.RCV.WND _ \TCP.DEFAULT.RECEIVE.WINDOW 
TCB.USER.TIMEOUT _ \TCP.DEFAULT.USER.TIMEOUT TCB.ESTABLISHED _ (CREATE.EVENT) TCB.SND.EVENT _ (
CREATE.EVENT) TCB.RCV.EVENT _ (CREATE.EVENT) TCB.URGENT.EVENT _ (CREATE.EVENT) TCB.FINACKED.EVENT _ (
CREATE.EVENT) TCB.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.OUR.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.SRTT _ 
\TCP.INITIAL.RTO TCB.RTO _ \TCP.INITIAL.RTO)
(ACCESSFNS TCPSTREAM ((TCB (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with NEWVALUE)) 
(BYTECOUNT (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE)) (ACCESS (fetch (
STREAM ACCESS) of DATUM) (replace (STREAM ACCESS) of DATUM with NEWVALUE)) (ORIGINAL.COFFSET (fetch (
STREAM FW6) of DATUM) (replace (STREAM FW6) of DATUM with NEWVALUE))) (CREATE (create STREAM DEVICE _ 
\TCP.DEVICE)))
(PUTPROP (QUOTE TCP) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 17:01:28"))

(PUTPROP (QUOTE TCPCHAT) (QUOTE IMPORTDATE) (IDATE " 7-Jul-88 18:21:44"))

(RECORD IPINIT (LOCAL.ADDRESSES LOCAL.NETWORKS DEFAULT.GATEWAY HTE.FILE HOSTNAME SUBNETMASK 
DOMAIN.SERVERS LOCAL.DOMAIN LOCAL.NSHOSTNUMBER))
(PUTPROP (QUOTE TCPCONFIG) (QUOTE IMPORTDATE) (IDATE "18-Apr-88 21:05:32"))

(PUTPROP (QUOTE TCPDEBUG) (QUOTE IMPORTDATE) (IDATE "16-Apr-87 15:16:27"))

(RPAQQ \UDPDOMAIN.WDS 6)
(CONSTANTS (\UDPDOMAIN.WDS 6))
(BLOCKRECORD DOMAIN.HEADER ((ID WORD) (RESPONSEFLG FLAG) (OPCODE BITS 4) (AUTHORITYFLG FLAG) (
TRUNCATEDFLG FLAG) (WANTRECURSEFLG FLAG) (CANRECURSEFLG FLAG) (NIL BITS 3) (RESPONSECODE BITS 4) (
QDCOUNT WORD) (ANCOUNT WORD) (NSCOUNT WORD) (ARCOUNT WORD)))
(RPAQQ DOMAIN.OPCODES ((DOMAIN.QUERY 0) (DOMAIN.IQUERY 1) (DOMAIN.CQUERYM 2) (DOMAIN.CQUERYU 3)))
(RPAQQ DOMAIN.QUERY 0)
(RPAQQ DOMAIN.IQUERY 1)
(RPAQQ DOMAIN.CQUERYM 2)
(RPAQQ DOMAIN.CQUERYU 3)
(CONSTANTS (DOMAIN.QUERY 0) (DOMAIN.IQUERY 1) (DOMAIN.CQUERYM 2) (DOMAIN.CQUERYU 3))
(RPAQQ DOMAIN.RCODES ((RCODE.OK 0) (RCODE.FORMATERROR 1) (RCODE.SERVERFAILED 2) (RCODE.NAMEERROR 3) (
RCODE.NOTIMPLEMENTED 4) (RCODE.REFUSED 5)))
(RPAQQ RCODE.OK 0)
(RPAQQ RCODE.FORMATERROR 1)
(RPAQQ RCODE.SERVERFAILED 2)
(RPAQQ RCODE.NAMEERROR 3)
(RPAQQ RCODE.NOTIMPLEMENTED 4)
(RPAQQ RCODE.REFUSED 5)
(CONSTANTS (RCODE.OK 0) (RCODE.FORMATERROR 1) (RCODE.SERVERFAILED 2) (RCODE.NAMEERROR 3) (
RCODE.NOTIMPLEMENTED 4) (RCODE.REFUSED 5))
(RPAQQ DOMAIN.RRTYPES ((RRTYPE.A 1) (RRTYPE.NS 2) (RRTYPE.MD 3) (RRTYPE.MF 4) (RRTYPE.CNAME 5) (
RRTYPE.SOA 6) (RRTYPE.MB 7) (RRTYPE.MG 8) (RRTYPE.MR 9) (RRTYPE.NULL 10) (RRTYPE.WKS 11) (RRTYPE.PTR 
12) (RRTYPE.HINFO 13) (RRTYPE.MINFO 14) (RRTYPE.MX 15)))
(RPAQQ RRTYPE.A 1)
(RPAQQ RRTYPE.NS 2)
(RPAQQ RRTYPE.MD 3)
(RPAQQ RRTYPE.MF 4)
(RPAQQ RRTYPE.CNAME 5)
(RPAQQ RRTYPE.SOA 6)
(RPAQQ RRTYPE.MB 7)
(RPAQQ RRTYPE.MG 8)
(RPAQQ RRTYPE.MR 9)
(RPAQQ RRTYPE.NULL 10)
(RPAQQ RRTYPE.WKS 11)
(RPAQQ RRTYPE.PTR 12)
(RPAQQ RRTYPE.HINFO 13)
(RPAQQ RRTYPE.MINFO 14)
(RPAQQ RRTYPE.MX 15)
(CONSTANTS (RRTYPE.A 1) (RRTYPE.NS 2) (RRTYPE.MD 3) (RRTYPE.MF 4) (RRTYPE.CNAME 5) (RRTYPE.SOA 6) (
RRTYPE.MB 7) (RRTYPE.MG 8) (RRTYPE.MR 9) (RRTYPE.NULL 10) (RRTYPE.WKS 11) (RRTYPE.PTR 12) (
RRTYPE.HINFO 13) (RRTYPE.MINFO 14) (RRTYPE.MX 15))
(RPAQQ DOMAIN.CLASSTYPES ((CLASSTYPE.IN 1) (CLASSTYPE.CSNET 2) (CLASSTYPE.CHAOS 3)))
(RPAQQ CLASSTYPE.IN 1)
(RPAQQ CLASSTYPE.CSNET 2)
(RPAQQ CLASSTYPE.CHAOS 3)
(CONSTANTS (CLASSTYPE.IN 1) (CLASSTYPE.CSNET 2) (CLASSTYPE.CHAOS 3))
(RPAQQ \DOMAIN.PORT 53)
(CONSTANTS (\DOMAIN.PORT 53))
(PUTPROP (QUOTE tcpdomain) (QUOTE IMPORTDATE) (IDATE "15-Feb-88 17:40:22"))

(PUTPROP (QUOTE tcpexports) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 17:23:47"))

(ACCESSFNS TCPDATASTREAM ((TCPCONTROLDEVICE (fetch (STREAM F3) of DATUM) (replace (STREAM F3) of DATUM
 with NEWVALUE)) (SEENEOS (fetch (STREAM F4) of DATUM) (replace (STREAM F4) of DATUM with NEWVALUE)) (
TCPFTPCON (fetch (STREAM F5) of DATUM) (replace (STREAM F5) of DATUM with NEWVALUE))))
(RECORD TCPFTPCON (TCPIN TCPOUT DATASTREAM BUSY? IDLETIMER GENERATEFILESDIRECTORY))
(PUTPROP (QUOTE TCPFTP) (QUOTE IMPORTDATE) (IDATE "11-Sep-89 15:22:47"))

(PUTPROP (QUOTE tcpftpsrv) (QUOTE IMPORTDATE) (IDATE "24-Aug-87 18:26:25"))

(PUTPROP (QUOTE TCPHTE) (QUOTE IMPORTDATE) (IDATE "24-May-88 17:06:10"))

(ACCESSFNS AR ((ARBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM)))) (BLOCKRECORD ARBASE ((
ARHARDWARESPACE WORD) (ARPROTOCOLSPACE WORD) (ARHARDWARELEN BYTE) (ARPROTOCOLLEN BYTE) (AROPCODE WORD)
 (AR1STWORD WORD)) (ACCESSFNS AR1STWORD ((ARCONTENTS (LOCF DATUM))))))
(ACCESSFNS ARETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM))) (BLOCKRECORD ARETHERBASE ((
ARLCLHDW0 WORD) (ARLCLHDW1 WORD) (ARLCLHDW2 WORD) (ARLCLPTCL FIXP) (ARFRNHDW0 WORD) (ARFRNHDW1 WORD) (
ARFRNHDW2 WORD) (ARFRNPTCL FIXP)) (ACCESSFNS ARLCLHDW0 ((ARSENDERHDW (\LOADNSHOSTNUMBER (LOCF DATUM)) 
(\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)))) (ACCESSFNS ARFRNHDW0 ((ARTARGETHDW (\LOADNSHOSTNUMBER (
LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE))))))
(ACCESSFNS AREXPETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM))) (BLOCKRECORD ARETHERBASE ((
ARLCLHDW WORD) (ARLCLPTCL FIXP) (ARFRNHDW WORD) (ARFRNPTCL FIXP))))
(DATATYPE ARENTRY ((RECENT FLAG) (SEARCHING FLAG) (IPADDRESS POINTER) (ETHERADDRESS POINTER) (TIMER 
POINTER)) TIMER _ (NCREATE (QUOTE FIXP)))
(RPAQQ \AR.HARDWARE.SPACE.ETHERNET 1)
(RPAQQ \AR.ETHERNET.ADDRESS.LENGTH 6)
(RPAQQ \AR.IP.ADDRESS.LENGTH 4)
(RPAQQ \AR.REQUEST 1)
(RPAQQ \AR.RESPONSE 2)
(RPAQQ \AR.ETHER.PACKET.LENGTH 28)
(CONSTANTS (\AR.HARDWARE.SPACE.ETHERNET 1) (\AR.ETHERNET.ADDRESS.LENGTH 6) (\AR.IP.ADDRESS.LENGTH 4) (
\AR.REQUEST 1) (\AR.RESPONSE 2) (\AR.ETHER.PACKET.LENGTH 28))
(PUTPROP (QUOTE TCPLLAR) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 15:50:14"))

(ACCESSFNS ICMPADMASK ((ICMPADMASKBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD 
ICMPADMASKBASE ((ICMPADMASKID WORD) (ICMPADMASKSEQNO WORD) (ICMPADMASKADMASK FIXP))))
(ACCESSFNS ICMP ((ICMPBASE (\IPDATABASE DATUM))) (BLOCKRECORD ICMPBASE ((ICMPTYPE BYTE) (ICMPCODE BYTE
) (ICMPCHECKSUM WORD) (ICMPDATASTART WORD))) (ACCESSFNS ICMP ((ICMPCONTENTS (LOCF (fetch (ICMP 
ICMPDATASTART) of DATUM))))))
(ACCESSFNS ICMPECHO ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPECHOBASE ((
ICMPECHOID WORD) (ICMPECHOSEQNO WORD) (ICMPECHODATA BYTE))))
(ACCESSFNS ICMPDESTUN ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPECHOBASE 
((NIL FIXP) (ICMPIPSTART WORD))) (ACCESSFNS ICMPDESTUN ((ICMPIPHEADER (LOCF (fetch (ICMPDESTUN 
ICMPIPSTART) of DATUM))))))
(ACCESSFNS ICMPREDIRECT ((ICMPREDIRECTBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD 
ICMPREDIRECTBASE ((ICMPGATEWAY FIXP) (ICMPIPSTART WORD))) (ACCESSFNS ICMPREDIRECT ((ICMPIPHEADER (LOCF
 (fetch (ICMPREDIRECT ICMPIPSTART) of DATUM))))))
(RPAQQ ICMPTYPES ((\ICMP.ECHO.REPLY 0) (\ICMP.DEST.UNREACHABLE 3) (\ICMP.SOURCE.QUENCH 4) (
\ICMP.REDIRECT 5) (\ICMP.ECHO 8) (\ICMP.TIME.EXCEEDED 11) (\ICMP.PARAMETER.PROBLEM 12) (
\ICMP.TIMESTAMP 13) (\ICMP.TIMESTAMP.REPLY 14) (\ICMP.INFO.REQUEST 15) (\ICMP.INFO.REPLY 16) (
\ICMP.ADDRESS.MASK.REQUEST 17) (\ICMP.ADDRESS.MASK.REPLY 18)))
(RPAQQ \ICMP.ECHO.REPLY 0)
(RPAQQ \ICMP.DEST.UNREACHABLE 3)
(RPAQQ \ICMP.SOURCE.QUENCH 4)
(RPAQQ \ICMP.REDIRECT 5)
(RPAQQ \ICMP.ECHO 8)
(RPAQQ \ICMP.TIME.EXCEEDED 11)
(RPAQQ \ICMP.PARAMETER.PROBLEM 12)
(RPAQQ \ICMP.TIMESTAMP 13)
(RPAQQ \ICMP.TIMESTAMP.REPLY 14)
(RPAQQ \ICMP.INFO.REQUEST 15)
(RPAQQ \ICMP.INFO.REPLY 16)
(RPAQQ \ICMP.ADDRESS.MASK.REQUEST 17)
(RPAQQ \ICMP.ADDRESS.MASK.REPLY 18)
(CONSTANTS (\ICMP.ECHO.REPLY 0) (\ICMP.DEST.UNREACHABLE 3) (\ICMP.SOURCE.QUENCH 4) (\ICMP.REDIRECT 5) 
(\ICMP.ECHO 8) (\ICMP.TIME.EXCEEDED 11) (\ICMP.PARAMETER.PROBLEM 12) (\ICMP.TIMESTAMP 13) (
\ICMP.TIMESTAMP.REPLY 14) (\ICMP.INFO.REQUEST 15) (\ICMP.INFO.REPLY 16) (\ICMP.ADDRESS.MASK.REQUEST 17
) (\ICMP.ADDRESS.MASK.REPLY 18))
(RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (
\ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5
)))
(RPAQQ \ICMP.NET.UNREACHABLE 0)
(RPAQQ \ICMP.HOST.UNREACHABLE 1)
(RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2)
(RPAQQ \ICMP.PORT.UNREACHABLE 3)
(RPAQQ \ICMP.CANT.FRAGMENT 4)
(RPAQQ \ICMP.SOURCE.ROUTE 5)
(CONSTANTS (\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) (
\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5))
(RPAQQ ICMPREDIRECTS ((\ICMP.REDIRECT.NET 0) (\ICMP.REDIRECT.HOST 1) (\ICMP.REDIRECT.SVC.AND.NET 2) (
\ICMP.REDIRECT.SVC.AND.HOST 3)))
(RPAQQ \ICMP.REDIRECT.NET 0)
(RPAQQ \ICMP.REDIRECT.HOST 1)
(RPAQQ \ICMP.REDIRECT.SVC.AND.NET 2)
(RPAQQ \ICMP.REDIRECT.SVC.AND.HOST 3)
(CONSTANTS (\ICMP.REDIRECT.NET 0) (\ICMP.REDIRECT.HOST 1) (\ICMP.REDIRECT.SVC.AND.NET 2) (
\ICMP.REDIRECT.SVC.AND.HOST 3))
(RPAQQ ICMPTIMEXS ((\ICMP.TRANSIT.TIME.EXCEEDED 0) (\ICMP.FRAGMENT.TIME.EXCEEDED 1)))
(RPAQQ \ICMP.TRANSIT.TIME.EXCEEDED 0)
(RPAQQ \ICMP.FRAGMENT.TIME.EXCEEDED 1)
(CONSTANTS (\ICMP.TRANSIT.TIME.EXCEEDED 0) (\ICMP.FRAGMENT.TIME.EXCEEDED 1))
(RPAQQ \ICMPOVLEN 4)
(CONSTANTS \ICMPOVLEN)
(RPAQQ \ICMP.PROTOCOL 1)
(CONSTANTS \ICMP.PROTOCOL)
(PUTPROPS ICMPLENGTH MACRO (LAMBDA (ICMP) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of ICMP) (LLSH (fetch
 (IP IPHEADERLENGTH) of ICMP) 2))))
(PUTPROP (QUOTE TCPLLICMP) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 16:28:51"))

(ACCESSFNS IP ((IPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM)))) (BLOCKRECORD IPBASE ((IPVERSION 
BITS 4) (* ; "Protocol version") (IPHEADERLENGTH BITS 4) (* ; "Head length, in cells") (IPSERVICE BYTE
) (* ; "Service type") (IPTOTALLENGTH WORD) (* ; "Packet length, in bytes") (IPID WORD) (* ; 
"Packet id") (NIL BITS 1) (IPDONTFRAGMENT FLAG) (* ; "Don't fragment me") (IPMOREFRAGMENTS FLAG) (* ; 
"Last fragment") (IPFRAGMENTOFFSET BITS 13) (* ; "Fragment position") (IPTIMETOLIVE BYTE) (* ; 
"Hop limiter") (IPPROTOCOL BYTE) (* ; "Client protocol") (IPHEADERCHECKSUM WORD) (* ; 
"Header-only checksum") (IPSOURCEADDRESS FIXP) (IPDESTINATIONADDRESS FIXP) (IPOPTIONSSTART BYTE) (* ; 
"Options or data start here")) (ACCESSFNS IPSERVICE ((IPSERVICEBASE (LOCF DATUM))) (BLOCKRECORD 
IPSERVICEBASE ((IPPRECEDENCE BITS 3) (IPDELAY FLAG) (IPTHROUGHPUT FLAG) (IPRELIABILITY FLAG) (NIL BITS
 2)))) (* ; 
"Replace is not supported on any of the following because there is ambiguity about the address class."
) (ACCESSFNS IPDESTINATIONADDRESS ((IPDESTBASE (LOCF DATUM))) (ACCESSFNS IPDESTBASE ((IPDESTINATIONNET
 (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSANET) of DATUM)) (
(EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBNET) of DATUM)) (T (* ; 
"Class C or error") (fetch (IPADDRESS CLASSCNET) of DATUM)))) (IPDESTINATIONHOST (COND ((EQ 
\IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSAHOST) of DATUM)) ((EQ 
\IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBHOST) of DATUM)) (T (* ; 
"Class C or error") (fetch (IPADDRESS CLASSCHOST) of DATUM))))))) (ACCESSFNS IPSOURCEADDRESS ((
IPSOURCEBASE (LOCF DATUM))) (ACCESSFNS IPSOURCEBASE ((IPSOURCENET (COND ((EQ \IP.CLASS.A (fetch (
IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSANET) of DATUM)) ((EQ \IP.CLASS.B (fetch (
IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBNET) of DATUM)) (T (fetch (IPADDRESS CLASSCNET) 
of DATUM)))) (IPSOURCEHOST (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (
IPADDRESS CLASSAHOST) of DATUM)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (
IPADDRESS CLASSBHOST) of DATUM)) (T (fetch (IPADDRESS CLASSCHOST) of DATUM)))))))) (TYPE? (type? 
ETHERPACKET DATUM)))
(DATATYPE IPSOCKET ((PROTOCOL BYTE) (IPSLINK POINTER) (* ; "Other sockets of this protocol type") (NIL
 BYTE) (IPSQUEUE POINTER) (* ; "Queue of packets for this protocol") (IPSQUEUELENGTH WORD) (* ; 
"Count of packets of input queue") (IPSQUEUEALLOC WORD) (* ; "Max count allowed") (
IPSDESTSOCKETCOMPAREFN POINTER) (* ; "Call this to compare dest protocol socket to this socket") (
IPSOCKET POINTER) (* ; "This socket") (IPSINPUTFN POINTER) (* ; "Call to hand packet to protocol") (
IPSEVENT POINTER) (* ; "Notify me when a packet arrives") (IPSNOSOCKETFN POINTER) (* ; 
"Call this when no socket found") (IPSICMPFN POINTER) (* ; 
"Call this when an ICMP packet is received on this protocol")) IPSQUEUE _ (create SYSQUEUE) 
IPSQUEUEALLOC _ \IP.MAX.EPKTS.ON.QUEUE IPSEVENT _ (CREATE.EVENT) IPSINPUTFN _ (FUNCTION 
\IP.DEFAULT.INPUTFN) IPSICMPFN _ (FUNCTION \RELEASE.ETHERPACKET))
(BLOCKRECORD IPADDRESS ((ADDRESS FIXP)) (* ;; "Class A nets: high bit is 0") (BLOCKRECORD IPADDRESS ((
CLASSA BITS 1) (CLASSANET BITS 7) (CLASSAHOST BITS 24))) (* ;; "Class B nets: high 2 bits are 10") (
BLOCKRECORD IPADDRESS ((CLASSB BITS 2))) (BLOCKRECORD IPADDRESS ((CLASSBNET BITS 16) (CLASSBHOST BITS 
16))) (* ;; "Class C nets: high 3 bits are 110") (BLOCKRECORD IPADDRESS ((CLASSC BITS 3))) (
BLOCKRECORD IPADDRESS ((CLASSCNETB1 BITS 8) (CLASSCNETB2 BITS 8) (CLASSCNETB3 BITS 8) (CLASSCHOST BITS
 8))) (* ; "I wish I could say just net bits 24, host bits 8, but BLOCKRECORD barfs") (BLOCKRECORD 
IPADDRESS ((CLASSCNETHI BITS 16))) (ACCESSFNS IPADDRESS ((CLASSCNET (\MAKENUMBER (FETCH CLASSCNETB1 OF
 DATUM) (LOGOR (LLSH (FETCH CLASSCNETB2 OF DATUM) 8) (FETCH CLASSCNETB3 OF DATUM))) (PROGN (REPLACE 
CLASSCNETHI OF DATUM WITH (LRSH NEWVALUE 8)) (REPLACE CLASSCNETB3 OF DATUM WITH (LOGAND NEWVALUE 255))
 DATUM)))))
(RPAQQ \IPOVLEN 20)
(RPAQQ \MAX.IPDATALENGTH 556)
(RPAQQ \IP.PROTOCOLVERSION 4)
(RPAQQ \IP.MAX.EPKTS.ON.QUEUE 16)
(RPAQQ \IP.DEFAULT.TIME.TO.LIVE 120)
(RPAQQ \IP.WAKEUP.INTERVAL 15000)
(CONSTANTS \IPOVLEN \MAX.IPDATALENGTH \IP.PROTOCOLVERSION \IP.MAX.EPKTS.ON.QUEUE 
\IP.DEFAULT.TIME.TO.LIVE \IP.WAKEUP.INTERVAL)
(RPAQQ IPPACKETTYPES ((\EPT.IP 2048) (\EPT.AR 2054) (\EET.IP 513) (\EPT.CHAOS 2052)))
(RPAQQ \EPT.IP 2048)
(RPAQQ \EPT.AR 2054)
(RPAQQ \EET.IP 513)
(RPAQQ \EPT.CHAOS 2052)
(CONSTANTS (\EPT.IP 2048) (\EPT.AR 2054) (\EET.IP 513) (\EPT.CHAOS 2052))
(RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (
\ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5
)))
(RPAQQ \ICMP.NET.UNREACHABLE 0)
(RPAQQ \ICMP.HOST.UNREACHABLE 1)
(RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2)
(RPAQQ \ICMP.PORT.UNREACHABLE 3)
(RPAQQ \ICMP.CANT.FRAGMENT 4)
(RPAQQ \ICMP.SOURCE.ROUTE 5)
(CONSTANTS (\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) (
\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5))
(PUTPROPS \IPDATABASE MACRO (LAMBDA (IP) (* ; 
"Returns the LOCF of the start of the data in the packet") (\ADDBASE (fetch (IP IPBASE) of IP) (UNFOLD
 (fetch (IP IPHEADERLENGTH) of IP) 2))))
(PUTPROPS \IPDATALENGTH MACRO (LAMBDA (IP) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of IP) (LLSH (fetch 
(IP IPHEADERLENGTH) of IP) 2))))
(RPAQQ IPADDRESSTYPES ((\IP.CLASS.A 0) (\IP.CLASS.A.BYTESPEC (BYTE 1 31)) (\IP.CLASS.A.NET.BYTESPEC (
BYTE 8 24)) (\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (\IP.CLASS.B 2) (\IP.CLASS.B.BYTESPEC (BYTE 2 30))
 (\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (\IP.CLASS.C 6) (
\IP.CLASS.C.BYTESPEC (BYTE 3 29)) (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (\IP.CLASS.C.HOST.BYTESPEC (
BYTE 8 0))))
(RPAQQ \IP.CLASS.A 0)
(RPAQ \IP.CLASS.A.BYTESPEC (BYTE 1 31))
(RPAQ \IP.CLASS.A.NET.BYTESPEC (BYTE 8 24))
(RPAQ \IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0))
(RPAQQ \IP.CLASS.B 2)
(RPAQ \IP.CLASS.B.BYTESPEC (BYTE 2 30))
(RPAQ \IP.CLASS.B.NET.BYTESPEC (BYTE 16 16))
(RPAQ \IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0))
(RPAQQ \IP.CLASS.C 6)
(RPAQ \IP.CLASS.C.BYTESPEC (BYTE 3 29))
(RPAQ \IP.CLASS.C.NET.BYTESPEC (BYTE 24 8))
(RPAQ \IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0))
(CONSTANTS (\IP.CLASS.A 0) (\IP.CLASS.A.BYTESPEC (BYTE 1 31)) (\IP.CLASS.A.NET.BYTESPEC (BYTE 8 24)) (
\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (\IP.CLASS.B 2) (\IP.CLASS.B.BYTESPEC (BYTE 2 30)) (
\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (\IP.CLASS.C 6) (
\IP.CLASS.C.BYTESPEC (BYTE 3 29)) (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (\IP.CLASS.C.HOST.BYTESPEC (
BYTE 8 0)))
(RPAQQ IPPROTOCOLTYPES ((\ICMP.PROTOCOL 1) (\TCP.PROTOCOL 6) (\UDP.PROTOCOL 17)))
(RPAQQ \ICMP.PROTOCOL 1)
(RPAQQ \TCP.PROTOCOL 6)
(RPAQQ \UDP.PROTOCOL 17)
(CONSTANTS (\ICMP.PROTOCOL 1) (\TCP.PROTOCOL 6) (\UDP.PROTOCOL 17))
(RECORD AssemblyRecord (Packet FirstHole Fragments Timeout) Packet _ (\ALLOCATE.ETHERPACKET) FirstHole
 _ 0)
(RECORD FragmentRecord (Start Length LastFragment))
(RECORD FragmentID (AssemblyRecord SourceAddress ID Protocol . DestinationAddress))
(RPAQQ IPOPTIONTYPES ((IPOPT.END 0) (IPOPT.NOP 1) (IPOPT.SECURITY 2) (IPOPT.LSRR 3) (IPOPT.TIMESTAMP 4
) (IPOPT.RECRT 7) (IPOPT.STREAMID 8) (IPOPT.SSSR 9)))
(RPAQQ IPOPT.END 0)
(RPAQQ IPOPT.NOP 1)
(RPAQQ IPOPT.SECURITY 2)
(RPAQQ IPOPT.LSRR 3)
(RPAQQ IPOPT.TIMESTAMP 4)
(RPAQQ IPOPT.RECRT 7)
(RPAQQ IPOPT.STREAMID 8)
(RPAQQ IPOPT.SSSR 9)
(CONSTANTS (IPOPT.END 0) (IPOPT.NOP 1) (IPOPT.SECURITY 2) (IPOPT.LSRR 3) (IPOPT.TIMESTAMP 4) (
IPOPT.RECRT 7) (IPOPT.STREAMID 8) (IPOPT.SSSR 9))
(RPAQ IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0))
(CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0)))
(PUTPROPS \IP.GET.BYTE DMACRO (LAMBDA (IP BYTE INHEADER) (* ;; 
"Retrieve a byte from an IP packet.  If INHEADER is T, BYTE is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\GETBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE)))
(PUTPROPS \IP.GET.CELL DMACRO (LAMBDA (IP CELL INHEADER) (* ;; 
"Retrieve a cell from an IP packet.  If INHEADER is not NIL, the cell is written to the header portion of the IP packet, else it's written to the data portion.  CELL is the offset, in 16-bit units"
) (\GETBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL)))
(PUTPROPS \IP.GET.STRING DMACRO (LAMBDA (IP BYTEOFFSET NCHARS INHEADER) (* ;; 
"Retrieve a string from an IP packet.  If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\GETBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET NCHARS))
)
(PUTPROPS \IP.GET.WORD DMACRO (LAMBDA (IP WORD INHEADER) (* ;; 
"Retrieve a word from an IP packet.  If INHEADER is T, WORD is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\GETBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD)))
(PUTPROPS \IP.PUT.BYTE DMACRO (LAMBDA (IP BYTE VALUE INHEADER) (* ;; 
"Store a byte in an IP packet.  If INHEADER is T, BYTE is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\PUTBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE VALUE)))
(PUTPROPS \IP.PUT.CELL DMACRO (LAMBDA (IP CELL VALUE INHEADER) (* ;; 
"Store a cell in an IP packet.  If INHEADER is not NIL, the cell is written to the header portion of the IP packet, else it's written to the data portion.  CELL is the offset, in 16-bit units"
) (\PUTBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL VALUE)))
(PUTPROPS \IP.PUT.STRING DMACRO (LAMBDA (IP BYTEOFFSET STRING INHEADER) (* ;; 
"Store a string ib an IP packet.  If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\PUTBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET STRING))
)
(PUTPROPS \IP.PUT.WORD DMACRO (LAMBDA (IP WORD VALUE INHEADER) (* ;; 
"Store a word in an IP packet.  If INHEADER is T, WORD is an offset from the start of the packet, else it's an offset from the start of the IP data section"
) (\PUTBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD VALUE)))
(PUTPROP (QUOTE TCPLLIP) (QUOTE IMPORTDATE) (IDATE "11-Sep-89 15:24:32"))

(PUTPROP (QUOTE TCPNAMES) (QUOTE IMPORTDATE) (IDATE " 2-Jun-88 20:58:40"))

(RECORD TFTPCON (UDPSOCKET DESTSOCKET STREAM HOST))
(ACCESSFNS TFTP ((TFTPBASE (fetch (UDP UDPCONTENTS) of DATUM))) (BLOCKRECORD TFTPBASE ((OPCODE WORD) (
BLOCK# WORD))) (ACCESSFNS TFTP ((TFTPCONTENTS (\ADDBASE (fetch (UDP UDPCONTENTS) of DATUM) (FOLDHI 
\TFTPOVLEN BYTESPERWORD))))) (BLOCKRECORD TFTPBASE ((NIL WORD) (ERRORCODE WORD))))
(ACCESSFNS TFTPSTREAM ((TFTPCON (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with 
NEWVALUE)) (LASTPACKETIN (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE))))
(RPAQQ \TFTPOVLEN 4)
(RPAQQ \TFTP.SOCKET 69)
(CONSTANTS (\TFTPOVLEN 4) (\TFTP.SOCKET 69))
(RPAQQ TFTPOPCODES ((\TFTP.RRQ 1) (\TFTP.WRQ 2) (\TFTP.DATA 3) (\TFTP.ACK 4) (\TFTP.ERROR 5)))
(RPAQQ \TFTP.RRQ 1)
(RPAQQ \TFTP.WRQ 2)
(RPAQQ \TFTP.DATA 3)
(RPAQQ \TFTP.ACK 4)
(RPAQQ \TFTP.ERROR 5)
(CONSTANTS (\TFTP.RRQ 1) (\TFTP.WRQ 2) (\TFTP.DATA 3) (\TFTP.ACK 4) (\TFTP.ERROR 5))
(PUTPROP (QUOTE TCPTFTP) (QUOTE IMPORTDATE) (IDATE " 1-Jul-87 10:54:35"))

(ACCESSFNS UDP ((UDPBASE (\IPDATABASE DATUM))) (BLOCKRECORD UDPBASE ((UDPSOURCEPORT WORD) (UDPDESTPORT
 WORD) (UDPLENGTH WORD) (UDPCHECKSUM WORD))) (ACCESSFNS UDP ((UDPCONTENTS (\ADDBASE (\IPDATABASE DATUM
) (FOLDHI \UDPOVLEN BYTESPERWORD))))))
(RPAQQ \UDPOVLEN 8)
(CONSTANTS (\UDPOVLEN 8))
(PUTPROP (QUOTE TCPUDP) (QUOTE IMPORTDATE) (IDATE " 6-Jan-89 16:37:41"))

(PUTPROP (QUOTE TCPEXPORTS) (QUOTE FILEDATES) (QUOTE (("11-Sep-89 16:22:57" . "{ERIS}<LispCore>Library>TCPEXPORTS.;8"))))

STOP

\ No newline at end of file
diff --git a/obsolete/tcp/TCPFTP b/obsolete/tcp/TCPFTP
deleted file mode 100644
index 519099e2..00000000
--- a/obsolete/tcp/TCPFTP
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jun-90 16:23:19" {DSK}<usr>local>lde>lispcore>library>TCPFTP.;3 50122  

      changes to%:  (VARS TCPFTPCOMS)

      previous date%: "20-Jun-89 19:47:44" {DSK}<usr>local>lde>lispcore>library>TCPFTP.;2)


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

(PRETTYCOMPRINT TCPFTPCOMS)

(RPAQQ TCPFTPCOMS
       [[COMS 
              (* ;; "FNS from Larry's Interlisp-10 LISPUSERS package")

              (FNS ARPACMD FTPHELP CMDREADCODE CMDREAD DISCARDLINE GETLINE \TCPFTP.INPUT TELNET.EOL)
              (INITVARS (\TCPFTP.ARPACMD.LOCK (CREATE.MONITORLOCK "ARPACMD Lock")))
              (GLOBALVARS \TCPFTP.ARPACMD.LOCK)
              (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                                   (NLAML)
                                                                                   (LAMA FTPHELP]
        (COMS 
              (* ;; "FNS for the Interlisp-D streams facility")

              (FNS \TCPFTP.CONTROL.CLOSED \TCPFTP.GET.OSTYPE \TCPFTP.EVENTFN \TCPFTP.HOSTNAMEP 
                   \GET.TCPFTP.CONNECTION \TCPFTP.OPEN.CONNECTION \TCPFTP.ASSURE.CLEANUP 
                   \TCPFTP.CLEANUP \TCPFTP.RELEASE.CONNECTION \TCPFTP.LOGIN \TCPFTP.DELETEFILE 
                   \TCPFTP.DIRECTORYNAMEP \TCPFTP.ENDOFSTREAMOP \TCPFTP.GENERATEFILES 
                   \TCPFTP.GENERATENEXTFILE \TCPFTP.GETFILENAME \TCPFTP.GETFILEINFO 
                   \TCPFTP.SETFILEINFO \TCPFTP.RENAMEFILE \TCPFTP.CONNECT \TCPFTP.OPENFILE 
                   \TCPFTP.CLOSE \TCPFTP.FLUSH \TCPFTP.INIT SET.TCP.EOL.CONVENTION)
              (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS TCPDATASTREAM TCPFTPCON)))
              (ADDVARS (TCPFTP.DEFAULT.FILETYPES (NIL . TEXT)
                              (DFASL . BINARY)
                              (dfasl . BINARY)
                              (LCOM . BINARY)
                              (lcom . BINARY)
                              (DCOM . BINARY)
                              (dcom . BINARY)
                              (LISP . TEXT)
                              (lisp . TEXT)
                              (LSP . TEXT)
                              (lsp . TEXT)
                              (RST . BINARY)
                              (rst . BINARY)
                              (BIN . BINARY)
                              (bin . BINARY)))
              (INITVARS (TCP.DEFAULTFILETYPE 'BINARY)
                     (TCP.USE.STANDARD.EOL T)
                     (\TCPFTP.DEVICES)
                     (\TCPFTP.CLEANUP.PROCESS))
              (GLOBALVARS \TCPFTP.DEVICES \TCPFTP.CLEANUP.PROCESS TCP.DEFAULTFILETYPE 
                     TCP.USE.STANDARD.EOL))
        (COMS 
              (* ;; "Data connection handling")

              (FNS \TCP.BYE \TCPFTP.MAYBE.ABORT \TCPFTP.DATA.CLOSED \TCPFTP.OPEN.DATA.CONNECTION 
                   \TCPFTP.PORT.STRING \TCPFTP.SPAWN.DATACONNECTION \TCPFTP.READ.UNTIL.EOF 
                   \TCPFTP.TRANSFER.COMPLETE \TCPFTP.WAIT.FOR.DATACONNECTION 
                   \TCPFTP.DELETE.CONNECTION)
              (INITVARS (\TCPFTP.DATACONNECTION.LOCK (CREATE.MONITORLOCK 
                                                            "TCPFTP Data Connection Lock"))
                     (\TCPFTP.CONNECTION.LOCK (CREATE.MONITORLOCK "TCPFTP Connection Lock"))
                     (\TCPFTP.IDLE.TIMEOUT (TIMES 10 60 1000)))
              (GLOBALVARS \TCPFTP.DATACONNECTION.LOCK \TCPFTP.CONNECTION.LOCK \TCPFTP.IDLE.TIMEOUT))
        (FILES (SYSLOAD)
               TCPNAMES TCP)
        (P (\TCPFTP.INIT))
        (VARS TCPFTP.DEFAULT.FILETYPES)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA])



(* ;; "FNS from Larry's Interlisp-10 LISPUSERS package")

(DEFINEQ

(ARPACMD
(LAMBDA (TCPFTPCON CMD ARG WANT DISCARD WANTARG) (* ejs%: "15-Nov-86 15:09") (* lmm "16-OCT-78 02:57") (DECLARE (GLOBALVARS \TCPFTP.ARPACMD.LOCK)) (WITH.MONITOR \TCPFTP.ARPACMD.LOCK (LET ((INC (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (OUTC (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (RESETLST (RESETSAVE NIL (BQUOTE (COND (RESETSTATE (AND (OPENP %, INC (QUOTE INPUT)) (CLOSEF %, INC)) (AND (OPENP %, OUTC (QUOTE OUTPUT)) (CLOSEF %, OUTC)))))) (PROG NIL (COND (CMD (COND (FTPDEBUGFLG (printout FTPDEBUGLOG CMD) (COND (ARG (printout FTPDEBUGLOG " " ARG))))) (PRIN3 CMD OUTC) (COND (ARG (PRIN3 " " OUTC) (PRIN3 ARG OUTC))) (TELNET.EOL OUTC) (FORCEOUTPUT OUTC) (* flush) (COND (FTPDEBUGFLG (TERPRI FTPDEBUGLOG))))) LP (COND (FTPDEBUGFLG (printout FTPDEBUGLOG "< "))) (SETQ CMD (\TCPFTP.INPUT INC)) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG CMD " "))) (COND ((EQMEMB CMD WANTARG) (AND (EQ (BIN INC) (CHARCODE -)) (FTPHELP CMD)) (RETURN CMD))) (COND ((EQ (BIN INC) (CHARCODE -)) (do (DISCARDLINE INC) repeatuntil (EQ (\TCPFTP.INPUT INC) CMD)))) (COND ((EQMEMB CMD WANT) (DISCARDLINE INC) (RETURN CMD)) ((EQMEMB CMD DISCARD) (DISCARDLINE INC) (GO LP))) (SELECTQ (AND (FIXP CMD) (IQUOTIENT CMD 100)) ((2 3) (FTPHELP CMD)) ((4 5) (ERROR (GETLINE INC T))) NIL) (DISCARDLINE INC) (GO LP))))))
)

(FTPHELP
(LAMBDA (ARG) (* ejs%: "29-Jan-85 17:02") (ERROR ARG " unrecognized response from remote FTP server"))
)

(CMDREADCODE
(LAMBDA (IN) (* lmm "31-MAY-78 00:45") (PACK* (CMDREAD IN) (CMDREAD IN) (CMDREAD IN))))

(CMDREAD
(LAMBDA (IN) (* ejs%: "12-Jan-85 14:28") ((LAMBDA (CH) (COND (FTPDEBUGFLG (BOUT CH FTPDEBUGLOG))) CH) (BIN IN)))
)

(DISCARDLINE
(LAMBDA (IN) (* ejs%: " 3-Feb-86 16:16") (* lmm "31-MAY-78 00:45") (DECLARE (GLOBALVARS FTPDEBUGFLG FTPDEBUGLOG)) (COND (FTPDEBUGFLG (\BACKFILEPTR IN) (bind CH until (FMEMB (SETQ CH (BIN IN)) (CONSTANT (LIST (CHARCODE LF) (CHARCODE NULL)))) do (BOUT FTPDEBUGLOG CH) finally (TERPRI FTPDEBUGLOG))) (T (until (FMEMB (BIN IN) (CONSTANT (LIST (CHARCODE LF) (CHARCODE NULL))))))))
)

(GETLINE
(LAMBDA (IN FLG) (* ejs%: "12-Jan-85 14:40") (* lmm "31-MAY-78 00:46") (bind CH (STRING _ (ALLOCSTRING 80)) for POS from 1 while (NEQ (SETQ CH (BIN IN)) (CHARCODE LF)) do (COND ((LEQ POS 80) (RPLCHARCODE STRING POS CH))) finally (RETURN (SUBSTRING STRING 1 (SUB1 POS)))))
)

(\TCPFTP.INPUT
(LAMBDA (STREAM) (* ; "Edited 17-Nov-88 15:16 by cdl") (DECLARE (GLOBALVARS FTPDEBUGFLG FTPDEBUGLOG)) (LET (CCODE (RESULT 0)) (to 3 do (SETQ CCODE (BIN STREAM)) (if (AND (GEQ CCODE (CHARCODE 0)) (LEQ CCODE (CHARCODE 9))) then (SETQ RESULT (PLUS (TIMES RESULT 10) (DIFFERENCE CCODE (CHARCODE 0))))) repeatuntil (OR (EQ CCODE (CHARCODE SPACE)) (EQ CCODE (CHARCODE -)) (EQ CCODE 0)) finally (if (EQ CCODE (CHARCODE -)) then (if FTPDEBUGFLG then (printout FTPDEBUGLOG T "< " RESULT)) (DISCARDLINE STREAM) (\TCPFTP.INPUT STREAM))) RESULT))
)

(TELNET.EOL
(LAMBDA (STREAM) (* ejs%: " 5-Jan-85 18:44") (BOUT STREAM (CHARCODE CR)) (BOUT STREAM (CHARCODE LF)) (FORCEOUTPUT STREAM))
)
)

(RPAQ? \TCPFTP.ARPACMD.LOCK (CREATE.MONITORLOCK "ARPACMD Lock"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCPFTP.ARPACMD.LOCK)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FTPHELP)
)



(* ;; "FNS for the Interlisp-D streams facility")

(DEFINEQ

(\TCPFTP.CONTROL.CLOSED
(LAMBDA (INSTREAM OUTSTREAM) (* ejs%: "28-Jul-86 14:30") (LET* ((DEVICE (fetch (STREAM DEVICE) of INSTREAM)) (TCPFTPCON (for CONN in (fetch (FDEV DEVICEINFO) of DEVICE) thereis (EQ (fetch (TCPFTPCON TCPIN) of CONN) INSTREAM)))) (COND (TCPFTPCON (replace (STREAM ACCESS) of INSTREAM with (replace (STREAM ACCESS) of OUTSTREAM with NIL)) (replace (FDEV DEVICEINFO) of DEVICE with (DREMOVE TCPFTPCON (fetch (FDEV DEVICEINFO) of DEVICE)))))))
)

(\TCPFTP.GET.OSTYPE
  [LAMBDA (DEVICE)                                       (* ; "Edited 12-May-89 14:10 by welch")
    (LET* ((HOST (fetch (FDEV DEVICENAME) of DEVICE))
           ENTRY)
          (GETHOSTINFO HOST 'OSTYPE])

(\TCPFTP.EVENTFN
(LAMBDA (FDEV FLG) (* ejs%: "23-Apr-85 18:56") (* * Called when a major event happens) (SELECTQ FLG ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS) (bind TCPIN TCPOUT DATASTREAM for TCPFTPCON in (fetch (FDEV DEVICEINFO) of FDEV) do (SETQ TCPIN (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (SETQ TCPOUT (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (SETQ DATASTREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON)) (COND ((OPENP TCPIN (QUOTE INPUT)) (CLOSEF TCPIN))) (COND ((OPENP TCPOUT (QUOTE OUTPUT)) (CLOSEF TCPOUT))) (COND ((OPENP DATASTREAM) (CLOSEF DATASTREAM))))) NIL))
)

(\TCPFTP.HOSTNAMEP
  [LAMBDA (HOST DEVICE)                                  (* ejs%: "24-Mar-86 14:36")
    (DECLARE (GLOBALVARS \TCP.DEVICE \TCPFTP.DEVICES))
    (PROG ((SERVER (OR (DODIP.HOSTP HOST)
                       (\IP.READ.STRING.ADDRESS HOST)))
           FULLHOSTNAME FILINGNAME)
          (RETURN (COND
                     ((NOT SERVER)
                      NIL)
                     ((\GETDEVICEFROMNAME (SETQ FULLHOSTNAME (MKATOM (U-CASE HOST)))
                             T T))
                     (T (SETQ FILINGNAME (PACK* HOST " Filing"))
                        (\DEFINEDEVICE FULLHOSTNAME (SETQ DEVICE
                                                     (create FDEV
                                                        using \TCP.DEVICE DEVICENAME _ 
                                                              FULLHOSTNAME OPENFILE _
                                                              (FUNCTION \TCPFTP.OPENFILE)
                                                              RENAMEFILE _ (FUNCTION 
                                                                            \TCPFTP.RENAMEFILE)
                                                              REOPENFILE _ (FUNCTION NILL)
                                                              GETFILEINFO _ (FUNCTION 
                                                                             \TCPFTP.GETFILEINFO)
                                                              SETFILEINFO _ (FUNCTION 
                                                                             \TCPFTP.SETFILEINFO)
                                                              GETEOFPTR _ (FUNCTION \TCPFTP.GETEOFPTR
                                                                           )
                                                              DELETEFILE _ (FUNCTION 
                                                                            \TCPFTP.DELETEFILE)
                                                              HOSTNAMEP _ (FUNCTION NILL)
                                                              GETFILENAME _ (FUNCTION 
                                                                             \TCPFTP.GETFILENAME)
                                                              DIRECTORYNAMEP _ (FUNCTION 
                                                                               \TCPFTP.DIRECTORYNAMEP
                                                                                )
                                                              GENERATEFILES _ (FUNCTION 
                                                                               \TCPFTP.GENERATEFILES)
                                                              EVENTFN _ (FUNCTION NILL)
                                                              DEVICEINFO _ NIL)))
                        (push \TCPFTP.DEVICES DEVICE)
                        DEVICE])

(\GET.TCPFTP.CONNECTION
(LAMBDA (DEVICE) (* ejs%: " 4-Jun-85 17:54") (LET ((CONNECTIONS (fetch (FDEV DEVICEINFO) of DEVICE)) TCPFTPCON INSTREAM OUTSTREAM) (WITH.MONITOR \TCPFTP.CONNECTION.LOCK (COND ((SETQ TCPFTPCON (for TCPFTPCON in CONNECTIONS thereis (NULL (fetch (TCPFTPCON BUSY?) of TCPFTPCON)))) (COND ((AND (SETQ INSTREAM (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (SETQ OUTSTREAM (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (OPENP INSTREAM (QUOTE INPUT)) (OPENP OUTSTREAM (QUOTE OUTPUT)) (NOT (EOFP INSTREAM))) (while (READP INSTREAM) do (BIN INSTREAM)) (replace (TCPFTPCON BUSY?) of TCPFTPCON with T) TCPFTPCON) (T (\TCPFTP.DELETE.CONNECTION TCPFTPCON DEVICE) (\TCPFTP.OPEN.CONNECTION DEVICE)))) (T (\TCPFTP.OPEN.CONNECTION DEVICE))))))
)

(\TCPFTP.OPEN.CONNECTION
(LAMBDA (DEVICE) (* ; "Edited 24-Apr-87 16:09 by FS") (LET* ((HOST (DODIP.HOSTP (fetch (FDEV DEVICENAME) of DEVICE))) (TCPFTPCON (create TCPFTPCON BUSY? _ T)) (INSTREAM (TCP.OPEN HOST \TCP.FTP.PORT NIL (QUOTE ACTIVE) (QUOTE INPUT) NIL (QUOTE (WHENCLOSEDFN \TCPFTP.CONTROL.CLOSED)))) (OUTSTREAM (COND (INSTREAM (TCP.OTHER.STREAM INSTREAM))))) (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (CON DEV) (COND (RESETSTATE (COND ((AND (EQ (\TCPFTP.GET.OSTYPE DEV) (QUOTE UNIX)) (READP (fetch (TCPFTPCON TCPIN) of CON))) (\TCPFTP.INPUT (fetch (TCPFTPCON TCPIN) of CON)))) (ARPACMD CON "QUIT" NIL (QUOTE (221 500))) (\TCPFTP.DELETE.CONNECTION CON DEV))))) TCPFTPCON DEVICE)) (COND (INSTREAM (replace (STREAM ENDOFSTREAMOP) of INSTREAM with (FUNCTION (LAMBDA (STREAM) (ZERO)))) (replace (STREAM DEVICE) of INSTREAM with DEVICE) (replace (STREAM DEVICE) of OUTSTREAM with DEVICE) (replace (TCPFTPCON TCPIN) of TCPFTPCON with INSTREAM) (replace (TCPFTPCON TCPOUT) of TCPFTPCON with OUTSTREAM) (SELECTQ (\TCPFTP.INPUT INSTREAM) (220 (COND (FTPDEBUGFLG (printout FTPDEBUGLOG T "< 220 ") (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)))) (\TCPFTP.LOGIN DEVICE TCPFTPCON) (push (fetch (FDEV DEVICEINFO) of DEVICE) TCPFTPCON) TCPFTPCON) (PROGN (\TCPFTP.DELETE.CONNECTION TCPFTPCON DEVICE) NIL)))))))
)

(\TCPFTP.ASSURE.CLEANUP
(LAMBDA NIL (* ejs%: "27-Apr-85 14:08") (* * Spawn a cleanup function if necessary) (COND ((AND (PROCESSP \TCPFTP.CLEANUP.PROCESS) (NOT (PROCESS.FINISHEDP \TCPFTP.CLEANUP.PROCESS)))) (T (SETQ \TCPFTP.CLEANUP.PROCESS (ADD.PROCESS (QUOTE (\TCPFTP.CLEANUP)) (QUOTE RESTARTABLE) (QUOTE NO))))))
)

(\TCPFTP.CLEANUP
(LAMBDA NIL (* ejs%: "28-Jul-86 12:26") (DECLARE (GLOBALVARS \TCPFTP.IDLE.TIMEOUT \TCPFTP.DEVICES \TCPFTP.CONNECTION.LOCK)) (LET ((INTERVAL (QUOTIENT \TCPFTP.IDLE.TIMEOUT 4)) CONNECTIONSP) (repeatwhile (NOT (ZEROP CONNECTIONSP)) do (SETQ CONNECTIONSP 0) (for DEVICE in \TCPFTP.DEVICES do (for CONNECTION in (APPEND (fetch (FDEV DEVICEINFO) of DEVICE)) do (add CONNECTIONSP 1) (WITH.MONITOR \TCPFTP.CONNECTION.LOCK (NLSETQ (COND ((AND (NULL (fetch (TCPFTPCON BUSY?) of CONNECTION)) (TIMEREXPIRED? (fetch (TCPFTPCON IDLETIMER) of CONNECTION))) (CLOSEF? (fetch (TCPFTPCON TCPIN) of CONNECTION)) (CLOSEF? (fetch (TCPFTPCON TCPOUT) of CONNECTION)) (COND ((fetch (TCPFTPCON DATASTREAM) of CONNECTION) (CLOSEF? (fetch (TCPFTPCON DATASTREAM) of CONNECTION)))) (add CONNECTIONSP -1) (\TCPFTP.DELETE.CONNECTION CONNECTION DEVICE T)) ((OR (NOT (OPENP (fetch (TCPFTPCON TCPIN) of CONNECTION) (QUOTE INPUT))) (NEQ (QUOTE ESTABLISHED) (fetch (TCP.CONTROL.BLOCK TCB.STATE) of (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN) of CONNECTION))))) (add CONNECTIONSP -1) (\TCPFTP.DELETE.CONNECTION CONNECTION DEVICE))))) (BLOCK))) (COND ((NOT (ZEROP CONNECTIONSP)) (BLOCK INTERVAL))))))
)

(\TCPFTP.RELEASE.CONNECTION
(LAMBDA (TCPFTPCON) (* jmh "11-Oct-85 13:43") (COND (TCPFTPCON (replace (TCPFTPCON BUSY?) of TCPFTPCON with NIL) (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with NIL) (replace (TCPFTPCON IDLETIMER) of TCPFTPCON with (SETUPTIMER \TCPFTP.IDLE.TIMEOUT)) (\TCPFTP.ASSURE.CLEANUP))))
)

(\TCPFTP.LOGIN
(LAMBDA (DEVICE TCPFTPCON) (* ; "Edited 24-Apr-87 16:17 by FS") (* * Log us in) (PROG ((OSTYPE (\TCPFTP.GET.OSTYPE DEVICE)) (HOST (fetch (FDEV DEVICENAME) of DEVICE)) (LOGINRETRYCOUNT 0) INFO) RETRY (SETQ INFO (\INTERNAL/GETPASSWORD HOST)) (* * Loop through this label if the server rejected the our name) (COND ((OR (NULL INFO) (EQ 0 (NCHARS (CAR INFO))) (EQ 0 (NCHARS (CDR INFO)))) (* Need to login. Can't send Unix hosts a string of no chars as name or password!) (LOGIN HOST) (GO RETRY))) RETRY1 (* * Loop through this label if the server rejected something else) (SELECTQ (ARPACMD TCPFTPCON "USER" (COND ((AND (EQ OSTYPE (QUOTE UNIX)) (EQ (CAR INFO) (U-CASE (CAR INFO))) (EQ LOGINRETRYCOUNT 0)) (L-CASE (CAR INFO))) (T (CAR INFO))) (QUOTE (202 230 331 332 500 503 530))) ((230 202) (* We're logged in) (RETURN T)) (331 (* Needs a password) (SELECTQ (ARPACMD TCPFTPCON "PASS" (\DECRYPT.PWD (CDR INFO)) (QUOTE (230 331 332 530))) (230 (RETURN T)) (332 (SELECTQ (ARPACMD TCPFTPCON "ACCT" (PROMPTFORWORD (CONCAT "Account for logging into " HOST)) (QUOTE (230 202 530))) (230 (RETURN T)) (GO RETRY1))) ((331 530) (LOGIN HOST) (add LOGINRETRYCOUNT 1) (GO RETRY)) (FTPHELP))) (332 (SELECTQ (ARPACMD TCPFTPCON "ACCT" (PROMPTFORWORD (CONCAT "Account for logging into " HOST)) (QUOTE (230 202 530))) (230 (RETURN T)) (GO RETRY1))) (503 (COND ((EQ OSTYPE (QUOTE UNIX)) (* ;; "Well, the sequence of events to get here was probably that the D-machine sent an illegal name/password pair, such that the name was not a registered user on the Unix machine.  There's a bug in the Unix FTP server which causes it to send a 530 error--illegal user name--immediately after it sent a 331 to prompt us for the password.  This is blatantly in violation of the FTP specification, which states that only 100 class errors can have multiple responses.  Now we're out of sync with the server, and need somehow to reinitialize our state") (\PEEKBIN (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (\TCPFTP.INPUT (fetch (TCPFTPCON TCPIN) of TCPFTPCON)))) (GO RETRY1)) ((500 530) (* No such user?) (LOGIN HOST) (add LOGINRETRYCOUNT 1) (GO RETRY)) (FTPHELP))))
)

(\TCPFTP.DELETEFILE
(LAMBDA (NAME DEVICE) (* ejs%: " 7-Apr-86 11:52") (* * FTP delete request) (LET* ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE)) (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE)) (CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "DELE" (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE HOST) NIL (QUOTE BODY) NAME) OSTYPE) (QUOTE (200 226 250 450 550))))))) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) (SELECTQ CODE ((250 226 200) NAME) NIL)))
)

(\TCPFTP.DIRECTORYNAMEP
(LAMBDA (HOST/DIR DEVICE) (* ejs%: "27-Apr-85 14:04") (LET ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE))) (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (TCPFTPCON) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) (COND (RESETSTATE (AND (OPENP (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (CLOSEF (fetch (TCPFTPCON TCPIN) of TCPFTPCON))) (replace (TCPFTPCON TCPIN) of TCPFTPCON with NIL) (AND (OPENP (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (CLOSEF (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (replace (TCPFTPCON TCPOUT) of TCPFTPCON with NIL))))) TCPFTPCON)) (\TCPFTP.CONNECT DEVICE TCPFTPCON (FILENAMEFIELD HOST/DIR (QUOTE DIRECTORY))))))
)

(\TCPFTP.ENDOFSTREAMOP
(LAMBDA (STREAM SILENTLY) (* ejs%: " 3-Feb-85 17:01") (\TCPFTP.TRANSFER.COMPLETE STREAM) (OR SILENTLY (\EOSERROR STREAM)))
)

(\TCPFTP.GENERATEFILES
  [LAMBDA (DEVICE PATTERN DESIREDPROPS OPTIONS)          (* ; "Edited 12-May-89 14:00 by welch")

         (* * FTP directory request)

    (LET* ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE))
           (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE))
           DATASTREAMEVENT DATASTREAM CODE)
          (SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION TCPFTPCON 'INPUT))
          (BLOCK)
          [SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "NLST"
                                         [COND
                                            [(EQ OSTYPE 'UNIX)
                                             (COND
                                                ((AND (EQ (FILENAMEFIELD PATTERN 'VERSION)
                                                          '*)
                                                      (EQ (FILENAMEFIELD PATTERN 'EXTENSION)
                                                          '*)
                                                      (EQ (FILENAMEFIELD PATTERN 'NAME)
                                                          '*))
                                                 (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                         'HOST NIL 'VERSION NIL
                                                                         'EXTENSION NIL 'NAME "*"
                                                                         'BODY PATTERN)
                                                        'UNIX))
                                                ((EQ (FILENAMEFIELD PATTERN 'VERSION)
                                                     '*)
                                                 (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                         'HOST NIL 'VERSION NIL
                                                                         'BODY PATTERN)
                                                        'UNIX))
                                                (T (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                           'HOST NIL 'BODY PATTERN)
                                                          'UNIX]
                                            (T (COND
                                                  ((EQ OSTYPE 'INTERLISP)
                                                   (PACKFILENAME.STRING 'HOST NIL 'BODY PATTERN))
                                                  (T (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                             'HOST NIL 'BODY PATTERN)
                                                            OSTYPE]
                                         150]
          (SELECTQ CODE
              (150 

         (* * Here we go)

                   (COND
                      ((SETQ DATASTREAM (\TCPFTP.WAIT.FOR.DATACONNECTION DEVICE TCPFTPCON 
                                               DATASTREAMEVENT 'INPUT))
                       (replace (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON
                          with (FILENAMEFIELD PATTERN 'DIRECTORY))
                       (create FILEGENOBJ
                              NEXTFILEFN _ (FUNCTION \TCPFTP.GENERATENEXTFILE)
                              FILEINFOFN _ (FUNCTION NILL)
                              GENFILESTATE _ TCPFTPCON))
                      (T (ERROR "Couldn't open data connection to remote TCPFTP server"))))
              (PROGN (DEL.PROCESS (CAR DATASTREAMEVENT))
                     (\TCPFTP.RELEASE.CONNECTION TCPFTPCON)
                     (\NULLFILEGENERATOR])

(\TCPFTP.GENERATENEXTFILE
  [LAMBDA (TCPFTPCON NAMEONLY)                           (* ; "Edited  8-Mar-89 22:54 by akw:")
    (PROG ((DATASTREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON))
           [OSTYPE (\TCPFTP.GET.OSTYPE (fetch (STREAM DEVICE) of (fetch (TCPFTPCON
                                                                                         TCPIN)
                                                                                of TCPFTPCON]
           [FILENAMERDTBL (DEFERREDCONSTANT (PROG [(R (COPYREADTABLE 'ORIG]
                                                  (SETBRK NIL NIL R)
                                                  (SETSYNTAX '%% 'OTHER R)
                                                  (SETSEPR '(13 10 31)
                                                         NIL R)
                                                  (RETURN R]
           CODE NAME)
      LOOP
          (RETURN (COND
                     [[AND (OPENP DATASTREAM 'INPUT)
                           (NOT (EOFP DATASTREAM))
                           (SETQ NAME (CAR (NLSETQ (READ DATASTREAM FILENAMERDTBL]
                      (COND
                         ((AND (OR (EQ OSTYPE 'TOPS-20)
                                   (EQ OSTYPE 'TOPS20))
                               (STRPOS "? Not found" NAME NIL NIL NIL NIL UPPERCASEARRAY))
                          (NLSETQ (until (EOFP DATASTREAM) do (READ DATASTREAM FILENAMERDTBL)
                                         ))
                          (AND (OPENP DATASTREAM)
                               (CLOSEF DATASTREAM))
                          (SELECTQ [SETQ CODE (ARPACMD TCPFTPCON NIL NIL '(226 250]
                              ((250 226) 
                                   (AND (OPENP DATASTREAM)
                                        (CLOSEF DATASTREAM))
                                   (\TCPFTP.RELEASE.CONNECTION TCPFTPCON)
                                   NIL)
                              (FTPHELP CODE)))
                         ((AND (EQ OSTYPE 'UNIX)
                               (STREQUAL ":" (SUBSTRING NAME -1)))
                          (replace (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON
                             with (REPACKFILENAME.STRING (SUBSTRING NAME 1 -2)
                                             'INTERLISP))
                          (GO LOOP))
                         (NAMEONLY (REPACKFILENAME.STRING NAME 'INTERLISP))
                         (T (if (STRPOS "*" (fetch (TCPFTPCON GENERATEFILESDIRECTORY)
                                                   of TCPFTPCON))
                                then (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME)
                                                                       of
                                                                       (fetch (STREAM DEVICE)
                                                                          of (fetch
                                                                                  (TCPFTPCON TCPIN)
                                                                                    of TCPFTPCON)
                                                                              ))
                                                'BODY
                                                (REPACKFILENAME.STRING NAME 'INTERLISP))
                              else (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME)
                                                                     of
                                                                     (fetch (STREAM DEVICE)
                                                                        of (fetch
                                                                                (TCPFTPCON TCPIN)
                                                                                  of TCPFTPCON)))
                                              'DIRECTORY
                                              (fetch (TCPFTPCON GENERATEFILESDIRECTORY)
                                                 of TCPFTPCON)
                                              'BODY
                                              (REPACKFILENAME.STRING NAME 'INTERLISP]
                     (T (AND (OPENP DATASTREAM)
                             (CLOSEF DATASTREAM))
                        (SELECTQ [SETQ CODE (ARPACMD TCPFTPCON NIL NIL '(226 250]
                            ((250 226) 
                                 (AND (OPENP DATASTREAM)
                                      (CLOSEF DATASTREAM))
                                 (\TCPFTP.RELEASE.CONNECTION TCPFTPCON)
                                 NIL)
                            (FTPHELP CODE])

(\TCPFTP.GETFILENAME
  [LAMBDA (NAME RECOG DEVICE)                            (* ; "Edited 12-May-89 13:35 by welch")

         (* * FTP directory request)

    (COND
       ((EQ RECOG 'NEW)
        NAME)
       (T (PROG ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE))
                 (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE))
                 DATASTREAMEVENT DATASTREAM CODE GENERATOR ALLPOSSIBILITIES)
                (SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION TCPFTPCON 'INPUT))
                (BLOCK)
                [SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "NLST"
                                               (COND
                                                  ((EQ OSTYPE 'INTERLISP)
                                                   (PACKFILENAME.STRING 'HOST NIL 'BODY NAME))
                                                  (T (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                             'HOST NIL 'BODY NAME)
                                                            OSTYPE)))
                                               150]
                (RETURN (SELECTQ CODE
                            (150 

         (* * Here we go)

                                 (COND
                                    ((AND (SETQ DATASTREAM (\TCPFTP.WAIT.FOR.DATACONNECTION
                                                            DEVICE TCPFTPCON DATASTREAMEVENT
                                                            'INPUT))
                                          (SETQ GENERATOR (create FILEGENOBJ
                                                                 NEXTFILEFN _ (FUNCTION 
                                                                             \TCPFTP.GENERATENEXTFILE
                                                                               )
                                                                 FILEINFOFN _ (FUNCTION NILL)
                                                                 GENFILESTATE _ TCPFTPCON)))
                                     (replace (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON
                                        with (FILENAMEFIELD NAME 'DIRECTORY))
                                     (SETQ ALLPOSSIBILITIES (bind FILE
                                                               while (SETQ FILE (
                                                                                    \GENERATENEXTFILE
                                                                                     GENERATOR))
                                                               collect FILE))
                                     (MKATOM (CAR ALLPOSSIBILITIES)))
                                    (T (ERROR 
                                             "Couldn't open data connection to remote TCPFTP server."
                                              ))))
                            (PROGN (DEL.PROCESS (CAR DATASTREAMEVENT))
                                   (\TCPFTP.RELEASE.CONNECTION TCPFTPCON)
                                   NIL])

(\TCPFTP.GETFILEINFO
(LAMBDA (STREAM ATTRIB DEVICE) (* ejs%: "20-Mar-86 21:01") (COND ((type? STREAM STREAM) (STREAMPROP STREAM ATTRIB)) ((EQ ATTRIB (QUOTE EOL)) (QUOTE CRLF))))
)

(\TCPFTP.SETFILEINFO
(LAMBDA (STREAM ATTRIB VALUE DEVICE) (* ejs%: " 9-Nov-85 14:20") (STREAMPROP STREAM ATTRIB VALUE)))

(\TCPFTP.RENAMEFILE
(LAMBDA (OLDDEVICE OLDNAME NEWDEVICE NEWNAME) (* ; "Edited 15-Jun-88 13:41 by atm") (* * FTP delete request) (COND ((NEQ OLDDEVICE NEWDEVICE) (\GENERIC.RENAMEFILE OLDDEVICE OLDNAME NEWDEVICE NEWNAME)) (T (LET ((OSTYPE (\TCPFTP.GET.OSTYPE OLDDEVICE)) (TCPFTPCON (\GET.TCPFTP.CONNECTION OLDDEVICE)) CODE) (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (CON) (\TCPFTP.RELEASE.CONNECTION CON))) TCPFTPCON)) (PROG NIL RETRY (SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "RNFR" (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE HOST) NIL (QUOTE BODY) OLDNAME) OSTYPE) (QUOTE (350 450 550)))))) (SELECTQ CODE (350 (SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "RNTO" (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE HOST) NIL (QUOTE BODY) NEWNAME) OSTYPE) (QUOTE (200 250 553)))))) (SELECTQ CODE ((200 250) (RETURN NEWNAME)) NIL)) (PROGN (SETQ OLDNAME (LISPERROR "FILE NOT FOUND" OLDNAME T)) (GO RETRY)))))))))
)

(\TCPFTP.CONNECT
(LAMBDA (DEVICE TCPFTPCON DIRECTORY) (* ejs%: "24-Jun-85 17:10") (LET ((DIRECTORYNAME (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRECTORY) (\TCPFTP.GET.OSTYPE DEVICE)))) (COND ((NEQ 0 (NCHARS DIRECTORYNAME)) (SELECTQ (ARPACMD TCPFTPCON "CWD" DIRECTORYNAME (QUOTE (200 250 450 550))) ((200 250) T) NIL)) (T (* The user specified no connect directory. We'll have to assume he or she meant his or her own login directory, whose name we can't even accurately guess. Thus, we leave it at this) T))))
)

(\TCPFTP.OPENFILE
  [LAMBDA (NAME ACCESS RECOG PARAMETERS DEVICE)          (* ; "Edited 22-Mar-89 22:31 by welch")
    (DECLARE (GLOBALVARS TCP.DEFAULTFILETYPE TCP.USE.STANDARD.EOL TCPFTP.EOL.CONVENTION 
                        TCPFTP.DEFAULT.FILETYPES))
    (LET* ((HOST (fetch (FDEV DEVICENAME) of DEVICE))
           (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE))
           [FILENAME (COND
                        ((EQ OSTYPE 'INTERLISP)
                         (PACKFILENAME.STRING 'HOST NIL 'BODY NAME))
                        (T (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY NAME)
                                  OSTYPE]
           (FILENAME.EXTENSION (FILENAMEFIELD FILENAME 'EXTENSION))
           (TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE))
           (TYPE (OR (CADR (FASSOC 'TYPE PARAMETERS))
                     (CDR (FASSOC FILENAME.EXTENSION TCPFTP.DEFAULT.FILETYPES))
                     (CDR (FASSOC (U-CASE FILENAME.EXTENSION)
                                 TCPFTP.DEFAULT.FILETYPES))
                     TCP.DEFAULTFILETYPE))
           DATASTREAMEVENT DATASTREAM CODE FTPCMD STREAMDEV)
          (SELECTQ TYPE
              (TEXT (ARPACMD TCPFTPCON "TYPE" "A N" 200))
              (ARPACMD TCPFTPCON "TYPE" "L 8" 200))
          (SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION TCPFTPCON (COND
                                                                               ((EQ ACCESS
                                                                                    'OUTPUT)
                                                                                'APPEND)
                                                                               (T ACCESS))
                                       T))
          (BLOCK)
          (PROG NIL
            LOOP
                (SETQ FTPCMD (SELECTQ ACCESS
                                 (INPUT '"RETR")
                                 (OUTPUT '"STOR")
                                 (APPEND '"APPE")
                                 (ERROR "ACCESS must be one of INPUT, OUTPUT, or APPEND" ACCESS)))
                [SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON FTPCMD FILENAME
                                               '(125 150 226 250 425 426 450 451 550]
                (SELECTQ CODE
                    ((125 150) 

         (* * Here we go)

                         (COND
                            ([SETQ DATASTREAM (\TCPFTP.WAIT.FOR.DATACONNECTION
                                               DEVICE TCPFTPCON DATASTREAMEVENT
                                               (COND
                                                  ((EQ ACCESS 'OUTPUT)
                                                   'APPEND)
                                                  (T ACCESS]
                             (replace (STREAM ENDOFSTREAMOP) of DATASTREAM
                                with (FUNCTION \TCPFTP.ENDOFSTREAMOP))
                             (replace (STREAM FULLFILENAME) of DATASTREAM with NAME)
                             [replace (STREAM EOLCONVENTION) of DATASTREAM
                                with (COND
                                            (TCP.USE.STANDARD.EOL CRLF.EOLC)
                                            (T (OR TCPFTP.EOL.CONVENTION (SELECTQ OSTYPE
                                                                             (UNIX LF.EOLC)
                                                                             (TOPS-20 CRLF.EOLC)
                                                                             CR.EOLC]
                             (STREAMPROP DATASTREAM 'TYPE TYPE)
                             (replace (TCPDATASTREAM TCPFTPCON) of DATASTREAM with 
                                                                                            TCPFTPCON
                                    )
                             (SETQ STREAMDEV (fetch (STREAM DEVICE) of DATASTREAM))
                             (replace (FDEV GETFILENAME) of STREAMDEV
                                with (FUNCTION NILL))
                             (replace (FDEV GETFILEINFO) of STREAMDEV
                                with (FUNCTION \TCPFTP.GETFILEINFO))
                             (STREAMADDPROP DATASTREAM 'AFTERCLOSE (FUNCTION 
                                                                    \TCPFTP.TRANSFER.COMPLETE))
                             (STREAMADDPROP DATASTREAM 'BEFORECLOSE (FUNCTION \TCPFTP.READ.UNTIL.EOF)
                                    )
                             (RETURN DATASTREAM))
                            (T (ERROR "Couldn't open data connection to remote TCPFTP server"))))
                    (425                                     (* The foreign port is busy)
                         (PROMPTPRINT "TCPFTP: Please wait; the remote ftp server is busy.")
                         (DEL.PROCESS (CAR DATASTREAMEVENT))
                         (DISMISS 5000)
                         [SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION
                                                TCPFTPCON
                                                (COND
                                                   ((EQ ACCESS 'OUTPUT)
                                                    'APPEND)
                                                   (T ACCESS]
                         (BLOCK)
                         (GO LOOP))
                    ((450 550) 
                         (DEL.PROCESS (CAR DATASTREAMEVENT))
                         (\TCPFTP.RELEASE.CONNECTION TCPFTPCON)
                         NIL)
                    (FTPHELP CODE])

(\TCPFTP.CLOSE
(LAMBDA (DEVICE) (* ejs%: "23-Apr-85 18:41") (* * This needs work) (PROG ((DEVINFO (fetch (FDEV DEVICEINFO) of DEVICE))) (AND (OPENP (fetch (TCPFTPCON TCPOUT) of DEVINFO) (QUOTE OUTPUT)) (CLOSEF (fetch (TCPFTPCON TCPOUT) of DEVINFO))) (AND (OPENP (fetch (TCPFTPCON TCPIN) of DEVINFO) (QUOTE INPUT)) (CLOSEF (fetch (TCPFTPCON TCPIN) of DEVINFO)))))
)

(\TCPFTP.FLUSH
(LAMBDA (DEVICE) (* ejs%: "23-Apr-85 18:56") (* * This needs work) (PROG ((INSTREAM (fetch (TCPFTPCON TCPIN) of (fetch (FDEV DEVICEINFO) of DEVICE)))) (COND ((READP INSTREAM) (until (NOT (READP INSTREAM)) do (BIN INSTREAM))))))
)

(\TCPFTP.INIT
(LAMBDA NIL (* ejs%: "10-Apr-85 19:25") (\DEFINEDEVICE NIL (create FDEV DEVICENAME _ (QUOTE TCPFTP) HOSTNAMEP _ (FUNCTION \TCPFTP.HOSTNAMEP) EVENTFN _ (FUNCTION \TCPFTP.EVENTFN))))
)

(SET.TCP.EOL.CONVENTION
  [LAMBDA (EOLTYPE)                                      (* ; "Edited 22-Mar-89 22:31 by welch")
                                                             (* ; "Sets the EOL convention to use")
    (DECLARE (GLOBALVARS TCP.USE.STANDARD.EOL TCPFTP.EOL.CONVENTION))
    (SELECTQ EOLTYPE
        (CR (SETQ TCP.USE.STANDARD.EOL NIL)
            (SETQ TCPFTP.EOL.CONVENTION CR.EOLC))
        (LF (SETQ TCP.USE.STANDARD.EOL NIL)
            (SETQ TCPFTP.EOL.CONVENTION LF.EOLC))
        (CRLF (SETQ TCP.USE.STANDARD.EOL NIL)
              (SETQ TCPFTP.EOL.CONVENTION CRLF.EOLC))
        (OS (SETQ TCP.USE.STANDARD.EOL NIL)
            (SETQ TCPFTP.EOL.CONVENTION NIL))
        (SETQ TCP.USE.STANDARD.EOL T])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS TCPDATASTREAM ((TCPCONTROLDEVICE (fetch (STREAM F3) of DATUM)
                                     (replace (STREAM F3) of DATUM with NEWVALUE))
                              (SEENEOS (fetch (STREAM F4) of DATUM)
                                     (replace (STREAM F4) of DATUM with NEWVALUE))
                              (TCPFTPCON (fetch (STREAM F5) of DATUM)
                                     (replace (STREAM F5) of DATUM with NEWVALUE))))

(RECORD TCPFTPCON (TCPIN TCPOUT DATASTREAM BUSY? IDLETIMER GENERATEFILESDIRECTORY))
)

(* "END EXPORTED DEFINITIONS")

)

(ADDTOVAR TCPFTP.DEFAULT.FILETYPES (NIL . TEXT)
                                       (DFASL . BINARY)
                                       (dfasl . BINARY)
                                       (LCOM . BINARY)
                                       (lcom . BINARY)
                                       (DCOM . BINARY)
                                       (dcom . BINARY)
                                       (LISP . TEXT)
                                       (lisp . TEXT)
                                       (LSP . TEXT)
                                       (lsp . TEXT)
                                       (RST . BINARY)
                                       (rst . BINARY)
                                       (BIN . BINARY)
                                       (bin . BINARY))

(RPAQ? TCP.DEFAULTFILETYPE 'BINARY)

(RPAQ? TCP.USE.STANDARD.EOL T)

(RPAQ? \TCPFTP.DEVICES )

(RPAQ? \TCPFTP.CLEANUP.PROCESS )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCPFTP.DEVICES \TCPFTP.CLEANUP.PROCESS TCP.DEFAULTFILETYPE TCP.USE.STANDARD.EOL)
)



(* ;; "Data connection handling")

(DEFINEQ

(\TCP.BYE
(LAMBDA (HOST) (* ejs%: "15-Nov-86 15:05") (LET* ((DEVICE (\GETDEVICEFROMNAME HOST NIL T)) (CONNECTIONS (AND DEVICE (fetch (FDEV DEVICEINFO) of DEVICE)))) (bind INSTREAM for TCPFTPCON in CONNECTIONS do (SETQ INSTREAM (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (while (AND (OPENP INSTREAM (QUOTE INPUT)) (READP INSTREAM)) do (BIN INSTREAM)) (NLSETQ (ARPACMD TCPFTPCON "QUIT" NIL (QUOTE (221 500)))) (CLOSEF? (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON)) (CLOSEF? INSTREAM) (CLOSEF? (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) T) (replace (FDEV DEVICEINFO) of DEVICE with NIL)))
)

(\TCPFTP.MAYBE.ABORT
  [LAMBDA (DATASTREAM)                                   (* ; "Edited 18-Mar-89 13:43 by welch")
    (LET* ((TCPFTPCON (fetch (TCPDATASTREAM TCPFTPCON) of DATASTREAM))
           (TCPOUTSTREAM (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)))
          (STREAMPROP DATASTREAM 'BEFORECLOSE NIL)
          (COND
             ((AND (NOT (fetch (TCPDATASTREAM SEENEOS) of DATASTREAM))
                   (OPENP DATASTREAM 'INPUT))
              (TCP.CLOSE.SENDER (TCP.OTHER.STREAM DATASTREAM))
              (BLOCK)
              (BOUT TCPOUTSTREAM 244)
              (BOUT TCPOUTSTREAM 242)
              (TCP.URGENT.MARK TCPOUTSTREAM)
              (ARPACMD TCPFTPCON "ABOR" NIL '(226 426 250])

(\TCPFTP.DATA.CLOSED
(LAMBDA (INSTREAM OUTSTREAM) (* ejs%: "28-Jul-86 14:03") (LET* ((STREAM (OR INSTREAM OUTSTREAM))) (replace (STREAM ACCESS) of STREAM with NIL)))
)

(\TCPFTP.OPEN.DATA.CONNECTION
(LAMBDA (TCPFTPCON ACCESS EVENT FOR.FILE.TRANSFER) (* ejs%: "26-Sep-86 18:27") (DECLARE (GLOBALVARS \TCPFTP.DATACONNECTION.LOCK)) (* * Tell the FTP control connection on what port we're expecting the data connection to made, and try up to five times to accept a connection. Each time, select a new port (this hopefully a workaround to a Unix bug in which ports sometimes tend to appear busy for 2 minute timeout intervals)) (WITH.MONITOR \TCPFTP.DATACONNECTION.LOCK (bind PORT STREAM for I from 1 to 5 do (SETQ PORT (\TCP.SELECT.PORT)) (ARPACMD TCPFTPCON "PORT" (\TCPFTP.PORT.STRING PORT) (QUOTE (200))) (SETQ STREAM (TCP.OPEN NIL NIL PORT (QUOTE PASSIVE) ACCESS NIL (COND (FOR.FILE.TRANSFER (CONSTANT (BQUOTE (MAXSEG %, BYTESPERPAGE WHENCLOSEDFN \TCPFTP.DATA.CLOSED))))))) (COND (STREAM (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with STREAM) (RETURN))) finally (* * We give up. Place a NIL in the datastream field so the client who was trying to accept the data connection will realize we couldn't succeed) (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with NIL)) (AND (TYPENAMEP EVENT (QUOTE EVENT)) (NOTIFY.EVENT EVENT)) (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON)))
)

(\TCPFTP.PORT.STRING
(LAMBDA (PORT) (* ejs%: "26-Apr-85 11:54") (* * Returns "h1,h2,h3,h4,p1,p3" corresponding to bytes of local IP host and PORT for port command) (LET ((IPADDRESS (\LOCAL.IP.ADDRESS))) (CONCAT (LOADBYTE IPADDRESS 24 8) "," (LOADBYTE IPADDRESS 16 8) "," (LOADBYTE IPADDRESS 8 8) "," (LOADBYTE IPADDRESS 0 8) "," (LOADBYTE PORT 8 8) "," (LOADBYTE PORT 0 8))))
)

(\TCPFTP.SPAWN.DATACONNECTION
(LAMBDA (TCPFTPCON ACCESS FOR.FILE.TRANSFER) (* ejs%: "26-Sep-86 19:21") (* * Called from TCPFTP device methods like \TCPFTP.OPENFILE. Spawns a process to wait for the server program to open a data connection to us. Returns a CONS consisting of the spawned process handle and an event which will be notified when the server has connected to us. This function MUST be called prior to any TCPFTP operations which would cause the server to try to open a data connection to us (otherwise, the server might try to open the connection before we're prepared to accept it)) (LET* ((EVENT (CREATE.EVENT)) (PROCESS (ADD.PROCESS (BQUOTE (\TCPFTP.OPEN.DATA.CONNECTION (QUOTE %, TCPFTPCON) (QUOTE %, ACCESS) %, EVENT %, FOR.FILE.TRANSFER))))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (PROCESS INSTREAM OUTSTREAM) (DEL.PROCESS PROCESS) (* CLOSEF? INSTREAM) (* CLOSEF? OUTSTREAM) NIL)) PROCESS (fetch (TCPFTPCON TCPIN) of TCPFTPCON) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (CONS PROCESS EVENT)))
)

(\TCPFTP.READ.UNTIL.EOF
  [LAMBDA (DATASTREAM)                                   (* ; "Edited 20-Jun-89 19:41 by welch")

(* ;;; "This function is used to avoid possible deadlock in the case where the stream is opened and closed immediately. ")

    (PROG ((TCB (fetch (TCPSTREAM TCB) of DATASTREAM))
           (TCPFTPCON (fetch (TCPDATASTREAM TCPFTPCON) of DATASTREAM)))
          (WITH.MONITOR \TCPFTP.DATACONNECTION.LOCK
              (if (NOT (EOFP DATASTREAM))
                  then (while (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))
                              do (\TCP.GET.SEGMENT DATASTREAM)) 

                        (* ;; "read to the end of the file.")

                        (while (NOT (EOFP DATASTREAM)) do (BIN DATASTREAM))))])

(\TCPFTP.TRANSFER.COMPLETE
  [LAMBDA (DATASTREAM)                                   (* ; "Edited 24-May-89 14:12 by welch")
    (LET ((TCPFTPCON (fetch (TCPDATASTREAM TCPFTPCON) of DATASTREAM)))
         (STREAMPROP DATASTREAM 'AFTERCLOSE NIL)
         (COND
            ((AND TCPFTPCON (NOT (fetch (TCPDATASTREAM SEENEOS) of DATASTREAM)))
             [COND
                ((OPENP DATASTREAM 'INPUT)
                 (TCP.CLOSE.SENDER (TCP.OTHER.STREAM DATASTREAM]
             (replace (TCPDATASTREAM SEENEOS) of DATASTREAM with T)
             (replace (TCPDATASTREAM TCPCONTROLDEVICE) of DATASTREAM with NIL)
             (replace (TCPDATASTREAM TCPFTPCON) of DATASTREAM with NIL)
             (\TCPFTP.RELEASE.CONNECTION TCPFTPCON])

(\TCPFTP.WAIT.FOR.DATACONNECTION
(LAMBDA (DEVICE TCPFTPCON PROCESS.AND.EVENT ACCESS) (* ejs%: "26-Sep-86 18:30") (* * EVENT is a cons of PROCESS and a real event. PROCESS is the process trying to open the connection; EVENT is an event which is notified when the process succeeds or fails to open the connection to the server) (LET (STREAM) (AWAIT.EVENT (CDR PROCESS.AND.EVENT) 120000) (COND ((NULL (SETQ STREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON))) (* * A NIL in this field means the local client code was unable to open the connection to the server program.) NIL) ((OPENP STREAM ACCESS) (replace (TCPDATASTREAM TCPCONTROLDEVICE) of STREAM with DEVICE) STREAM))))
)

(\TCPFTP.DELETE.CONNECTION
(LAMBDA (TCPFTPCON DEVICE SENDBYE) (* ejs%: "15-Nov-86 15:09") (LET ((INSTREAM (fetch (TCPFTPCON TCPIN) of TCPFTPCON))) (COND (SENDBYE (NLSETQ (ARPACMD TCPFTPCON "BYE" NIL (QUOTE (221 500)))))) (COND (INSTREAM (DEL.PROCESS (fetch (TCP.CONTROL.BLOCK TCB.PROCESS) of (fetch (TCPSTREAM TCB) of INSTREAM))))) (replace (FDEV DEVICEINFO) of DEVICE with (DREMOVE TCPFTPCON (fetch (FDEV DEVICEINFO) of DEVICE)))))
)
)

(RPAQ? \TCPFTP.DATACONNECTION.LOCK (CREATE.MONITORLOCK "TCPFTP Data Connection Lock"))

(RPAQ? \TCPFTP.CONNECTION.LOCK (CREATE.MONITORLOCK "TCPFTP Connection Lock"))

(RPAQ? \TCPFTP.IDLE.TIMEOUT (TIMES 10 60 1000))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TCPFTP.DATACONNECTION.LOCK \TCPFTP.CONNECTION.LOCK \TCPFTP.IDLE.TIMEOUT)
)

(FILESLOAD (SYSLOAD)
       TCPNAMES TCP)

(\TCPFTP.INIT)

(RPAQQ TCPFTP.DEFAULT.FILETYPES
       ((NIL . TEXT)
        (DFASL . BINARY)
        (dfasl . BINARY)
        (LCOM . BINARY)
        (lcom . BINARY)
        (DCOM . BINARY)
        (dcom . BINARY)
        (LISP . TEXT)
        (lisp . TEXT)
        (LSP . TEXT)
        (lsp . TEXT)
        (RST . BINARY)
        (rst . BINARY)
        (BIN . BINARY)
        (bin . BINARY)
        (TXT . TEXT)
        (txt . TEXT)
        (TEXT . TEXT)
        (text . TEXT)
        (c . TEXT)
        (h . TEXT)
        (o . BINARY)
        (TEDIT . BINARY)
        (tedit . BINARY)
        (DISPLAYFONT . BINARY)
        (WD . BINARY)))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(PUTPROPS TCPFTP COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1900 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4143 7185 (ARPACMD 4153 . 5446) (FTPHELP 5448 . 5565) (CMDREADCODE 5567 . 5671) (
CMDREAD 5673 . 5800) (DISCARDLINE 5802 . 6196) (GETLINE 6198 . 6484) (\TCPFTP.INPUT 6486 . 7041) (
TELNET.EOL 7043 . 7183)) (7526 40072 (\TCPFTP.CONTROL.CLOSED 7536 . 8004) (\TCPFTP.GET.OSTYPE 8006 . 
8252) (\TCPFTP.EVENTFN 8254 . 8834) (\TCPFTP.HOSTNAMEP 8836 . 11823) (\GET.TCPFTP.CONNECTION 11825 . 
12570) (\TCPFTP.OPEN.CONNECTION 12572 . 13893) (\TCPFTP.ASSURE.CLEANUP 13895 . 14215) (\TCPFTP.CLEANUP
 14217 . 15408) (\TCPFTP.RELEASE.CONNECTION 15410 . 15723) (\TCPFTP.LOGIN 15725 . 17870) (
\TCPFTP.DELETEFILE 17872 . 18309) (\TCPFTP.DIRECTORYNAMEP 18311 . 18965) (\TCPFTP.ENDOFSTREAMOP 18967
 . 19118) (\TCPFTP.GENERATEFILES 19120 . 22881) (\TCPFTP.GENERATENEXTFILE 22883 . 27772) (
\TCPFTP.GETFILENAME 27774 . 30946) (\TCPFTP.GETFILEINFO 30948 . 31131) (\TCPFTP.SETFILEINFO 31133 . 
31257) (\TCPFTP.RENAMEFILE 31259 . 32187) (\TCPFTP.CONNECT 32189 . 32726) (\TCPFTP.OPENFILE 32728 . 
38498) (\TCPFTP.CLOSE 38500 . 38868) (\TCPFTP.FLUSH 38870 . 39118) (\TCPFTP.INIT 39120 . 39320) (
SET.TCP.EOL.CONVENTION 39322 . 40070)) (41953 48826 (\TCP.BYE 41963 . 42548) (\TCPFTP.MAYBE.ABORT 
42550 . 43295) (\TCPFTP.DATA.CLOSED 43297 . 43468) (\TCPFTP.OPEN.DATA.CONNECTION 43470 . 44677) (
\TCPFTP.PORT.STRING 44679 . 45060) (\TCPFTP.SPAWN.DATACONNECTION 45062 . 46078) (
\TCPFTP.READ.UNTIL.EOF 46080 . 46897) (\TCPFTP.TRANSFER.COMPLETE 46899 . 47705) (
\TCPFTP.WAIT.FOR.DATACONNECTION 47707 . 48384) (\TCPFTP.DELETE.CONNECTION 48386 . 48824)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPFTPSRV b/obsolete/tcp/TCPFTPSRV
deleted file mode 100644
index 1e95bbcd..00000000
--- a/obsolete/tcp/TCPFTPSRV
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "13-Sep-90 15:07:59" {DSK}<LISPFILES>TCP>TCPFTPSRV.;6 55339  

      changes to%:  (FNS TCPFTP.SERVER.MERGE.PATHNAMES TCPFTP.SERVER.PATH TCPFTP.SERVER.LIST 
                         TCPFTP.SERVER.RETRIEVE)

      previous date%: "11-Sep-90 13:34:33" {DSK}<LISPFILES>TCP>TCPFTPSRV.;5)


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

(PRETTYCOMPRINT TCPFTPSRVCOMS)

(RPAQQ TCPFTPSRVCOMS
       ((FNS TCPFTP.SERVER TCPFTP.SERVER.ABORTED TCPFTP.SERVER.ACCOUNT TCPFTP.SERVER.APPEND 
             TCPFTP.SERVER.CLOSE.DATA.CONNECTION TCPFTP.SERVER.COMMAND.LOOP 
             TCPFTP.SERVER.CONNECTED.INFO TCPFTP.SERVER.DELETE TCPFTP.SERVER.DIRECTORY 
             TCPFTP.SERVER.EXIT TCPFTP.SERVER.IDLE.INFO TCPFTP.SERVER.LIST 
             TCPFTP.SERVER.MERGE.PATHNAMES TCPFTP.SERVER.MODE TCPFTP.SERVER.OPEN.DATA.CONNECTION 
             TCPFTP.SERVER.PARSE.PORT TCPFTP.SERVER.PASSWORD TCPFTP.SERVER.PATH TCPFTP.SERVER.PORT 
             TCPFTP.SERVER.PROCESS TCPFTP.SERVER.RENAME.FROM TCPFTP.SERVER.RENAME.TO 
             TCPFTP.SERVER.RESPONSE TCPFTP.SERVER.RETRIEVE TCPFTP.SERVER.RETURN.FILE 
             TCPFTP.SERVER.STORE TCPFTP.SERVER.STRUCTURE TCPFTP.SERVER.TYPE TCPFTP.SERVER.USER 
             TCPFTP.SERVER.VERBOSE.LIST TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTP.UNIX.LS.DATE)
        (INITVARS (TCPFTP.SERVER.HERALD.STRING "Venue Medley FTP Service 1.0 at your service")
               (TCPFTP.SERVER.USE.TOPS20.SYNTAX NIL)
               (TCPFTP.SERVER.RETRYCOUNT 5))
        (GLOBALVARS TCPFTP.SERVER.HERALD.STRING TCPFTP.SERVER.USE.TOPS20.SYNTAX 
               TCPFTP.SERVER.RETRYCOUNT)
        (FILES (SYSLOAD)
               TCPFTP)))
(DEFINEQ

(TCPFTP.SERVER
  [LAMBDA (PORT DEFAULT.FILE.PATH)                           (* ; "Edited 24-Aug-87 17:57 by scp")
          
          (* * This is the TCP-based FTP server top-level)

    (ADD.PROCESS `(TCPFTP.SERVER.PROCESS ,PORT ,DEFAULT.FILE.PATH) 'RESTARTABLE 'HARDRESET])

(TCPFTP.SERVER.ABORTED
  [LAMBDA (INSTREAM OUTSTREAM)                               (* ejs%: "20-Mar-86 19:53")
    (TCPFTP.SERVER.EXIT INSTREAM OUTSTREAM])

(TCPFTP.SERVER.ACCOUNT
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 11:40")
          
          (* * This function parses USER commands)

    (LET ((ACCT (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                       RDTBL)))
         (COND
            (FTPDEBUGFLG (printout FTPDEBUGLOG ACCT T)))
         (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
         (TCPFTP.SERVER.RESPONSE 230 "You sure are formal!" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.APPEND
  [LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH)       (* ejs%: "24-Mar-86 14:07")
          
          (* * This function parses USER commands)

    (LET*
     [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                       RDTBL))
      (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
      (TRUENAME (CAR (NLSETQ (OR (INFILEP PACKED.FILENAME)
                                 (OUTFILEP PACKED.FILENAME]
     (COND
        (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
     (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
     (COND
        [TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'APPEND NIL
                                                        `((TYPE %, TYPE]
                       (COND
                          [FILESTREAM
                           (TCPFTP.SERVER.RESPONSE 150 (CONCAT 
                                                             "Opening data connection for append to "
                                                              (FULLNAME FILESTREAM))
                                  (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                           (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT T
                                                    )))
                                (COND
                                   (DATASTREAM [replace (STREAM ENDOFSTREAMOP) of DATASTREAM
                                                  with (FUNCTION (LAMBDA (STREAM)
                                                                   (ERROR!]
                                          (RESETLST (RESETSAVE (COND
                                                                  ((EQ TYPE 'BINARY)
                                                                   (COPYBYTES DATASTREAM FILESTREAM))
                                                                  (T (COPYCHARS DATASTREAM FILESTREAM
                                                                            )))
                                                           (LIST [FUNCTION (LAMBDA (FILESTREAM 
                                                                                          TCPFTPCON)
                                                                             (CLOSEF? FILESTREAM)
                                                                             (
                                                                  TCPFTP.SERVER.CLOSE.DATA.CONNECTION
                                                                              TCPFTPCON)
                                                                             (TCPFTP.SERVER.RESPONSE
                                                                              226 
                                                                             "Data transfer complete"
                                                                              (fetch (TCPFTPCON
                                                                                      TCPOUT)
                                                                                 of TCPFTPCON]
                                                                 FILESTREAM TCPFTPCON]
                          (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " TRUENAME)
                                    (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
        (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "Unable to create output filename - " PACKED.FILENAME)
                  (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.CLOSE.DATA.CONNECTION
  [LAMBDA (TCPFTPCON)                                        (* ejs%: "20-Mar-86 17:53")
    (LET ((DATASTREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON))
          (EVENT (fetch (TCPFTPCON BUSY?) of TCPFTPCON)))
         (CLOSEF? DATASTREAM)
         (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with NIL)
         (replace (TCPFTPCON BUSY?) of TCPFTPCON with NIL)
         (NOTIFY.EVENT EVENT)
         T])

(TCPFTP.SERVER.COMMAND.LOOP
  [LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM PATH)
                                                           (* ; "Edited 31-Aug-90 17:15 by gadener")
    (DECLARE (SPECVARS TCPFTPCON COMMAND))
    (LET ([COMMAND.RDTBL (DEFERREDCONSTANT (PROG [(R (COPYREADTABLE 'ORIG]
                                                 (SETBRK NIL NIL R)
                                                 (SETSYNTAX '%% 'OTHER R)
                                                 (SETSEPR '(13 10 31 32)
                                                        NIL R)
                                                 (RETURN R]
          (TCPFTPCON (create TCPFTPCON
                            TCPIN _ CONTROL.INPUT.STREAM
                            TCPOUT _ CONTROL.OUTPUT.STREAM))
          (TYPE TCP.DEFAULTFILETYPE)
          RENAME.FROM.FILE LAST.COMMAND USERPORT)
         (OR PATH (SETQ PATH "{DSK}<LISPFILES>"))
         (while (AND (OPENP CONTROL.INPUT.STREAM 'INPUT)
                         (OPENP CONTROL.OUTPUT.STREAM 'OUTPUT)
                         (NOT (EOFP CONTROL.INPUT.STREAM)))
            first [PROCESSPROP (THIS.PROCESS)
                             'NAME
                             (CONCAT "FTP#" (\IP.ADDRESS.TO.STRING (fetch (TCP.CONTROL.BLOCK
                                                                               TCB.DST.HOST)
                                                                      of (fetch (TCPSTREAM
                                                                                         TCB)
                                                                                of 
                                                                                 CONTROL.INPUT.STREAM
                                                                                    ]
            do (LET [(COMMAND (U-CASE (CAR (NLSETQ (READ CONTROL.INPUT.STREAM COMMAND.RDTBL]
                        [COND
                           ((AND (OPENP CONTROL.INPUT.STREAM 'INPUT)
                                 (NOT (EOFP CONTROL.INPUT.STREAM)))
                            (COND
                               ([NOT (FMEMB COMMAND '(QUIT REIN ABOR NOOP NIL]
                                (BIN CONTROL.INPUT.STREAM]   (* Advance past the space preceding 
                                                           the argument)
                        (COND
                           (FTPDEBUGFLG (printout FTPDEBUGLOG T "> " COMMAND " ")))
                        (SELECTQ COMMAND
                            (USER (TCPFTP.SERVER.USER TCPFTPCON COMMAND.RDTBL))
                            (PASS (TCPFTP.SERVER.PASSWORD TCPFTPCON COMMAND.RDTBL))
                            (ACCT (TCPFTP.SERVER.ACCOUNT TCPFTPCON COMMAND.RDTBL))
                            (CWD (SETQ PATH (OR (TCPFTP.SERVER.PATH TCPFTPCON COMMAND.RDTBL PATH)
                                                PATH)))
                            (PWD (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Default pathname is " PATH)
                                        (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)))
                            (PORT (SETQ USERPORT (OR (TCPFTP.SERVER.PORT TCPFTPCON COMMAND.RDTBL)
                                                     USERPORT)))
                            (TYPE (SETQ TYPE (OR (TCPFTP.SERVER.TYPE TCPFTPCON COMMAND.RDTBL)
                                                 TYPE)))
                            (MODE (TCPFTP.SERVER.MODE TCPFTPCON COMMAND.RDTBL))
                            (STRU (TCPFTP.SERVER.STRUCTURE TCPFTPCON COMMAND.RDTBL))
                            (* ;; "Depending on the COMMAND (LIST -> verbose), TCPFTP.SERVER.LIST will return a verbose listing or a simple list of file names ")
                            ((NLST LIST)                     (* ; 
                                         "Depending on the COMMAND, TCPFTP.SERVER.LIST will return")
                                 (TCPFTP.SERVER.LIST TCPFTPCON COMMAND.RDTBL USERPORT PATH 
                                        COMMAND))
                            (RETR (TCPFTP.SERVER.RETRIEVE TCPFTPCON COMMAND.RDTBL USERPORT TYPE 
                                         PATH))
                            (STOR (TCPFTP.SERVER.STORE TCPFTPCON COMMAND.RDTBL USERPORT TYPE PATH
                                         ))
                            (APPE (TCPFTP.SERVER.APPEND TCPFTPCON COMMAND.RDTBL USERPORT TYPE 
                                         PATH))
                            (DELE (TCPFTP.SERVER.DELETE TCPFTPCON COMMAND.RDTBL PATH))
                            (RNFR (SETQ RENAME.FROM.FILE (TCPFTP.SERVER.RENAME.FROM TCPFTPCON 
                                                                COMMAND.RDTBL PATH)))
                            (RNTO (COND
                                     ((EQ LAST.COMMAND 'RNFR)
                                      (TCPFTP.SERVER.RENAME.TO TCPFTPCON COMMAND.RDTBL PATH 
                                             RENAME.FROM.FILE))
                                     (T (TCPFTP.SERVER.RESPONSE 503 
                                        "I need a RNFR command immediately preceding a RNTO command."
                                               CONTROL.OUTPUT.STREAM))))
                            (REIN (DISCARDLINE CONTROL.INPUT.STREAM)
                                  (TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTPCON)
                                  (TCPFTP.SERVER.RESPONSE 220 "Go ahead" CONTROL.OUTPUT.STREAM))
                            (QUIT (DISCARDLINE CONTROL.INPUT.STREAM)
                                  (TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTPCON)
                                  (TCPFTP.SERVER.RESPONSE 221 "It's been real" 
                                         CONTROL.OUTPUT.STREAM)
                                  (RETURN))
                            (NOOP (TCPFTP.SERVER.RESPONSE 200 "I'm still here" 
                                         CONTROL.OUTPUT.STREAM))
                            (NIL                             (* Error reading from control stream)
                                 (ERROR!))
                            (PROGN (DISCARDLINE CONTROL.INPUT.STREAM)
                                   (TCPFTP.SERVER.RESPONSE 502 (CONCAT "Unrecognized command " 
                                                                          COMMAND)
                                          CONTROL.OUTPUT.STREAM)))
                        (SETQ LAST.COMMAND COMMAND])

(TCPFTP.SERVER.CONNECTED.INFO
  [LAMBDA (PROCESS BUTTON)                                   (* ejs%: "21-Mar-86 17:07")
    [PROMPTPRINT "TCPFTP server connected to " (IPHOSTNAME (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST)
                                                              of (fetch (TCPSTREAM TCB) of 
                                                                                 CONTROL.INPUT.STREAM
                                                                        ]
    (COND
       ((EQ BUTTON 'MIDDLE)
        (COND
           ((AND (BOUNDP 'TCPFTPCON)
                 (fetch (TCPFTPCON BUSY?) of TCPFTPCON))
            (printout PROMPTWINDOW T "  Server is busy; last command was "
                   (OR (AND (BOUNDP 'COMMAND)
                            COMMAND)
                       "???")))
           ((AND (BOUNDP COMMAND)
                 COMMAND)
            (printout PROMPTWINDOW T "  Last command was " COMMAND])

(TCPFTP.SERVER.DELETE
  [LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH)                     (* ejs%: " 7-Apr-86 11:42")
          
          (* * This function parses USER commands)

    (LET* ((FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                            RDTBL))
           (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T T))
           TRUENAME)
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (COND
             [PACKED.FILENAME (COND
                                 ([SETQ TRUENAME (CAR (NLSETQ (DELFILE PACKED.FILENAME]
                                  (TCPFTP.SERVER.RESPONSE 250
                                         (CONCAT "Deleted " (COND
                                                               (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                                (REPACKFILENAME.STRING
                                                                 (PACKFILENAME.STRING 'HOST NIL
                                                                        'BODY TRUENAME)
                                                                 'TOPS-20))
                                                               (T TRUENAME)))
                                         (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)))
                                 (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't delete file " 
                                                                       TRUENAME)
                                           (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
             (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME)
                       (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.DIRECTORY
  [LAMBDA (TCPFTPCON RDTBL USERPORT DEFAULT.PATH COMMAND)
                                                           (* ; "Edited 30-Aug-90 17:47 by gadener")

         (* * This function parses USER commands)

    (LET* [(PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                        RDTBL))
           (FILES (CAR (NLSETQ (DIRECTORY (TCPFTP.SERVER.MERGE.PATHNAMES PATH DEFAULT.PATH T]
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG PATH T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening data connection for directory of " PATH 
                                                 " [" (LENGTH FILES)
                                                 " file name(s)]")
                 (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
          (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT)))
               (COND
                  (DATASTREAM (for FILE in FILES
                                 do (PRIN1 [COND
                                                  (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                   (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                           'HOST NIL 'BODY FILE)
                                                          'TOPS-20))
                                                  (T (TCPFTP.SERVER.RETURN.FILE FILE DEFAULT.PATH
                                                            'INFO]
                                               DATASTREAM)
                                       (TERPRI DATASTREAM) finally (
                                                                TCPFTP.SERVER.CLOSE.DATA.CONNECTION
                                                                        TCPFTPCON))
                         (TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch
                                                                                   (TCPFTPCON TCPOUT)
                                                                                     of TCPFTPCON
                                                                                   ])

(TCPFTP.SERVER.EXIT
  [LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM)       (* ejs%: "20-Mar-86 19:52")
    (CLOSEF? CONTROL.OUTPUT.STREAM)
    (CLOSEF? CONTROL.INPUT.STREAM])

(TCPFTP.SERVER.IDLE.INFO
  [LAMBDA (PROCESS BUTTON)                                   (* ejs%: "21-Mar-86 16:58")
    (PROMPTPRINT "Idle TCPFTP server"])

(TCPFTP.SERVER.LIST
  [LAMBDA (TCPFTPCON RDTBL USERPORT DEFAULT.PATH COMMAND)
                                                           (* ; "Edited 13-Sep-90 14:41 by gadener")

         (* * This function parses USER commands)

    (LET* ((PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                        RDTBL))
           [FILES (CAR (NLSETQ (DIRECTORY (TCPFTP.SERVER.MERGE.PATHNAMES PATH DEFAULT.PATH T]
           (NFILES (LENGTH FILES)))
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG PATH T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening data connection for directory " 
                                                 DEFAULT.PATH " [" NFILES " file name(s)]")
                 (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
          (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT)))
               (COND
                  (DATASTREAM (for FILE in FILES
                                 do (PRIN1 (COND
                                                  (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                   (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                           'HOST NIL 'BODY FILE)
                                                          'TOPS-20))
                                                  (T (TCPFTP.SERVER.RETURN.FILE FILE DEFAULT.PATH
                                                            COMMAND)))
                                               DATASTREAM)
                                       (TERPRI DATASTREAM) finally (
                                                                TCPFTP.SERVER.CLOSE.DATA.CONNECTION
                                                                        TCPFTPCON))
                         (TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch
                                                                                   (TCPFTPCON TCPOUT)
                                                                                     of TCPFTPCON
                                                                                   ])

(TCPFTP.SERVER.MERGE.PATHNAMES
  [LAMBDA (NAME DEFAULT.PATH NODEVICE.IF.LOCAL NOVERSION.IF.LOCAL DIRFLG)
                                                           (* ; "Edited 13-Sep-90 14:16 by gadener")
    (LET* ((NAMEFIELDS (UNPACKFILENAME.STRING NAME NIL DIRFLG))
           (DEFAULTFIELDS (UNPACKFILENAME.STRING DEFAULT.PATH NIL DIRFLG))
           [HOST (OR (LISTGET NAMEFIELDS 'HOST)
                     (LISTGET DEFAULTFIELDS 'HOST]
           [HOSTSPECIFIED (NOT (NULL (LISTGET NAMEFIELDS 'HOST]
           DIRECTORY1)
          (PACKFILENAME.STRING 'HOST HOST 'DEVICE [COND
                                                     ((AND NODEVICE.IF.LOCAL (EQ HOST 'DSK))
                                                      NIL)
                                                     ((OR (LISTGET NAMEFIELDS 'DEVICE)
                                                          (COND
                                                             (HOSTSPECIFIED NIL)
                                                             (T (LISTGET DEFAULTFIELDS 'DEVICE]
                 'DIRECTORY
                 [COND
                    ((LISTGET NAMEFIELDS 'DIRECTORY))
                    ([COND
                        [(SETQ DIRECTORY1 (LISTGET NAMEFIELDS 'SUBDIRECTORY]
                        ((SETQ DIRECTORY1 (LISTGET NAMEFIELDS 'RELATIVEDIRECTORY]
                     (CL:CONCATENATE 'STRING (LISTGET DEFAULTFIELDS 'DIRECTORY)
                            ">" DIRECTORY1))
                    (HOSTSPECIFIED NIL)
                    (T (LISTGET DEFAULTFIELDS 'DIRECTORY]
                 'NAME
                 (OR (LISTGET NAMEFIELDS 'NAME)
                     (LISTGET DEFAULTFIELDS 'NAME))
                 'EXTENSION
                 (OR (LISTGET NAMEFIELDS 'EXTENSION)
                     (LISTGET DEFAULTFIELDS 'EXTENSION))
                 'VERSION
                 (COND
                    ((AND NOVERSION.IF.LOCAL (EQ HOST 'DSK))
                     NIL)
                    (T (OR (LISTGET NAMEFIELDS 'VERSION)
                           (LISTGET DEFAULTFIELDS 'VERSION])

(TCPFTP.SERVER.MODE
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 15:38")
          
          (* * This function parses USER commands)

    (LET ((MODE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                      RDTBL))
          (RESPONSE.STRING)
          (ERRORFLG))
         (COND
            (FTPDEBUGFLG (printout FTPDEBUGLOG MODE T)))
         (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
         (SELECTQ MODE
             (S (SETQ RESPONSE.STRING "Now in stream mode"))
             (PROGN (SETQ RESPONSE.STRING (CONCAT "Unsupported mode - " MODE))
                    (SETQ ERRORFLG T)))
         (COND
            (ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT)
                                                                     of TCPFTPCON))
                   NIL)
            (T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.OPEN.DATA.CONNECTION
  [LAMBDA (TCPFTPCON USERPORT FORINPUT)                      (* ejs%: "11-Apr-86 16:09")
          
          (* * This function handles opening data connections and marking said tcp 
          connections as busy)

    (bind (TCB _ (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN) of TCPFTPCON)))
          DATASTREAM for RETRIES from 0 to TCPFTP.SERVER.RETRYCOUNT
       until (SETQ DATASTREAM (TCP.OPEN (COND
                                           (USERPORT (CAR USERPORT))
                                           (T (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST) of TCB)))
                                     (COND
                                        (USERPORT (CDR USERPORT))
                                        (T (fetch (TCP.CONTROL.BLOCK TCB.DST.PORT) of TCB)))
                                     (SUB1 (fetch (TCP.CONTROL.BLOCK TCB.SRC.PORT) of TCB))
                                     'ACTIVE
                                     (COND
                                        (FORINPUT 'INPUT)
                                        (T 'OUTPUT))
                                     T)) finally (RETURN (COND
                                                            (DATASTREAM (replace (TCPFTPCON 
                                                                                        DATASTREAM)
                                                                           of TCPFTPCON with 
                                                                                           DATASTREAM
                                                                               )
                                                                   (replace (TCPFTPCON BUSY?)
                                                                      of TCPFTPCON with (CREATE.EVENT
                                                                                         ))
                                                             (* TELNET standard EOL convention on 
                                                             DATASTREAMS)
                                                                   (SETFILEINFO DATASTREAM
                                                                          'EOL
                                                                          'CRLF)
                                                                   DATASTREAM)
                                                            (T (TCPFTP.SERVER.RESPONSE
                                                                426 "Couldn't open data connection"
                                                                (fetch (TCPFTPCON TCPOUT)
                                                                   of TCPFTPCON))
                                                               NIL])

(TCPFTP.SERVER.PARSE.PORT
  [LAMBDA (PSTRING)                                          (* ; "Edited 28-May-87 18:00 by jop")

(* ;;; "Parse a port string, in the form 'h1,h2,h3,h4,p1,p2' , where the hx are bytes from an internet host address, and the px are bytes from a 16-bit TCP port number")

    (LET ((IPADDRESS (CREATECELL \FIXP))
          (TCPPORT 0))
         (bind (BYTECOUNTER _ 0)
               (ACCUMULATOR _ 0)
               ERRORFLG for CH instring PSTRING do (COND
                                                      ((EQ CH (CHARCODE %,))
                                                       (COND
                                                          ((IGREATERP BYTECOUNTER 3)
                                                           (SETQ TCPPORT (IPLUS (ITIMES TCPPORT 256)
                                                                                ACCUMULATOR)))
                                                          (T (\PUTBASEBYTE IPADDRESS BYTECOUNTER 
                                                                    ACCUMULATOR)))
                                                       (SETQ ACCUMULATOR 0)
                                                       (add BYTECOUNTER 1))
                                                      [(AND (ILEQ CH (CHARCODE 9))
                                                            (IGEQ CH (CHARCODE 0)))
                                                       (SETQ ACCUMULATOR (IPLUS (IDIFFERENCE
                                                                                 CH
                                                                                 (CHARCODE 0))
                                                                                (ITIMES ACCUMULATOR 
                                                                                       10)))
                                                       (COND
                                                          ((IGREATERP ACCUMULATOR 255)
                                                           (SETQ ERRORFLG T)
                                                           (GO $$OUT]
                                                      (T (SETQ ERRORFLG T)
                                                         (GO $$OUT)))
            finally (COND
                       (ERRORFLG (RETURN NIL))
                       (T (COND
                             ((NEQ BYTECOUNTER 5)
                              (RETURN NIL))
                             (T (RETURN (CONS IPADDRESS (IPLUS (ITIMES TCPPORT 256)
                                                               ACCUMULATOR])

(TCPFTP.SERVER.PASSWORD
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 11:39")
          
          (* * This function parses USER commands)

    (LET ((PASS (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                       RDTBL)))
         (COND
            (FTPDEBUGFLG (printout FTPDEBUGLOG PASS T)))
         (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
         (TCPFTP.SERVER.RESPONSE 230 "OK, so you're logged in.  Now what?" (fetch (TCPFTPCON TCPOUT)
                                                                              of TCPFTPCON])

(TCPFTP.SERVER.PATH
  [LAMBDA (TCPFTPCON COMMAND.RDTBL OLDPATH)            (* ; "Edited 13-Sep-90 13:37 by gadener")
    (LET* ((PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                        COMMAND.RDTBL))
           (TRUEPATH (TCPFTP.SERVER.MERGE.PATHNAMES PATH OLDPATH NIL T 'RETURN))

           (* ;; "The last argument, RETURN, makes sure that even though a directory was specified as /a/b/c, we really meant /a/b/c")

           )
          (IF TRUEPATH
              THEN (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Default pathname now " TRUEPATH)
                              (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                    TRUEPATH
            else (TCPFTP.SERVER.RESPONSE 501 (CONCAT "Couldn't interpret " NEWPATH 
                                                            " as a pathname")
                            (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                  NIL])

(TCPFTP.SERVER.PORT
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 11:41")
    (LET* ((PORTSTRING (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                              RDTBL))
           (PARSEDPORT (TCPFTP.SERVER.PARSE.PORT PORTSTRING)))
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG PORTSTRING T)))
          (COND
             (PARSEDPORT (TCPFTP.SERVER.RESPONSE 200 (CONCAT "User port now " PORTSTRING)
                                (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                    PARSEDPORT)
             (T (TCPFTP.SERVER.RESPONSE 501 (CONCAT "Couldn't parse port specification " PORTSTRING)
                       (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                NIL])

(TCPFTP.SERVER.PROCESS
  [LAMBDA (PORT DEFAULT.FILE.PATH)                           (* ; "Edited 24-Aug-87 17:55 by scp")
          
          (* * This is the TCP-based FTP server top-level)

    (PROCESSPROP (THIS.PROCESS)
           'INFOHOOK
           (FUNCTION TCPFTP.SERVER.IDLE.INFO))
    (LET* ((CONTROL.INPUT.STREAM (TCP.OPEN NIL NIL (OR PORT \TCP.FTP.PORT)
                                        'PASSIVE
                                        'INPUT))
           (CONTROL.OUTPUT.STREAM (TCP.OTHER.STREAM CONTROL.INPUT.STREAM)))
                                                             (* EOL convention -> TELNET Standard)
          (SETFILEINFO CONTROL.OUTPUT.STREAM 'EOL 'CRLF)     (* Say hello quickly)
          (TCPFTP.SERVER.RESPONSE 220 TCPFTP.SERVER.HERALD.STRING CONTROL.OUTPUT.STREAM)
                                                             (* Spawn a new server)
          (ADD.PROCESS (LIST (FUNCTION TCPFTP.SERVER)
                             PORT
                             (KWOTE DEFAULT.FILE.PATH))
                 'RESTARTABLE
                 'HARDRESET)                                 (* Now that we're "established," 
                                                             errors are fatal)
          (PROCESSPROP (THIS.PROCESS)
                 'RESTARTABLE
                 'NO)
          (PROCESSPROP (THIS.PROCESS)
                 'INFOHOOK
                 (FUNCTION TCPFTP.SERVER.CONNECTED.INFO))
          (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM)
                                           (COND
                                              (RESETSTATE (TCPFTP.SERVER.ABORTED CONTROL.INPUT.STREAM 
                                                                 CONTROL.OUTPUT.STREAM))
                                              (T (TCPFTP.SERVER.EXIT CONTROL.INPUT.STREAM 
                                                        CONTROL.OUTPUT.STREAM]
                               CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM))
          (TCPFTP.SERVER.COMMAND.LOOP CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM DEFAULT.FILE.PATH])

(TCPFTP.SERVER.RENAME.FROM
  [LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH)                     (* ejs%: "24-Mar-86 14:16")
          
          (* * This function parses RNFR commands)

    (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                            RDTBL))
           (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
           (TRUENAME (CAR (NLSETQ (INFILEP PACKED.FILENAME]
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (COND
             (TRUENAME (TCPFTP.SERVER.RESPONSE 350 (CONCAT "About to rename "
                                                          (COND
                                                             (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                              (REPACKFILENAME.STRING
                                                               (PACKFILENAME.STRING 'HOST NIL
                                                                      'BODY TRUENAME)
                                                               'TOPS-20))
                                                             (T TRUENAME)))
                              (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                    TRUENAME)
             (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME)
                       (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                NIL])

(TCPFTP.SERVER.RENAME.TO
  [LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH FROM.FILE)           (* ejs%: "24-Mar-86 14:34")
          
          (* * This function parses RNTO commands)

    (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                            RDTBL))
           (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
           (TRUENAME (CAR (NLSETQ (OUTFILEP PACKED.FILENAME]
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (COND
             (TRUENAME (RENAMEFILE FROM.FILE TRUENAME)
                    (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Renamed "
                                                       (COND
                                                          (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                           (REPACKFILENAME.STRING (
                                                                                  PACKFILENAME.STRING
                                                                                   'HOST NIL
                                                                                   'BODY FROM.FILE)
                                                                  'TOPS-20))
                                                          (T FROM.FILE))
                                                       " to "
                                                       (COND
                                                          (TCPFTP.SERVER.USE.TOPS20.SYNTAX
                                                           (REPACKFILENAME.STRING (
                                                                                  PACKFILENAME.STRING
                                                                                   'HOST NIL
                                                                                   'BODY TRUENAME)
                                                                  'TOPS-20))
                                                          (T TRUENAME)))
                           (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)))
             (T (TCPFTP.SERVER.RESPONSE 553 (CONCAT "Couldn't make an output file named " 
                                                   PACKED.FILENAME)
                       (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.RESPONSE
  [LAMBDA (CODE STRING STREAM)                               (* edited%: "21-Mar-86 11:44")
    (RESETFORM (RADIX 10)
           (COND
              (FTPDEBUGFLG (printout FTPDEBUGLOG "> " CODE " " STRING T)))
           (printout STREAM CODE " " STRING T))
    (FORCEOUTPUT STREAM])

(TCPFTP.SERVER.RETRIEVE
  [LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH) (* ; "Edited 13-Sep-90 14:59 by gadener")

         (* * This function parses USER commands)

    (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                            RDTBL))
           (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
           (TRUENAME (CAR (NLSETQ (INFILEP PACKED.FILENAME]
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (COND
             [TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'INPUT 'OLD
                                                             `((TYPE %, TYPE]
                            (COND
                               [FILESTREAM
                                (TCPFTP.SERVER.RESPONSE
                                 150
                                 (CONCAT "Opening " TYPE " data connection for "
                                        (COND
                                           (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING
                                                                             (FULLNAME FILESTREAM)
                                                                             'TOPS-20))
                                           (T (FULLNAME FILESTREAM)))
                                        " ("
                                        [\IP.ADDRESS.TO.STRING
                                         (OR (CAR USERPORT)
                                             (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST)
                                                of (fetch (TCPSTREAM TCB)
                                                          of (fetch (TCPFTPCON TCPIN)
                                                                    of TCPFTPCON]
                                        ","
                                        [OR (CDR USERPORT)
                                            (fetch (TCP.CONTROL.BLOCK TCB.DST.PORT)
                                               of (fetch (TCPSTREAM TCB)
                                                         of (fetch (TCPFTPCON TCPIN)
                                                                   of TCPFTPCON]
                                        ") ("
                                        (OR (GETFILEINFO FILESTREAM 'LENGTH)
                                            0)
                                        " bytes).")
                                 (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                                (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON 
                                                         USERPORT)))
                                     (COND
                                        (DATASTREAM (LET [(RESULT (NLSETQ (COND
                                                                             ((EQ TYPE 'BINARY)
                                                                              (COPYBYTES FILESTREAM 
                                                                                     DATASTREAM))
                                                                             (T (COPYCHARS FILESTREAM
                                                                                       DATASTREAM]
                                                         (CLOSEF? FILESTREAM)
                                                         (TCPFTP.SERVER.CLOSE.DATA.CONNECTION
                                                          TCPFTPCON)
                                                         (COND
                                                            (RESULT (TCPFTP.SERVER.RESPONSE
                                                                     226 "Data transfer complete"
                                                                     (fetch (TCPFTPCON TCPOUT)
                                                                        of TCPFTPCON)))
                                                            (T (TCPFTP.SERVER.RESPONSE
                                                                426 
                                                               "Couldn't complete retrieve operation"
                                                                (fetch (TCPFTPCON TCPOUT)
                                                                   of TCPFTPCON]
                               (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " 
                                                                         TRUENAME)
                                         (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
             (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME)
                       (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.RETURN.FILE
  [LAMBDA (FILE DEFAULT.PATH COMMAND)                  (* ; "Edited 31-Aug-90 17:57 by gadener")

    (* ;; "If COMMAND is LIST , it will return a verbose listing of the file and some of its properties. If the command is NLIST, it will just return the filename with extension and version. ")

    (* ;; "Note that since the D-mahines don't have a true directory structure, it will return the relative pathname to the file , in relation to DEFAULT.PATH.")

    (LET* [(DEFAULT.PATH.STRING.LENGTH (NCHARS DEFAULT.PATH))
           (PATH (SUBSTRING FILE (PLUS 1 DEFAULT.PATH.STRING.LENGTH)))
           (TAB (CHARACTER (CHARCODE TAB]
          (COND
             ((EQUAL COMMAND 'LIST)
              (CONCAT (GETFILEINFO FILE 'TYPE)
                     TAB
                     (GETFILEINFO FILE 'LENGTH)
                     TAB
                     (GETFILEINFO FILE 'WRITEDATE)
                     TAB
                     (GETFILEINFO FILE 'AUTHOR)
                     TAB PATH))
             (T PATH])

(TCPFTP.SERVER.STORE
  [LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH)       (* ejs%: "24-Mar-86 15:27")
          
          (* * This function parses USER commands)

    (LET*
     [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                       RDTBL))
      (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T))
      (TRUENAME (CAR (NLSETQ (OUTFILEP PACKED.FILENAME]
     (COND
        (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T)))
     (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
     (COND
        [TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'OUTPUT 'NEW
                                                        `((TYPE %, TYPE]
                       (COND
                          [FILESTREAM
                           (TCPFTP.SERVER.RESPONSE 150 (CONCAT 
                                                              "Opening data connection for store of "
                                                              (FULLNAME FILESTREAM))
                                  (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                           (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT T
                                                    )))
                                (COND
                                   (DATASTREAM [replace (STREAM ENDOFSTREAMOP) of DATASTREAM
                                                  with (FUNCTION (LAMBDA (STREAM)
                                                                   (ERROR!]
                                          (RESETLST (RESETSAVE (COND
                                                                  ((EQ TYPE 'BINARY)
                                                                   (COPYBYTES DATASTREAM FILESTREAM))
                                                                  (T (COPYCHARS DATASTREAM FILESTREAM
                                                                            )))
                                                           (LIST [FUNCTION (LAMBDA (FILESTREAM 
                                                                                          TCPFTPCON)
                                                                             (CLOSEF? FILESTREAM)
                                                                             (
                                                                  TCPFTP.SERVER.CLOSE.DATA.CONNECTION
                                                                              TCPFTPCON)
                                                                             (TCPFTP.SERVER.RESPONSE
                                                                              226 
                                                                             "Data transfer complete"
                                                                              (fetch (TCPFTPCON
                                                                                      TCPOUT)
                                                                                 of TCPFTPCON]
                                                                 FILESTREAM TCPFTPCON]
                          (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " TRUENAME)
                                    (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]
        (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "Unable to create output filename - " PACKED.FILENAME)
                  (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.STRUCTURE
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 14:08")
          
          (* * This function parses USER commands)

    (LET ((STRUCTURE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                           RDTBL))
          (RESPONSE.STRING)
          (ERRORFLG))
         (COND
            (FTPDEBUGFLG (printout FTPDEBUGLOG STRUCTURE T)))
         (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
         (SELECTQ STRUCTURE
             (F (SETQ RESPONSE.STRING "Now in stream mode"))
             (PROGN (SETQ RESPONSE.STRING (CONCAT "Unsupported mode - " STRUCTURE))
                    (SETQ ERRORFLG T)))
         (COND
            (ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT)
                                                                     of TCPFTPCON))
                   NIL)
            (T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.TYPE
  [LAMBDA (TCPFTPCON RDTBL)                                  (* ejs%: "24-Mar-86 15:26")
          
          (* * This function parses USER commands)

    (LET* ((MAJOR.TYPE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                             RDTBL))
           [MINOR.TYPE (LET [(TERM.CHAR (BIN (fetch (TCPFTPCON TCPIN) of TCPFTPCON]
                            (COND
                               ((EQ TERM.CHAR (CHARCODE SPACE))
                                (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                                      RDTBL))
                               (T (SELECTQ MAJOR.TYPE
                                      (A 'N)
                                      (L 8)
                                      NIL]
           (RESPONSE.STRING)
           (ERRORFLG))
          (COND
             (FTPDEBUGFLG (printout FTPDEBUGLOG MAJOR.TYPE " " MINOR.TYPE T)))
          (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
          (SELECTQ MAJOR.TYPE
              (A (SELECTQ MINOR.TYPE
                     (N (SETQ RESPONSE.STRING "Type is now standard ASCII"))
                     (PROGN (SETQ RESPONSE.STRING (CONCAT "ASCII subtype " MINOR.TYPE 
                                                         " not recognized"))
                            (SETQ ERRORFLG T))))
              (E (SETQ RESPONSE.STRING "EBCDIC not supported")
                 (SETQ ERRORFLG T))
              (I (SETQ RESPONSE.STRING "Type is now 8-bit binary"))
              (L (COND
                    ((NEQ MINOR.TYPE 8)
                     (SETQ RESPONSE.STRING (CONCAT "Binary byte size " MINOR.TYPE " not supported"))
                     (SETQ ERRORFLG T))
                    (T (SETQ RESPONSE.STRING "Type is now 8-bit binary"))))
              NIL)
          (COND
             (ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT)
                                                                      of TCPFTPCON))
                    NIL)
             (T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))
                (SELECTQ MAJOR.TYPE
                    (A 'TEXT)
                    'BINARY])

(TCPFTP.SERVER.USER
  [LAMBDA (TCPFTPCON RDTBL)                                  (* edited%: "21-Mar-86 11:39")
          
          (* * This function parses USER commands)

    (LET ((USER (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON)
                       RDTBL)))
         (COND
            (FTPDEBUGFLG (printout FTPDEBUGLOG USER T)))
         (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON))
         (TCPFTP.SERVER.RESPONSE 230 "Hi, there!" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON])

(TCPFTP.SERVER.VERBOSE.LIST
  [LAMBDA (FILE STREAM)                                      (* edited%: "26-Mar-86 11:32")
    (printout STREAM (COND
                        (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING (PACKFILENAME.STRING
                                                                                 'HOST NIL
                                                                                 'BODY
                                                                                 (FULLNAME FILE))
                                                                'TOPS-20))
                        (T (FULLNAME FILE)))
           ";P775252;AFORYOURSELF,"
           (FOLDHI (OR (GETFILEINFO FILE 'SIZE)
                       0)
                  4)
           ","
           (GETFILEINFO FILE 'CREATIONDATE)
           ","
           (GETFILEINFO FILE 'WRITEDATE)
           T])

(TCPFTP.SERVER.WAIT.FOR.IDLE
  [LAMBDA (TCPFTPCON)                                        (* ejs%: "20-Mar-86 16:39")
    (bind BUSY? while (SETQ BUSY? (fetch (TCPFTPCON BUSY?) of TCPFTPCON)) do (AWAIT.EVENT BUSY?])

(TCPFTP.UNIX.LS.DATE
  [LAMBDA (FILE)                                             (* edited%: "21-Mar-86 13:38")
    (LET* [(CREATIONDATE (GETFILEINFO FILE 'CREATIONDATE))
           (MONTHPOS (STRPOS "-" CREATIONDATE))
           (YEARPOS (STRPOS "-" CREATIONDATE (ADD1 MONTHPOS)))
           (TIMEPOS (ADD1 (STRPOS " " CREATIONDATE]
          (CONCAT (SUBSTRING CREATIONDATE (ADD1 MONTHPOS)
                         (SUB1 YEARPOS))
                 " "
                 (SUBSTRING CREATIONDATE 1 (SUB1 MONTHPOS))
                 " "
                 (SUBSTRING CREATIONDATE TIMEPOS -4])
)

(RPAQ? TCPFTP.SERVER.HERALD.STRING "Venue Medley FTP Service 1.0 at your service")

(RPAQ? TCPFTP.SERVER.USE.TOPS20.SYNTAX NIL)

(RPAQ? TCPFTP.SERVER.RETRYCOUNT 5)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS TCPFTP.SERVER.HERALD.STRING TCPFTP.SERVER.USE.TOPS20.SYNTAX TCPFTP.SERVER.RETRYCOUNT)
)

(FILESLOAD (SYSLOAD)
       TCPFTP)
(PUTPROPS TCPFTPSRV COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1782 54890 (TCPFTP.SERVER 1792 . 2089) (TCPFTP.SERVER.ABORTED 2091 . 2263) (
TCPFTP.SERVER.ACCOUNT 2265 . 2817) (TCPFTP.SERVER.APPEND 2819 . 6531) (
TCPFTP.SERVER.CLOSE.DATA.CONNECTION 6533 . 7031) (TCPFTP.SERVER.COMMAND.LOOP 7033 . 13702) (
TCPFTP.SERVER.CONNECTED.INFO 13704 . 14690) (TCPFTP.SERVER.DELETE 14692 . 16577) (
TCPFTP.SERVER.DIRECTORY 16579 . 18921) (TCPFTP.SERVER.EXIT 18923 . 19115) (TCPFTP.SERVER.IDLE.INFO 
19117 . 19282) (TCPFTP.SERVER.LIST 19284 . 21609) (TCPFTP.SERVER.MERGE.PATHNAMES 21611 . 23718) (
TCPFTP.SERVER.MODE 23720 . 24743) (TCPFTP.SERVER.OPEN.DATA.CONNECTION 24745 . 27732) (
TCPFTP.SERVER.PARSE.PORT 27734 . 30442) (TCPFTP.SERVER.PASSWORD 30444 . 31090) (TCPFTP.SERVER.PATH 
31092 . 32075) (TCPFTP.SERVER.PORT 32077 . 32886) (TCPFTP.SERVER.PROCESS 32888 . 35079) (
TCPFTP.SERVER.RENAME.FROM 35081 . 36653) (TCPFTP.SERVER.RENAME.TO 36655 . 39136) (
TCPFTP.SERVER.RESPONSE 39138 . 39457) (TCPFTP.SERVER.RETRIEVE 39459 . 44526) (
TCPFTP.SERVER.RETURN.FILE 44528 . 45581) (TCPFTP.SERVER.STORE 45583 . 49232) (TCPFTP.SERVER.STRUCTURE 
49234 . 50287) (TCPFTP.SERVER.TYPE 50289 . 52577) (TCPFTP.SERVER.USER 52579 . 53118) (
TCPFTP.SERVER.VERBOSE.LIST 53120 . 54036) (TCPFTP.SERVER.WAIT.FOR.IDLE 54038 . 54285) (
TCPFTP.UNIX.LS.DATE 54287 . 54888)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPHTE b/obsolete/tcp/TCPHTE
deleted file mode 100644
index dda05d9a..00000000
--- a/obsolete/tcp/TCPHTE
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP")
(FILECREATED "12-Jun-90 17:31:06" {DSK}<usr>local>lde>lispcore>library>TCPHTE.;3 5753   

      changes to%:  (VARS TCPHTECOMS)

      previous date%: "11-Feb-89 11:06:54" {DSK}<usr>local>lde>lispcore>library>TCPHTE.;2)


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

(PRETTYCOMPRINT TCPHTECOMS)

(RPAQQ TCPHTECOMS
       ((PROP MAKEFILE-ENVIRONMENT TCPHTE)
        (RECORDS HOSTS.TXT.ENTRY)
        (FNS \HTE.PARSE.ENTRY \HTE.READ.FILE \HTE.READ; \HTE.READLINE)
        (INITVARS (HOSTS.TEXT.DIRECTORIES)
               (\HTE.RDTBL))
        (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \HTE.RDTBL \IP.HOSTNAMES)
               (RECORDS HTELINE))))

(PUTPROPS TCPHTE MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP"))
(DECLARE%: EVAL@COMPILE

(DATATYPE HOSTS.TXT.ENTRY (HTE.TYPE HTE.ADDRESSES HTE.NAMES HTE.MACHINE.TYPE HTE.OS.TYPE 
                                     HTE.PROTOCOLS))
)

(/DECLAREDATATYPE 'HOSTS.TXT.ENTRY '(POINTER POINTER POINTER POINTER POINTER POINTER)
       '((HOSTS.TXT.ENTRY 0 POINTER)
         (HOSTS.TXT.ENTRY 2 POINTER)
         (HOSTS.TXT.ENTRY 4 POINTER)
         (HOSTS.TXT.ENTRY 6 POINTER)
         (HOSTS.TXT.ENTRY 8 POINTER)
         (HOSTS.TXT.ENTRY 10 POINTER))
       '12)
(DEFINEQ

(\HTE.PARSE.ENTRY
  [LAMBDA (ENTRY)                                        (* ; "Edited 11-Feb-89 11:04 by akw:")
    (DECLARE (GLOBALVARS NETWORKOSTYPES))
    (LET* [[NAMES (for NAME in (fetch (HTELINE NAMES) of ENTRY)
                     collect (MKATOM (U-CASE NAME]
           (OSTYPE (CAR (fetch (HTELINE OS.TYPE) of ENTRY))
                  (MKATOM (U-CASE)))
           (HTE.ENTRY (create HOSTS.TXT.ENTRY
                             HTE.TYPE _ (CAR (fetch (HTELINE TYPE) of ENTRY))
                             HTE.ADDRESSES _ (for X in (fetch (HTELINE ADDRESSES)
                                                                  of ENTRY)
                                                collect (\IP.READ.STRING.ADDRESS X))
                             HTE.NAMES _ NAMES
                             HTE.MACHINE.TYPE _ [MKATOM (U-CASE (CAR (fetch (HTELINE MACHINE.TYPE
                                                                                       ) of
                                                                                         ENTRY]
                             HTE.OS.TYPE _ [AND OSTYPE (SETQ OSTYPE (MKATOM (U-CASE OSTYPE]
                             HTE.PROTOCOLS _ (for PROTOENTRY in (fetch (HTELINE PROTOCOLS
                                                                                          )
                                                                           of ENTRY) bind
                                                                                         SLASH
                                                when (SETQ SLASH (STRPOS '/ PROTOENTRY))
                                                collect (CONS (SUBATOM PROTOENTRY 1 (SUB1 SLASH))
                                                                  (SUBATOM PROTOENTRY (ADD1 SLASH]
          (for NAME in NAMES do (PUTHASH NAME HTE.ENTRY \IP.HOSTNAMES])

(\HTE.READ.FILE
(LAMBDA (FILE WANTEDTYPES) (* ; "Edited 24-May-88 16:57 by bvm") (DECLARE (GLOBALVARS \IP.HOSTNAMES \TCP.LAST.HOSTS.FILE.DATE \TCP.LAST.HOSTS.FILE.READ)) (OR WANTEDTYPES (SETQ WANTEDTYPES (QUOTE (HOST)))) (CL:WITH-OPEN-FILE (STREAM FILE) (LET ((FILENAME (FULLNAME STREAM)) (DATE (GETFILEINFO STREAM (QUOTE ICREATIONDATE))) ENTRY) (PRINTOUT PROMPTWINDOW T "Reading " FILENAME " of " (GDATE DATE (DATEFORMAT NO.SECONDS))) (CLRHASH \IP.HOSTNAMES) (until (EOFP STREAM) when (AND (SETQ ENTRY (\HTE.READLINE STREAM WANTEDTYPES)) (FMEMB (CAR (fetch (HTELINE TYPE) of ENTRY)) WANTEDTYPES)) do (\HTE.PARSE.ENTRY ENTRY)) (SETQ \TCP.LAST.HOSTS.FILE.DATE DATE) (SETQ \TCP.LAST.HOSTS.FILE.READ FILENAME))))
)

(\HTE.READ;
(LAMBDA (FL RDTBL) (* ; "Edited 24-May-88 14:45 by bvm") (until (SELCHARQ (READCCODE FL) ((CR LF EOL) T) NIL)) NIL)
)

(\HTE.READLINE
(LAMBDA (STREAM WANTEDTYPES) (* ; "Edited 24-May-88 16:57 by bvm") (while (EQ (PEEKCCODE STREAM T) (CHARCODE ";")) do (\HTE.READ; STREAM)) (AND (NOT (EOFP STREAM)) (for FIELD# from 1 bind FIELDCONTENTS DONE (RDTBL _ (COND (\HTE.RDTBL) (T (SETQ \HTE.RDTBL (COPYREADTABLE (QUOTE ORIG))) (SETSEPR (CHARCODE (SPACE TAB %,)) NIL \HTE.RDTBL) (SETBRK (CHARCODE (":" ";" CR LF)) NIL \HTE.RDTBL) (READTABLEPROP \HTE.RDTBL (QUOTE CASEINSENSITIVE) T) \HTE.RDTBL))) until DONE collect (SETQ FIELDCONTENTS (until (SELCHARQ (SKIPSEPRCODES STREAM RDTBL) (":" (* ; "End of field") (READCCODE STREAM) T) (";" (* ; "end of line") (\HTE.READ; STREAM) (SETQ DONE T)) ((CR LF) (* ; "end of line--consume the terminator") (READCCODE STREAM) (SETQ DONE T)) (NIL (* ; "Eof") (SETQ DONE T)) NIL) collect (* ; "Read up to the next field delimiter") (if (EQ FIELD# 1) then (* ; "Canonicalize the type field") (READ STREAM RDTBL) else (RSTRING STREAM RDTBL)))) (if (AND (EQ FIELD# 1) WANTEDTYPES (NOT (FMEMB (CAR FIELDCONTENTS) WANTEDTYPES))) then (* ; "Don't care about this line") (OR DONE (\HTE.READ; STREAM)) (RETURN NIL)) FIELDCONTENTS)))
)
)

(RPAQ? HOSTS.TEXT.DIRECTORIES )

(RPAQ? \HTE.RDTBL )
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \HTE.RDTBL \IP.HOSTNAMES)
)

(DECLARE%: EVAL@COMPILE

(RECORD HTELINE (TYPE ADDRESSES NAMES MACHINE.TYPE OS.TYPE PROTOCOLS))
)
)
(PUTPROPS TCPHTE COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1360 5370 (\HTE.PARSE.ENTRY 1370 . 3378) (\HTE.READ.FILE 3380 . 4095) (\HTE.READ; 4097
 . 4230) (\HTE.READLINE 4232 . 5368)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPIP.TEDIT b/obsolete/tcp/TCPIP.TEDIT
deleted file mode 100644
index 11c83753..00000000
Binary files a/obsolete/tcp/TCPIP.TEDIT and /dev/null differ
diff --git a/obsolete/tcp/TCPLLAR b/obsolete/tcp/TCPLLAR
deleted file mode 100644
index 12e028d3..00000000
--- a/obsolete/tcp/TCPLLAR
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Aug-90 12:32:20" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCPLLAR.;3 22788  

      changes to%:  (FNS \AR.DAEMON \AR.ENTER.RESOLUTION \AR.NOTE.RESOLUTION \AR.UPDATE.RESOLUTION 
                         \PRINTAR SPUTASSOC \AR.TRANSLATE.TO.10MB \AR.REQUEST.IP.TO.10MB 
                         \AR.REQUEST.IP.TO.3MB \AR.RESOLVE \AR.TRANSLATE.TO.3MB \HANDLE.RAW.AR)

      previous date%: " 6-Jan-89 15:18:06" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCPLLAR.;2)


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

(PRETTYCOMPRINT TCPLLARCOMS)

(RPAQQ TCPLLARCOMS [(COMS 

(* ;;; "IP Ethernet address translation module")

                              [DECLARE%: DONTCOPY (EXPORT (RECORDS AR ARETHER AREXPETHER ARENTRY)
                                                         (CONSTANTS (\AR.HARDWARE.SPACE.ETHERNET
                                                                     1)
                                                                (\AR.ETHERNET.ADDRESS.LENGTH 6)
                                                                (\AR.IP.ADDRESS.LENGTH 4)
                                                                (\AR.REQUEST 1)
                                                                (\AR.RESPONSE 2)
                                                                (\AR.ETHER.PACKET.LENGTH 28]
                              (INITRECORDS ARENTRY)
                              (INITVARS (\AR.IP.TO.10MB.ALIST (CONS))
                                     (\AR.SEARCH.TIMEOUT.INTERVAL 300000)
                                     (\AR.VALID.TIMEOUT.INTERVAL 600000))
                              (GLOBALVARS \AR.IP.TO.10MB.ALIST \AR.SEARCH.TIMEOUT.INTERVAL 
                                     \AR.VALID.TIMEOUT.INTERVAL)
                              (FNS \AR.DAEMON \AR.ENTER.RESOLUTION \AR.NOTE.RESOLUTION 
                                   \AR.UPDATE.RESOLUTION \PRINTAR SPUTASSOC \AR.TRANSLATE.TO.10MB 
                                   \AR.REQUEST.IP.TO.10MB \AR.REQUEST.IP.TO.3MB \AR.RESOLVE 
                                   \AR.TRANSLATE.TO.3MB \HANDLE.RAW.AR)
                              (ADDVARS (\PACKET.PRINTERS (2054 . \PRINTAR])



(* ;;; "IP Ethernet address translation module")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS AR [(ARBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM]
                  [BLOCKRECORD ARBASE ((ARHARDWARESPACE WORD)
                                       (ARPROTOCOLSPACE WORD)
                                       (ARHARDWARELEN BYTE)
                                       (ARPROTOCOLLEN BYTE)
                                       (AROPCODE WORD)
                                       (AR1STWORD WORD))
                         (ACCESSFNS AR1STWORD ((ARCONTENTS (LOCF DATUM])

(ACCESSFNS ARETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM)))
                       [BLOCKRECORD ARETHERBASE ((ARLCLHDW0 WORD)
                                                 (ARLCLHDW1 WORD)
                                                 (ARLCLHDW2 WORD)
                                                 (ARLCLPTCL FIXP)
                                                 (ARFRNHDW0 WORD)
                                                 (ARFRNHDW1 WORD)
                                                 (ARFRNHDW2 WORD)
                                                 (ARFRNPTCL FIXP))
                              [ACCESSFNS ARLCLHDW0 ((ARSENDERHDW (\LOADNSHOSTNUMBER (LOCF DATUM))
                                                           (\STORENSHOSTNUMBER (LOCF DATUM)
                                                                  NEWVALUE]
                              (ACCESSFNS ARFRNHDW0 ((ARTARGETHDW (\LOADNSHOSTNUMBER (LOCF DATUM))
                                                           (\STORENSHOSTNUMBER (LOCF DATUM)
                                                                  NEWVALUE])

(ACCESSFNS AREXPETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM)))
                          (BLOCKRECORD ARETHERBASE ((ARLCLHDW WORD)
                                                    (ARLCLPTCL FIXP)
                                                    (ARFRNHDW WORD)
                                                    (ARFRNPTCL FIXP))))

(DATATYPE ARENTRY ((RECENT FLAG)
                       (SEARCHING FLAG)
                       (IPADDRESS POINTER)
                       (ETHERADDRESS POINTER)
                       (TIMER POINTER))
                      TIMER _ (NCREATE 'FIXP))
)

(/DECLAREDATATYPE 'ARENTRY '(FLAG FLAG POINTER POINTER POINTER)
       '((ARENTRY 0 (FLAGBITS . 0))
         (ARENTRY 0 (FLAGBITS . 16))
         (ARENTRY 0 POINTER)
         (ARENTRY 2 POINTER)
         (ARENTRY 4 POINTER))
       '6)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \AR.HARDWARE.SPACE.ETHERNET 1)

(RPAQQ \AR.ETHERNET.ADDRESS.LENGTH 6)

(RPAQQ \AR.IP.ADDRESS.LENGTH 4)

(RPAQQ \AR.REQUEST 1)

(RPAQQ \AR.RESPONSE 2)

(RPAQQ \AR.ETHER.PACKET.LENGTH 28)


(CONSTANTS (\AR.HARDWARE.SPACE.ETHERNET 1)
       (\AR.ETHERNET.ADDRESS.LENGTH 6)
       (\AR.IP.ADDRESS.LENGTH 4)
       (\AR.REQUEST 1)
       (\AR.RESPONSE 2)
       (\AR.ETHER.PACKET.LENGTH 28))
)

(* "END EXPORTED DEFINITIONS")

)

(/DECLAREDATATYPE 'ARENTRY '(FLAG FLAG POINTER POINTER POINTER)
       '((ARENTRY 0 (FLAGBITS . 0))
         (ARENTRY 0 (FLAGBITS . 16))
         (ARENTRY 0 POINTER)
         (ARENTRY 2 POINTER)
         (ARENTRY 4 POINTER))
       '6)

(RPAQ? \AR.IP.TO.10MB.ALIST (CONS))

(RPAQ? \AR.SEARCH.TIMEOUT.INTERVAL 300000)

(RPAQ? \AR.VALID.TIMEOUT.INTERVAL 600000)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \AR.IP.TO.10MB.ALIST \AR.SEARCH.TIMEOUT.INTERVAL \AR.VALID.TIMEOUT.INTERVAL)
)
(DEFINEQ

(\AR.DAEMON
  [LAMBDA NIL                                            (* ejs%: "25-Jun-85 18:47")
    (for ARENTRY in \AR.IP.TO.10MB.ALIST do (\AR.UPDATE.RESOLUTION ARENTRY)
                                                       (BLOCK])

(\AR.ENTER.RESOLUTION
  [LAMBDA (IPADDRESS ETHERADDRESS ONLY-IF-PRESENT-P)    (* ; "Edited 21-Dec-88 20:10 by Briggs")

         (* * Enter a new resolution in the AR table, or update an existing resolution)

    (LET [(OLDENTRY (find ENTRY in \AR.IP.TO.10MB.ALIST
                       suchthat (EQUAL IPADDRESS (fetch (ARENTRY IPADDRESS) of ENTRY]
         (COND
            (OLDENTRY (freplace (ARENTRY TIMER) of OLDENTRY with
                                                                    (SETUPTIMER 
                                                                           \AR.VALID.TIMEOUT.INTERVAL
                                                                           (ffetch (ARENTRY
                                                                                        TIMER)
                                                                              of OLDENTRY)))
                   (freplace (ARENTRY ETHERADDRESS) of OLDENTRY with ETHERADDRESS)
                   (freplace (ARENTRY RECENT) of OLDENTRY with T)
                   (freplace (ARENTRY SEARCHING) of OLDENTRY with NIL)
                   OLDENTRY)
            ((NOT ONLY-IF-PRESENT-P)
             (CAR (push \AR.IP.TO.10MB.ALIST (create ARENTRY
                                                        IPADDRESS _ IPADDRESS
                                                        ETHERADDRESS _ ETHERADDRESS
                                                        TIMER _ (SETUPTIMER 
                                                                       \AR.VALID.TIMEOUT.INTERVAL)
                                                        RECENT _ T])

(\AR.NOTE.RESOLUTION
  [LAMBDA (AR)                                          (* ; "Edited 21-Dec-88 20:11 by Briggs")

(* ;;; "Use the information in the AR to update any existing entry in the cache, and if this was a response (presumably to our query) add the new information.")

    [COND
       ((NOT (AND (EQ (fetch (ARETHER ARLCLHDW0) of AR)
                      0)
                  (EQ (fetch (ARETHER ARLCLHDW1) of AR)
                      0)
                  (EQ (fetch (ARETHER ARLCLHDW2) of AR)
                      0)))
        (\AR.ENTER.RESOLUTION (fetch (ARETHER ARLCLPTCL) of AR)
               (fetch (ARETHER ARSENDERHDW) of AR)
               (NOT (MEMBER (fetch (ARETHER ARFRNPTCL) of AR)
                           \IP.LOCAL.ADDRESSES]
    (COND
       ([AND (EQ (fetch (AR AROPCODE) of AR)
                 \AR.RESPONSE)
             (NOT (AND (EQ (fetch (ARETHER ARFRNHDW0) of AR)
                           0)
                       (EQ (fetch (ARETHER ARFRNHDW1) of AR)
                           0)
                       (EQ (fetch (ARETHER ARFRNHDW2) of AR)
                           0]
        (\AR.ENTER.RESOLUTION (fetch (ARETHER ARFRNPTCL) of AR)
               (fetch (ARETHER ARTARGETHDW) of AR])

(\AR.UPDATE.RESOLUTION
  [LAMBDA (ARENTRY)                                     (* ; "Edited 21-Dec-88 18:27 by Briggs")

(* ;;; "Called when a resolution is no longer recent.  Does ARP requests to update our cache.  Eventually, the entry is marked invalid and is removed")

    (COND
       [(TIMEREXPIRED? (fetch (ARENTRY TIMER) of ARENTRY))
        (COND
           ((ffetch (ARENTRY RECENT) of ARENTRY)
            (freplace (ARENTRY RECENT) of ARENTRY with NIL)
            (freplace (ARENTRY SEARCHING) of ARENTRY with T)
            (freplace (ARENTRY TIMER) of ARENTRY with (SETUPTIMER 
                                                                         \AR.SEARCH.TIMEOUT.INTERVAL
                                                                         (ffetch (ARENTRY TIMER)
                                                                            of ARENTRY)))

            (* ;; 
          "ask the system in the table to respond to avoid clogging the net with broadcasts")

            (\AR.REQUEST.IP.TO.10MB (ffetch (ARENTRY IPADDRESS) of ARENTRY)
                   (ffetch (ARENTRY ETHERADDRESS) of ARENTRY)))
           ((ffetch (ARENTRY SEARCHING) of ARENTRY)
            (SETQ \AR.IP.TO.10MB.ALIST (DREMOVE ARENTRY \AR.IP.TO.10MB.ALIST]
       ((ffetch (ARENTRY SEARCHING) of ARENTRY)
        (\AR.REQUEST.IP.TO.10MB (ffetch (ARENTRY IPADDRESS) of ARENTRY)
               (ffetch (ARENTRY ETHERADDRESS) of ARENTRY])

(\PRINTAR
  [LAMBDA (AR CALLER FILE)                               (* ejs%: " 2-Jun-85 13:58")
    (PROG NIL
          (SELECTC (fetch (ETHERPACKET EPTYPE) of AR)
              (\EPT.AR NIL)
              (3 (RETURN))
              (RETURN))
          (COND
             ((AND (EQ (fetch (AR ARHARDWARESPACE) of AR)
                       \AR.HARDWARE.SPACE.ETHERNET)
                   (EQ (fetch (AR ARHARDWARELEN) of AR)
                       \AR.ETHERNET.ADDRESS.LENGTH)
                   (EQ (fetch (AR ARPROTOCOLSPACE) of AR)
                       \EPT.IP)
                   (EQ (fetch (AR ARPROTOCOLLEN) of AR)
                       \AR.IP.ADDRESS.LENGTH))
              (printout FILE CALLER ": Address resolution " (SELECTC (fetch (AR AROPCODE)
                                                                        of AR)
                                                                (\AR.REQUEST "request.")
                                                                (\AR.RESPONSE "response.")
                                                                "unknown opcode.")
                     T "Sender's protocol address is " (\IP.ADDRESS.TO.STRING (fetch (ARETHER
                                                                                          ARLCLPTCL)
                                                                                 of AR))
                     "." T "Sender's hardware address is " (fetch (ARETHER ARSENDERHDW)
                                                              of AR)
                     "." T)
              (SELECTC (fetch (AR AROPCODE) of AR)
                  (\AR.REQUEST (printout FILE "Sender desires hardware address for "
                                      (\IP.ADDRESS.TO.STRING (fetch (ARETHER ARFRNPTCL)
                                                                of AR))
                                      T))
                  (\AR.RESPONSE (printout FILE "Sender says hardware address for "
                                       (\IP.ADDRESS.TO.STRING (fetch (ARETHER ARFRNPTCL)
                                                                 of AR))
                                       T "  is " (fetch (ARETHER ARTARGETHDW) of AR)
                                       T))
                  NIL)))
          (TERPRI FILE])

(SPUTASSOC
  [LAMBDA (KEY VAL ALIST)                                (* ejs%: "27-Dec-84 17:52")
    (PROG (OLDENTRY)
          [COND
             ([SETQ OLDENTRY (for ENTRY in ALIST thereis (EQUAL KEY (CAR ENTRY]
              (RPLACD OLDENTRY VAL))
             (T (NCONC1 ALIST (CONS KEY VAL]
          (RETURN VAL])

(\AR.TRANSLATE.TO.10MB
  [LAMBDA (IPADDRESS DONTPROBE)                         (* ; "Edited 21-Dec-88 20:11 by Briggs")

(* ;;; "Translate an IPADDRESS to a 10MBHOSTNUMBER, or initiate request and fail for now")

    (COND
       ((\IP.BROADCAST.ADDRESS IPADDRESS)
        BROADCASTNSHOSTNUMBER)
       [(bind FOUNDIT find ENTRY in \AR.IP.TO.10MB.ALIST
           suchthat (AND (EQUAL IPADDRESS (fetch (ARENTRY IPADDRESS) of ENTRY))
                             (SETQ FOUNDIT T)) finally (COND
                                                              (FOUNDIT (RETURN (ffetch
                                                                                (ARENTRY ETHERADDRESS
                                                                                       ) of
                                                                                         ENTRY]
       ((NOT DONTPROBE)
        (\AR.REQUEST.IP.TO.10MB IPADDRESS)
        NIL])

(\AR.REQUEST.IP.TO.10MB
  [LAMBDA (IPADDRESS PDH)                               (* ; "Edited 21-Dec-88 18:31 by Briggs")

(* ;;; 
"Request an address translation, either from the specified host, or  by broadcasting the request.")

    (PROG ((AR (\ALLOCATE.ETHERPACKET)))
          (replace (AR ARHARDWARESPACE) of AR with \AR.HARDWARE.SPACE.ETHERNET)
          (replace (AR ARPROTOCOLSPACE) of AR with \EPT.IP)
          (replace (AR ARHARDWARELEN) of AR with \AR.ETHERNET.ADDRESS.LENGTH)
          (replace (AR ARPROTOCOLLEN) of AR with \AR.IP.ADDRESS.LENGTH)
          (replace (AR AROPCODE) of AR with \AR.REQUEST)
          (replace (ARETHER ARSENDERHDW) of AR with \MY.NSHOSTNUMBER)
          (replace (ARETHER ARLCLPTCL) of AR with (ffetch (NDB NDBIPHOST#)
                                                                 of \10MBLOCALNDB))
          (replace (ARETHER ARFRNPTCL) of AR with IPADDRESS)
          (replace (ETHERPACKET EPTYPE) of AR with \EPT.AR)
          (ENCAPSULATE.ETHERPACKET \10MBLOCALNDB AR (OR PDH BROADCASTNSHOSTNUMBER)
                 \AR.ETHER.PACKET.LENGTH \EPT.AR)
          (COND
             ((EQ IPTRACEFLG T)
              (PRINTPACKET AR 'PUT IPTRACEFILE))
             (IPTRACEFLG (PRIN1 (COND
                                   (PDH "!")
                                   (T "^"))
                                IPTRACEFILE)))
          (TRANSMIT.ETHERPACKET \10MBLOCALNDB AR])

(\AR.REQUEST.IP.TO.3MB
  [LAMBDA (IPADDRESS)                                    (* ejs%: " 2-Jan-85 17:12")

         (* * Broadcast a request for an address translation)

    (PROG ((AR (\ALLOCATE.ETHERPACKET)))
          (replace (AR ARHARDWARESPACE) of AR with \AR.HARDWARE.SPACE.ETHERNET)
          (replace (AR ARPROTOCOLSPACE) of AR with \EET.IP)
          (replace (AR ARHARDWARELEN) of AR with 2)
          (replace (AR ARPROTOCOLLEN) of AR with \AR.IP.ADDRESS.LENGTH)
          (replace (AR AROPCODE) of AR with \AR.REQUEST)
          (replace (AREXPETHER ARLCLHDW) of AR with (LOGAND \LOCALPUPNETHOST
                                                                       (MASK.1'S 0 8)))
          (replace (AREXPETHER ARLCLPTCL) of AR with (ffetch (NDB NDBIPHOST#)
                                                                    of \3MBLOCALNDB))
          (replace (AREXPETHER ARFRNPTCL) of AR with IPADDRESS)
          (ENCAPSULATE.ETHERPACKET \3MBLOCALNDB AR 0 20 \EPT.AR)
          (COND
             (IPTRACEFLG (PRINTPACKET AR 'PUT IPTRACEFILE)))
          (TRANSMIT.ETHERPACKET \3MBLOCALNDB AR])

(\AR.RESOLVE
  [LAMBDA (AR)                                          (* ; "Edited  6-Jan-89 14:50 by Briggs")

(* ;;; "Try to respond to an address resolution request.  Release the packet if we can't")

    (DECLARE (GLOBALVARS \10MBLOCALNDB \MY.NSHOSTNUMBER))
    (LET* ((TargetProtocolAddress (fetch (ARETHER ARFRNPTCL) of AR))
           (TargetHardwareAddress (COND
                                     ((MEMBER TargetProtocolAddress \IP.LOCAL.ADDRESSES)
                                      (\AR.ENTER.RESOLUTION TargetProtocolAddress 
                                             \MY.NSHOSTNUMBER)
                                      \MY.NSHOSTNUMBER)
                                     ([AND \IP.GATEWAY.FLG
                                           (LET* ((SUBNETMASK (CDR (SASSOC (fetch NDBIPHOST#
                                                                              of \10MBLOCALNDB)
                                                                          \IP.SUBNET.MASKS)))
                                                  (MASKEDTARGET (LOGAND TargetProtocolAddress 
                                                                       SUBNETMASK)))
                                                 (COND
                                                    ([AND SUBNETMASK
                                                          (NOT (EQP MASKEDTARGET
                                                                    (LOGAND (fetch NDBIPHOST#
                                                                               of \10MBLOCALNDB)
                                                                           SUBNETMASK]
                                                     (for ADDRPAIR in \IP.ROUTING.TABLE
                                                        when (LISTP ADDRPAIR)
                                                        thereis (EQP MASKEDTARGET (CAR ADDRPAIR]
                                      \MY.NSHOSTNUMBER)))
           (SenderHardwareAddress (fetch (ARETHER ARSENDERHDW) of AR)))
          (COND
             (TargetHardwareAddress (swap (fetch (ARETHER ARLCLPTCL) of AR)
                                           (fetch (ARETHER ARFRNPTCL) of AR))
                    (replace (ARETHER ARTARGETHDW) of AR with (fetch (ARETHER 
                                                                                          ARSENDERHDW
                                                                                            )
                                                                             of AR))
                    (replace (ARETHER ARSENDERHDW) of AR with TargetHardwareAddress)
                    (replace (ARETHER ARLCLPTCL) of AR with TargetProtocolAddress)
                    (replace (AR AROPCODE) of AR with \AR.RESPONSE)
                    (ENCAPSULATE.ETHERPACKET \10MBLOCALNDB AR SenderHardwareAddress 
                           \AR.ETHER.PACKET.LENGTH \EPT.AR)
                    [COND
                       (IPTRACEFLG (COND
                                      ((EQ IPTRACEFLG T)
                                       (PRINTPACKET AR 'PUT IPTRACEFILE))
                                      (T (PRIN1 "!" IPTRACEFILE]
                    (TRANSMIT.ETHERPACKET \10MBLOCALNDB AR))
             (T (\RELEASE.ETHERPACKET AR])

(\AR.TRANSLATE.TO.3MB
  [LAMBDA (IPADDRESS)                                    (* ejs%: "27-Jun-85 12:43")
    (COND
       ((\IP.BROADCAST.ADDRESS IPADDRESS)
        0)
       (T (LDB (BYTE 8 0)
               IPADDRESS])

(\HANDLE.RAW.AR
  [LAMBDA (AR TYPE)                                      (* ejs%: " 2-Jun-85 14:12")
    (PROG ((NDB (ffetch (ETHERPACKET EPNETWORK) of AR)))
          (SELECTQ (ffetch (NDB NETTYPE) of NDB)
              (10 (COND
                     ((NEQ TYPE \EPT.AR)
                      (RETURN))))
              (3 (RETURN))
              (ERROR "Unknown net type" (fetch (NDB NETTYPE) of NDB)))
          [COND
             ((AND (EQ (fetch (AR ARHARDWARESPACE) of AR)
                       \AR.HARDWARE.SPACE.ETHERNET)
                   (EQ (fetch (AR ARHARDWARELEN) of AR)
                       \AR.ETHERNET.ADDRESS.LENGTH)
                   (EQ (fetch (AR ARPROTOCOLSPACE) of AR)
                       \EPT.IP)
                   (EQ (fetch (AR ARPROTOCOLLEN) of AR)
                       \AR.IP.ADDRESS.LENGTH))
              [COND
                 (IPTRACEFLG (COND
                                ((EQ IPTRACEFLG T)
                                 (PRINTPACKET AR 'ARGET IPTRACEFILE))
                                (T (PRIN1 "*" IPTRACEFILE]
              (\AR.NOTE.RESOLUTION AR)
              (COND
                 ((EQ (fetch (AR AROPCODE) of AR)
                      \AR.REQUEST)
                  (\AR.RESOLVE AR))
                 (T (\RELEASE.ETHERPACKET AR]
          (RETURN T])
)

(ADDTOVAR \PACKET.PRINTERS (2054 . \PRINTAR))
(PUTPROPS TCPLLAR COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (5949 22633 (\AR.DAEMON 5959 . 6223) (\AR.ENTER.RESOLUTION 6225 . 7972) (
\AR.NOTE.RESOLUTION 7974 . 9329) (\AR.UPDATE.RESOLUTION 9331 . 10916) (\PRINTAR 10918 . 13356) (
SPUTASSOC 13358 . 13700) (\AR.TRANSLATE.TO.10MB 13702 . 14709) (\AR.REQUEST.IP.TO.10MB 14711 . 16270) 
(\AR.REQUEST.IP.TO.3MB 16272 . 17510) (\AR.RESOLVE 17512 . 20996) (\AR.TRANSLATE.TO.3MB 20998 . 21232)
 (\HANDLE.RAW.AR 21234 . 22631)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPLLICMP b/obsolete/tcp/TCPLLICMP
deleted file mode 100644
index 62f1f4bb..00000000
--- a/obsolete/tcp/TCPLLICMP
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Aug-90 12:34:42" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCPLLICMP.;2 20237  

      changes to%:  (FNS PRINTICMP \ICMP.HANDLE.REDIRECT \ICMP.INPUT)

      previous date%: " 6-Jan-89 16:38:06" {DSK}<LISPFILES>ETHERNET>TCP>NEW>TCPLLICMP.;1)


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

(PRETTYCOMPRINT TCPLLICMPCOMS)

(RPAQQ TCPLLICMPCOMS [(COMS (* * ICMP functions)
                                (DECLARE%: DONTCOPY (EXPORT (RECORDS ICMPADMASK ICMP ICMPECHO 
                                                                   ICMPDESTUN ICMPREDIRECT)
                                                           (CONSTANTS * ICMPTYPES)
                                                           (CONSTANTS * ICMPUNREACHABLES)
                                                           (CONSTANTS * ICMPREDIRECTS)
                                                           (CONSTANTS \ICMPOVLEN)
                                                           (CONSTANTS \ICMP.PROTOCOL)
                                                           (MACROS ICMPLENGTH)))
                                (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS IP.FROM.ICMP))
                                (INITVARS * ICMPTIMEXS)
                                (INITVARS (\ICMP.ECHO.REPLY.QUEUE (NCREATE 'SYSQUEUE))
                                       (\ICMP.ECHO.REPLY.EVENT (CREATE.EVENT "ICMP Echo reply"))
                                       (\ICMP.ECHOING))
                                (GLOBALVARS \ICMP.ECHO.REPLY.QUEUE \ICMP.ECHO.REPLY.EVENT 
                                       \ICMP.ECHOING)
                                (FNS PRINTICMP \ICMP.DEST.UNREACHABLE \ICMP.REDIRECT \ICMP.ECHO.TEST
                                     \ICMP.HANDLE.ECHO.REPLY \ICMP.HANDLE.REDIRECT \ICMP.INPUT 
                                     \ICMP.REPLY.TO.ECHO \ICMP.SETUPICMP \ICMP.TIME.EXCEEDED 
                                     \ICMP.TRANSMIT)
                                (FNS ICMP.HANDLE.ADDRESS.MASK \ICMP.INPUT \ICMP.REQUEST.ADDRESS.MASK)
                                (ADDVARS (IPPRINTMACROS (1 . PRINTICMP])
(* * ICMP functions)

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS ICMPADMASK ((ICMPADMASKBASE (fetch (ICMP ICMPCONTENTS) of DATUM)))
                          (BLOCKRECORD ICMPADMASKBASE ((ICMPADMASKID WORD)
                                                       (ICMPADMASKSEQNO WORD)
                                                       (ICMPADMASKADMASK FIXP))))

(ACCESSFNS ICMP ((ICMPBASE (\IPDATABASE DATUM)))
                    (BLOCKRECORD ICMPBASE ((ICMPTYPE BYTE)
                                           (ICMPCODE BYTE)
                                           (ICMPCHECKSUM WORD)
                                           (ICMPDATASTART WORD)))
                    [ACCESSFNS ICMP ((ICMPCONTENTS (LOCF (fetch (ICMP ICMPDATASTART) of
                                                                                         DATUM])

(ACCESSFNS ICMPECHO ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM)))
                        (BLOCKRECORD ICMPECHOBASE ((ICMPECHOID WORD)
                                                   (ICMPECHOSEQNO WORD)
                                                   (ICMPECHODATA BYTE))))

(ACCESSFNS ICMPDESTUN ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM)))
                          (BLOCKRECORD ICMPECHOBASE ((NIL FIXP)
                                                     (ICMPIPSTART WORD)))
                          [ACCESSFNS ICMPDESTUN ((ICMPIPHEADER (LOCF (fetch (ICMPDESTUN 
                                                                                       ICMPIPSTART)
                                                                        of DATUM])

(ACCESSFNS ICMPREDIRECT ((ICMPREDIRECTBASE (fetch (ICMP ICMPCONTENTS) of DATUM)))
                            (BLOCKRECORD ICMPREDIRECTBASE ((ICMPGATEWAY FIXP)
                                                           (ICMPIPSTART WORD)))
                            [ACCESSFNS ICMPREDIRECT ((ICMPIPHEADER (LOCF (fetch (ICMPREDIRECT
                                                                                     ICMPIPSTART)
                                                                            of DATUM])
)

(RPAQQ ICMPTYPES ((\ICMP.ECHO.REPLY 0)
                      (\ICMP.DEST.UNREACHABLE 3)
                      (\ICMP.SOURCE.QUENCH 4)
                      (\ICMP.REDIRECT 5)
                      (\ICMP.ECHO 8)
                      (\ICMP.TIME.EXCEEDED 11)
                      (\ICMP.PARAMETER.PROBLEM 12)
                      (\ICMP.TIMESTAMP 13)
                      (\ICMP.TIMESTAMP.REPLY 14)
                      (\ICMP.INFO.REQUEST 15)
                      (\ICMP.INFO.REPLY 16)
                      (\ICMP.ADDRESS.MASK.REQUEST 17)
                      (\ICMP.ADDRESS.MASK.REPLY 18)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.ECHO.REPLY 0)

(RPAQQ \ICMP.DEST.UNREACHABLE 3)

(RPAQQ \ICMP.SOURCE.QUENCH 4)

(RPAQQ \ICMP.REDIRECT 5)

(RPAQQ \ICMP.ECHO 8)

(RPAQQ \ICMP.TIME.EXCEEDED 11)

(RPAQQ \ICMP.PARAMETER.PROBLEM 12)

(RPAQQ \ICMP.TIMESTAMP 13)

(RPAQQ \ICMP.TIMESTAMP.REPLY 14)

(RPAQQ \ICMP.INFO.REQUEST 15)

(RPAQQ \ICMP.INFO.REPLY 16)

(RPAQQ \ICMP.ADDRESS.MASK.REQUEST 17)

(RPAQQ \ICMP.ADDRESS.MASK.REPLY 18)


(CONSTANTS (\ICMP.ECHO.REPLY 0)
       (\ICMP.DEST.UNREACHABLE 3)
       (\ICMP.SOURCE.QUENCH 4)
       (\ICMP.REDIRECT 5)
       (\ICMP.ECHO 8)
       (\ICMP.TIME.EXCEEDED 11)
       (\ICMP.PARAMETER.PROBLEM 12)
       (\ICMP.TIMESTAMP 13)
       (\ICMP.TIMESTAMP.REPLY 14)
       (\ICMP.INFO.REQUEST 15)
       (\ICMP.INFO.REPLY 16)
       (\ICMP.ADDRESS.MASK.REQUEST 17)
       (\ICMP.ADDRESS.MASK.REPLY 18))
)

(RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0)
                             (\ICMP.HOST.UNREACHABLE 1)
                             (\ICMP.PROTOCOL.UNREACHABLE 2)
                             (\ICMP.PORT.UNREACHABLE 3)
                             (\ICMP.CANT.FRAGMENT 4)
                             (\ICMP.SOURCE.ROUTE 5)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.NET.UNREACHABLE 0)

(RPAQQ \ICMP.HOST.UNREACHABLE 1)

(RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2)

(RPAQQ \ICMP.PORT.UNREACHABLE 3)

(RPAQQ \ICMP.CANT.FRAGMENT 4)

(RPAQQ \ICMP.SOURCE.ROUTE 5)


(CONSTANTS (\ICMP.NET.UNREACHABLE 0)
       (\ICMP.HOST.UNREACHABLE 1)
       (\ICMP.PROTOCOL.UNREACHABLE 2)
       (\ICMP.PORT.UNREACHABLE 3)
       (\ICMP.CANT.FRAGMENT 4)
       (\ICMP.SOURCE.ROUTE 5))
)

(RPAQQ ICMPREDIRECTS ((\ICMP.REDIRECT.NET 0)
                          (\ICMP.REDIRECT.HOST 1)
                          (\ICMP.REDIRECT.SVC.AND.NET 2)
                          (\ICMP.REDIRECT.SVC.AND.HOST 3)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.REDIRECT.NET 0)

(RPAQQ \ICMP.REDIRECT.HOST 1)

(RPAQQ \ICMP.REDIRECT.SVC.AND.NET 2)

(RPAQQ \ICMP.REDIRECT.SVC.AND.HOST 3)


(CONSTANTS (\ICMP.REDIRECT.NET 0)
       (\ICMP.REDIRECT.HOST 1)
       (\ICMP.REDIRECT.SVC.AND.NET 2)
       (\ICMP.REDIRECT.SVC.AND.HOST 3))
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMPOVLEN 4)


(CONSTANTS \ICMPOVLEN)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.PROTOCOL 1)


(CONSTANTS \ICMP.PROTOCOL)
)
(DECLARE%: EVAL@COMPILE 

[PUTPROPS ICMPLENGTH MACRO (LAMBDA (ICMP)
                             (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of ICMP)
                                    (LLSH (fetch (IP IPHEADERLENGTH) of ICMP)
                                          2]
)

(* "END EXPORTED DEFINITIONS")

)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

[PUTPROPS IP.FROM.ICMP MACRO (OPENLAMBDA (PKT)

                                 (* ;; "Returns a pointer to the 'Internet header + 64 bits' found in an ICMP packet, offset so that it looks like an IP record.  I.e., add to the base the size of the IP header + ICMP header")

                                    (\ADDBASE PKT (+ (UNFOLD (fetch (IP IPHEADERLENGTH)
                                                                of PKT)
                                                            WORDSPERCELL)
                                                     (CONSTANT (+ (FOLDHI \ICMPOVLEN BYTESPERWORD)
                                                                  2]
)
)

(RPAQQ ICMPTIMEXS ((\ICMP.TRANSIT.TIME.EXCEEDED 0)
                       (\ICMP.FRAGMENT.TIME.EXCEEDED 1)))

(RPAQ? \ICMP.TRANSIT.TIME.EXCEEDED 0)

(RPAQ? \ICMP.FRAGMENT.TIME.EXCEEDED 1)

(RPAQ? \ICMP.ECHO.REPLY.QUEUE (NCREATE 'SYSQUEUE))

(RPAQ? \ICMP.ECHO.REPLY.EVENT (CREATE.EVENT "ICMP Echo reply"))

(RPAQ? \ICMP.ECHOING )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \ICMP.ECHO.REPLY.QUEUE \ICMP.ECHO.REPLY.EVENT \ICMP.ECHOING)
)
(DEFINEQ

(PRINTICMP
  [LAMBDA (ICMP FILE)                                    (* ; "Edited 13-Sep-88 11:35 by bvm")
    (LET ((*PRINT-BASE* 10)
          (TYPE (fetch (ICMP ICMPTYPE) of ICMP))
          (CODE (fetch (ICMP ICMPCODE) of ICMP)))
         (PRINTCONSTANT TYPE ICMPTYPES FILE "\ICMP.")
         (SPACES 1 FILE)
         (SELECTC TYPE
             (\ICMP.REDIRECT 
                  (PRINTCONSTANT CODE ICMPREDIRECTS FILE "\ICMP.REDIRECT.")
                  (PRINTOUT FILE " " (\IP.ADDRESS.TO.STRING (fetch (ICMPREDIRECT ICMPGATEWAY)
                                                               of ICMP))))
             (\ICMP.DEST.UNREACHABLE 
                  (PRINTCONSTANT CODE ICMPUNREACHABLES FILE "\ICMP."))
             (PRIN3 CODE FILE))
         (TERPRI FILE])

(\ICMP.DEST.UNREACHABLE
(LAMBDA (PACKET CODE) (* ejs%: " 2-Feb-86 11:35") (* * Returns an ICMP unreachable packet of proper code to sender) (PROG ((ICMP (\ALLOCATE.ETHERPACKET)) NWORDS) (\IP.SETUPIP ICMP (fetch (IP IPSOURCEADDRESS) of PACKET) 0 (\IP.FIND.PROTOCOL \ICMP.PROTOCOL)) (\ICMP.SETUPICMP ICMP \ICMP.DEST.UNREACHABLE CODE) (SETQ NWORDS (IPLUS (FOLDHI 64 BITSPERWORD) (UNFOLD (fetch (IP IPHEADERLENGTH) of PACKET) WORDSPERCELL))) (\BLT (fetch (ICMPDESTUN ICMPIPHEADER) of ICMP) (fetch (IP IPBASE) of PACKET) NWORDS) (add (fetch (IP IPTOTALLENGTH) of ICMP) (UNFOLD NWORDS BYTESPERWORD)) (\ICMP.TRANSMIT ICMP) (\RELEASE.ETHERPACKET PACKET)))
)

(\ICMP.REDIRECT
(LAMBDA (PACKET CODE) (* ejs%: " 2-Feb-86 12:13") (* * Returns an ICMP unreachable packet of proper code to sender) (PROG ((ICMP (\ALLOCATE.ETHERPACKET)) NWORDS) (\IP.SETUPIP ICMP (fetch (IP IPSOURCEADDRESS) of PACKET) 0 (\IP.FIND.PROTOCOL \ICMP.PROTOCOL)) (\ICMP.SETUPICMP ICMP \ICMP.REDIRECT CODE) (SETQ NWORDS (IPLUS (FOLDHI 64 BITSPERWORD) (UNFOLD (fetch (IP IPHEADERLENGTH) of PACKET) WORDSPERCELL) WORDSPERCELL)) (replace (ICMPREDIRECT ICMPGATEWAY) of ICMP with (OR \IP.DEFAULT.GATEWAY 0)) (\BLT (fetch (ICMPREDIRECT ICMPIPHEADER) of ICMP) (fetch (IP IPBASE) of PACKET) NWORDS) (add (fetch (IP IPTOTALLENGTH) of ICMP) (UNFOLD NWORDS BYTESPERWORD)) (\ICMP.TRANSMIT ICMP) (\RELEASE.ETHERPACKET PACKET)))
)

(\ICMP.ECHO.TEST
(LAMBDA (IPADDRESS ECHOSTREAM DATALENGTH) (* ejs%: "12-May-86 18:01") (* * An ICMP echo tester) (while (\QUEUEHEAD \ICMP.ECHO.REPLY.QUEUE) do (\RELEASE.ETHERPACKET (\DEQUEUE \ICMP.ECHO.REPLY.QUEUE))) (RESETVAR \ICMP.ECHOING T (PROG (ICMP (IPSOCKET (\IP.FIND.PROTOCOL \ICMP.PROTOCOL))) (for SEQUENCE from 0 do ((SETQ ICMP (\ALLOCATE.ETHERPACKET)) (\IP.SETUPIP ICMP (DODIP.HOSTP IPADDRESS) 0 IPSOCKET) (\ICMP.SETUPICMP ICMP \ICMP.ECHO 0) (replace (ICMPECHO ICMPECHOID) of ICMP with 0) (replace (ICMPECHO ICMPECHOSEQNO) of ICMP with SEQUENCE) (add (fetch (IP IPTOTALLENGTH) of ICMP) 4) (AND (NUMBERP DATALENGTH) (add (fetch (IP IPTOTALLENGTH) of ICMP) DATALENGTH)) (printout ECHOSTREAM "!") (\ICMP.TRANSMIT ICMP) (AWAIT.EVENT \ICMP.ECHO.REPLY.EVENT \ETHERTIMEOUT) (COND ((SETQ ICMP (\DEQUEUE \ICMP.ECHO.REPLY.QUEUE)) (COND ((IGREATERP (fetch (ICMPECHO ICMPECHOSEQNO) of ICMP) SEQUENCE) (printout T "ICMP echo out of sequence" T) (PRINTPACKET ICMP (QUOTE GET) ECHOSTREAM) (RETURN ICMP)) (T (printout ECHOSTREAM "+") (\RELEASE.ETHERPACKET ICMP)))) (T (printout ECHOSTREAM "."))))))))
)

(\ICMP.HANDLE.ECHO.REPLY
(LAMBDA (ICMP) (* ejs%: "28-Dec-84 09:02") (COND (\ICMP.ECHOING (\ENQUEUE \ICMP.ECHO.REPLY.QUEUE ICMP) (NOTIFY.EVENT \ICMP.ECHO.REPLY.EVENT)) (T (\RELEASE.ETHERPACKET ICMP))))
)

(\ICMP.HANDLE.REDIRECT
  [LAMBDA (ICMP)                                         (* ; "Edited 24-Aug-88 16:16 by bvm")

(* ;;; "Called when a gateway tells us a better route to the destination.  There is a code for type of redirect, but it's not obviously meaningful ")

    (LET* ((NDB (fetch EPNETWORK of ICMP))
           (GATEWAY (fetch (ICMPREDIRECT ICMPGATEWAY) of ICMP))
           (DESTADDRESS (fetch (IP IPDESTINATIONADDRESS) of (IP.FROM.ICMP ICMP)))
           (DESTNET (\IPNETADDRESS DESTADDRESS)))

          (* ;; "Store the new route in the routing table")

          (COND
             [(= DESTNET (fetch (NDB NDBIPNET#) of NDB))
              (LET* ((SOURCEADDRESS (fetch (NDB NDBIPHOST#) of NDB))
                     (SUBNETMASK (CDR (SASSOC SOURCEADDRESS \IP.SUBNET.MASKS)))
                     (DESTSUBNET (LOGAND DESTADDRESS SUBNETMASK)))

                    (* ;; "The dest net is a local net.  Either we fouled up in our routing, or the dest net is really a subnet")

                    (COND
                       ((NOT (= DESTSUBNET (LOGAND SOURCEADDRESS SUBNETMASK)))
                                                             (* ; 
                                        "Yes, this is a redirect for a subnet, if such is possible")
                        (SPUTASSOC DESTSUBNET GATEWAY \IP.ROUTING.TABLE]
             (T                                              (* ; "Non-local net")
                (SPUTASSOC DESTNET GATEWAY \IP.ROUTING.TABLE)))

          (* ;; "If it's a 10MB network, see if we have the 10MB address of this gateway, and if not, request the address")

          (SELECTQ (fetch (NDB NETTYPE) of NDB)
              (10 (COND
                     ((NOT (\AR.TRANSLATE.TO.10MB GATEWAY T))
                      (\AR.TRANSLATE.TO.10MB GATEWAY))))
              NIL)
          (\RELEASE.ETHERPACKET ICMP])

(\ICMP.INPUT
  [LAMBDA (ICMP)                                         (* ; "Edited 25-Aug-88 11:51 by bvm")

(* ;;; "ICMP packet received")

    (COND
       ((\IP.CHECKSUM.OK (\IPCHECKSUM ICMP (fetch (ICMP ICMPBASE) of ICMP)
                                (\IPDATALENGTH ICMP)))
        (SELECTC (fetch (ICMP ICMPTYPE) of ICMP)
            (\ICMP.ECHO.REPLY 
                 (\ICMP.HANDLE.ECHO.REPLY ICMP))
            (\ICMP.ECHO (\ICMP.REPLY.TO.ECHO ICMP))
            (\ICMP.DEST.UNREACHABLE                          (* ; "Some packet couldn't reach its destination.  Tell the protocol that sent the packet (found in the enclosed header)")
                 [LET* [(SEGMENT (IP.FROM.ICMP ICMP))
                        (PROTOCOL (\IP.FIND.PROTOCOL (fetch (IP IPPROTOCOL) of SEGMENT]
                       (COND
                          (PROTOCOL (CL:FUNCALL (fetch (IPSOCKET IPSICMPFN) of PROTOCOL)
                                           ICMP SEGMENT PROTOCOL])
            (\ICMP.REDIRECT 
                 (\ICMP.HANDLE.REDIRECT ICMP))
            (\ICMP.ADDRESS.MASK.REPLY 
                 (ICMP.HANDLE.ADDRESS.MASK ICMP))
            (\RELEASE.ETHERPACKET ICMP)))
       (T (AND IPTRACEFLG (PRINTPACKET ICMP 'ICMPGET IPTRACEFILE 
                                 "[dropping packet--bad ICMP checksum]"])

(\ICMP.REPLY.TO.ECHO
(LAMBDA (ICMP) (* ejs%: "12-May-86 17:34") (* * Reply to an echo request) (swap (fetch (IP IPSOURCEADDRESS) of ICMP) (fetch (IP IPDESTINATIONADDRESS) of ICMP)) (replace (ICMP ICMPTYPE) of ICMP with \ICMP.ECHO.REPLY) (replace EPREQUEUE of ICMP with (QUOTE FREE)) (\ICMP.TRANSMIT ICMP))
)

(\ICMP.SETUPICMP
(LAMBDA (ICMP TYPE CODE) (* ejs%: "27-Dec-84 19:00") (replace (ICMP ICMPTYPE) of ICMP with TYPE) (replace (ICMP ICMPCODE) of ICMP with CODE) (add (fetch (IP IPTOTALLENGTH) of ICMP) \ICMPOVLEN))
)

(\ICMP.TIME.EXCEEDED
(LAMBDA (PACKET CODE) (* ejs%: " 3-Feb-86 11:00") (* * Returns an ICMP unreachable packet of proper code to sender) (PROG ((ICMP (\ALLOCATE.ETHERPACKET)) NWORDS) (\IP.SETUPIP ICMP (fetch (IP IPSOURCEADDRESS) of PACKET) 0 (\IP.FIND.PROTOCOL \ICMP.PROTOCOL)) (\ICMP.SETUPICMP ICMP \ICMP.TIME.EXCEEDED CODE) (SETQ NWORDS (IPLUS (FOLDHI 64 BITSPERWORD) (UNFOLD (fetch (IP IPHEADERLENGTH) of PACKET) WORDSPERCELL))) (\BLT (fetch (ICMPDESTUN ICMPIPHEADER) of ICMP) (fetch (IP IPBASE) of PACKET) NWORDS) (add (fetch (IP IPTOTALLENGTH) of ICMP) (UNFOLD NWORDS BYTESPERWORD)) (\ICMP.TRANSMIT ICMP)))
)

(\ICMP.TRANSMIT
(LAMBDA (ICMP) (* ejs%: "31-Dec-84 14:27") (* * Checksum and transmit an ICMP packet) (\IP.SET.CHECKSUM ICMP (fetch (ICMP ICMPBASE) of ICMP) (\IPDATALENGTH ICMP) (LOCF (fetch (ICMP ICMPCHECKSUM) of ICMP))) (\IP.TRANSMIT ICMP))
)
)
(DEFINEQ

(ICMP.HANDLE.ADDRESS.MASK
(LAMBDA (ICMP) (* ; "Edited 22-Mar-88 18:49 by eweaver") (* ;; "Called when an address-mask-reply icmp comes in.") (LET* ((FROM (fetch (IP IPSOURCEADDRESS) of ICMP)) (DESTADDR (fetch (IP IPDESTINATIONADDRESS) of ICMP)) (LOCALADDR (COND ((AND \3MBLOCALNDB (EQ (fetch NDBIPHOST# of \3MBLOCALNDB) DESTADDR)) DESTADDR) ((AND \10MBLOCALNDB (EQ (fetch NDBIPHOST# of \10MBLOCALNDB) DESTADDR)) DESTADDR))) (MASK (fetch (ICMPADMASK ICMPADMASKADMASK) of ICMP))) (* ;; (CL:FORMAT PROMPTWINDOW "ICMP AdMask from ~a mask ~a" (\IP.ADDRESS.TO.STRING FROM) (\IP.ADDRESS.TO.STRING MASK))) (COND ((NULL \IP.DEFAULT.GATEWAY) (SETQ \IP.DEFAULT.GATEWAY FROM))) (COND ((NULL (SASSOC DESTADDR \IP.SUBNET.MASKS)) (CL:PUSH (CONS DESTADDR MASK) \IP.SUBNET.MASKS)))))
)

(\ICMP.INPUT
  [LAMBDA (ICMP)                                         (* ; "Edited 25-Aug-88 11:51 by bvm")

(* ;;; "ICMP packet received")

    (COND
       ((\IP.CHECKSUM.OK (\IPCHECKSUM ICMP (fetch (ICMP ICMPBASE) of ICMP)
                                (\IPDATALENGTH ICMP)))
        (SELECTC (fetch (ICMP ICMPTYPE) of ICMP)
            (\ICMP.ECHO.REPLY 
                 (\ICMP.HANDLE.ECHO.REPLY ICMP))
            (\ICMP.ECHO (\ICMP.REPLY.TO.ECHO ICMP))
            (\ICMP.DEST.UNREACHABLE                          (* ; "Some packet couldn't reach its destination.  Tell the protocol that sent the packet (found in the enclosed header)")
                 [LET* [(SEGMENT (IP.FROM.ICMP ICMP))
                        (PROTOCOL (\IP.FIND.PROTOCOL (fetch (IP IPPROTOCOL) of SEGMENT]
                       (COND
                          (PROTOCOL (CL:FUNCALL (fetch (IPSOCKET IPSICMPFN) of PROTOCOL)
                                           ICMP SEGMENT PROTOCOL])
            (\ICMP.REDIRECT 
                 (\ICMP.HANDLE.REDIRECT ICMP))
            (\ICMP.ADDRESS.MASK.REPLY 
                 (ICMP.HANDLE.ADDRESS.MASK ICMP))
            (\RELEASE.ETHERPACKET ICMP)))
       (T (AND IPTRACEFLG (PRINTPACKET ICMP 'ICMPGET IPTRACEFILE 
                                 "[dropping packet--bad ICMP checksum]"])

(\ICMP.REQUEST.ADDRESS.MASK
(LAMBDA NIL (* ; "Edited  8-Jan-88 15:15 by eweaver") (* ;; "Broadcast a request for the subnet mask.  The reply is handled asynchronously by") (* ;; " \handle-icmp-address-mask.") (LET ((ICMP (\ALLOCATE.ETHERPACKET)) (IPSOCKET (\IP.FIND.PROTOCOL \ICMP.PROTOCOL))) (\IP.SETUPIP ICMP 0 0 IPSOCKET) (\ICMP.SETUPICMP ICMP \ICMP.ADDRESS.MASK.REQUEST 0) (replace (ICMPADMASK ICMPADMASKID) of ICMP with 0) (replace (ICMPADMASK ICMPADMASKSEQNO) of ICMP with 0) (add (fetch (IP IPTOTALLENGTH) of ICMP) 4) (\ICMP.TRANSMIT ICMP)))
)
)

(ADDTOVAR IPPRINTMACROS (1 . PRINTICMP))
(PUTPROPS TCPLLICMP COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (9098 17355 (PRINTICMP 9108 . 9918) (\ICMP.DEST.UNREACHABLE 9920 . 10573) (
\ICMP.REDIRECT 10575 . 11304) (\ICMP.ECHO.TEST 11306 . 12407) (\ICMP.HANDLE.ECHO.REPLY 12409 . 12615) 
(\ICMP.HANDLE.REDIRECT 12617 . 14564) (\ICMP.INPUT 14566 . 15953) (\ICMP.REPLY.TO.ECHO 15955 . 16266) 
(\ICMP.SETUPICMP 16268 . 16484) (\ICMP.TIME.EXCEEDED 16486 . 17103) (\ICMP.TRANSMIT 17105 . 17353)) (
17356 20085 (ICMP.HANDLE.ADDRESS.MASK 17366 . 18138) (\ICMP.INPUT 18140 . 19527) (
\ICMP.REQUEST.ADDRESS.MASK 19529 . 20083)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPLLIP b/obsolete/tcp/TCPLLIP
deleted file mode 100644
index b5ec716b..00000000
--- a/obsolete/tcp/TCPLLIP
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP")
(FILECREATED "30-Aug-90 13:46:39" {DSK}<LISPFILES>TCP>TCPLLIP.;3 151757 

      changes to%:  (VARS TCPLLIPCOMS)

      previous date%: "29-Aug-90 16:28:12" {DSK}<LISPFILES>TCP>TCPLLIP.;2)


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

(PRETTYCOMPRINT TCPLLIPCOMS)

(RPAQQ TCPLLIPCOMS 
       ((PROP MAKEFILE-ENVIRONMENT TCPLLIP)
        (COMS 
              (* ;; "IP definitions and addressing")

              (DECLARE%: DONTCOPY (EXPORT (RECORDS IP IPSOCKET IPADDRESS)
                                         (CONSTANTS \IPOVLEN \MAX.IPDATALENGTH \IP.PROTOCOLVERSION 
                                                \IP.MAX.EPKTS.ON.QUEUE \IP.DEFAULT.TIME.TO.LIVE 
                                                \IP.WAKEUP.INTERVAL)
                                         (CONSTANTS * IPPACKETTYPES)
                                         (CONSTANTS * ICMPUNREACHABLES)
                                         (MACROS \IPDATABASE \IPDATALENGTH)))
              (ADDVARS (*IP-PROTOCOL-NAME-FROM-NUMBER* (17 . "UDP")
                              (6 . "TCP")
                              (1 . "ICMP")))
              (GLOBALVARS *IP-PROTOCOL-NAME-FROM-NUMBER*)
              
              (* ;; "value in sysout is too small.  This is 512-(indexf (fetch epencapsulation))-2.  489 is more correct, but let's leave a word of slop for off-by-ones")

              (VARS (\10MBPACKETLENGTH 488))
              
              (* ;; "Make it easier to see queuelength without opening up q.")

              (FNS \SYSQUEUE.DEFPRINT \IPSOCKET.DEFPRINT)
              [DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'IPSOCKET '\IPSOCKET.DEFPRINT))
                     (P (DEFPRINT 'SYSQUEUE '\SYSQUEUE.DEFPRINT]
              (INITVARS (IPTRACETIME)
                     (IPONLYTYPES)
                     (IPIGNORETYPES)
                     (IPPRINTMACROS)
                     (IPTRACEFLG)
                     (IPTRACEFILE)
                     (\IP.INIT.FILE)
                     (\IP.DEFAULT.CONFIGURATION)
                     (\IP.HOSTNAMES (HASHARRAY 40 1.1))
                     (\IP.HOSTNUMBERS)
                     (INTERNET.LOCAL.DOMAIN))
              (INITRECORDS IP IPSOCKET IPADDRESS)
              (GLOBALVARS IPTRACEFILE IPTRACEFLG IPIGNORETYPES IPONLYTYPES IPPRINTMACROS 
                     \IP.HOSTNAMES \IP.INIT.FILE INTERNET.LOCAL.DOMAIN \IP.DEFAULT.CONFIGURATION 
                     \IP.HOSTNUMBERS)
              (FILES (SYSLOAD)
                     TCPHTE TCPLLICMP TCPLLAR)
              (ADDVARS (\PACKET.PRINTERS (2048 . PRINTIP)))
              (FNS \CANONICALIZE.IP.HOSTNAME DODIP.HOSTP IPHOSTADDRESS IPHOSTNAME IPTRACE 
                   IPTRACEWINDOW.BUTTONFN PRINTIP PRINTIPDATA \IPADDRESSCLASS \IPEVENTFN 
                   \IPHOSTADDRESS \IPNETADDRESS \IP.ADDRESS.TO.STRING \IP.BROADCAST.ADDRESS 
                   \IP.LEGAL.ADDRESS \IP.MAKE.BROADCAST.ADDRESS \IP.PRINT.ADDRESS 
                   \IP.READ.STRING.ADDRESS \DOMAIN.NAME.QUALIFY.FULLY))
        (COMS 
              (* ;; "Startup and shutdown")

              (INITVARS (*IP-DEFAULT-HOSTS-FILE*)
                     (TCP.ALWAYS.READ.HOSTS.FILE T)
                     (\TCP.LAST.HOSTS.FILE.DATE)
                     (\TCP.LAST.HOSTS.FILE.READ)
                     (\IPFLG)
                     (\IP.READY)
                     (\IP.READY.EVENT (CREATE.EVENT "IP Ready"))
                     (\IP.WAKEUP.TIMER)
                     (IPTRACEFLG)
                     (\IP.WAKEUP.EVENT (CREATE.EVENT "IP Wakeup")))
              (GLOBALVARS \IPFLG \IP.READY \IP.READY.EVENT \IP.WAKEUP.TIMER \IP.WAKEUP.EVENT 
                     TCP.ALWAYS.READ.HOSTS.FILE \TCP.LAST.HOSTS.FILE.DATE \TCP.LAST.HOSTS.FILE.READ 
                     *IP-DEFAULT-HOSTS-FILE*)
              (FNS STOPIP \IPINIT \IPLISTENER \IP.REINITIALIZE.FROM.SCRATCH 
                   \IP.RESTART.FROM.CONFIGURATION \IP.MAYBE.READ.HOSTS.TXT \IP.READ.INIT.FILE 
                   \IP.PROMPT.FOR.FILE.NAME)
              (ADDVARS (RESTARTETHERFNS \IPEVENTFN)))
        (COMS 
              (* ;; "Early IP reception functions")

              (DECLARE%: DONTCOPY (EXPORT (CONSTANTS * IPADDRESSTYPES)))
              (INITVARS (\IP.LOCAL.ADDRESSES)
                     (\IP.SUBNET.MASKS)
                     (\IP.GATEWAY.FLG))
              (VARS (\IP.ADDRESS.BOX (\CREATECELL \FIXP)))
              (GLOBALVARS \IP.LOCAL.ADDRESSES \IP.SUBNET.MASKS \IP.GATEWAY.FLG \IP.ADDRESS.BOX)
              (MACROS \IP.FIX.DEST.HOST \IP.FIX.DEST.NET \IP.FIX.SOURCE.HOST \IP.FIX.SOURCE.NET)
              (FNS \HANDLE.RAW.IP \FORWARD.IP \IP.LOCAL.DESTINATION \IPCHECKSUM \IP.CHECKSUM.OK 
                   \IP.SET.CHECKSUM))
        (COMS 
              (* ;; "Protocol Distribution")

              (DECLARE%: DONTCOPY (EXPORT (CONSTANTS * IPPROTOCOLTYPES)))
              (INITVARS (\IP.PROTOCOLS))
              (GLOBALVARS \IP.PROTOCOLS)
              (FNS \IP.HAND.TO.PROTOCOL \IP.DEFAULT.INPUTFN \IP.DEFAULT.NOSOCKETFN \IP.ADD.PROTOCOL 
                   \IP.DELETE.PROTOCOL \IP.FIND.PROTOCOL \IP.FIND.PROTOCOL.SOCKET \IP.FIND.SOCKET 
                   \IP.OPEN.SOCKET \IP.CLOSE.SOCKET))
        (COMS 
              (* ;; "Fragmentation Handling")

              (DECLARE%: DONTCOPY (EXPORT (RECORDS AssemblyRecord FragmentRecord FragmentID)))
              (INITVARS (\IP.FRAGMENT.LIST)
                     (\IP.FRAGMENT.LOCK (CREATE.MONITORLOCK "IP Fragment Processing Lock")))
              (GLOBALVARS \IP.FRAGMENT.LIST \IP.FRAGMENT.LOCK)
              (CONSTANTS (\IP.FRAGMENTATION.UNIT 8))
              (FNS \HANDLE.RAW.IP.FRAGMENT \IP.NEW.FRAGMENT.LST 
                   \IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER \IP.ADD.FRAGMENT 
                   \IP.FIND.MATCHING.FRAGMENTS \IP.FRAGMENTED.PACKET \IP.CHECK.REASSEMBLY.TIMEOUTS 
                   \IP.DELETE.FRAGMENT \IP.PRINT.FRAGMENT))
        (COMS 
              (* ;; "Option Processing")

              [DECLARE%: DONTCOPY (EXPORT (CONSTANTS * IPOPTIONTYPES)
                                         (CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0]
              (FNS \IP.PROCESS.OPTIONS \IP.OPTION.RECORD.ROUTE \IP.OPTION.STRICT.SOURCE.ROUTE 
                   \IP.OPTION.TIMESTAMP))
        (COMS 
              (* ;; "Packet Transmission and routing")

              (INITVARS (\IP.ROUTING.TABLE (CONS))
                     (\IP.DEFAULT.GATEWAY)
                     (\IP.LOCAL.NETWORKS)
                     (\IP.GATEWAY.FORWARDING.FUNCTIONS))
              (GLOBALVARS \IP.ROUTING.TABLE \IP.DEFAULT.GATEWAY \IP.LOCAL.NETWORKS 
                     \IP.GATEWAY.FORWARDING.FUNCTIONS)
              (FNS \IP.SETUPIP \IP.TRANSMIT \IP.ROUTE.PACKET)
              (FNS IP.GET IP.SEND IP.PACKET.WATCHER)
              (MACROS IP.SEND))
        (COMS 
              (* ;; "Client functions for building packets")

              (FNS \IP.APPEND.BYTE \IP.APPEND.CELL \IP.APPEND.STRING \IP.APPEND.WORD \IP.GET.BYTE 
                   \IP.GET.CELL \IP.GET.STRING \IP.GET.WORD \IP.PUT.BYTE \IP.PUT.CELL \IP.PUT.STRING
                   \IP.PUT.WORD)
              (MACROS \IP.GET.BYTE \IP.GET.CELL \IP.GET.STRING \IP.GET.WORD \IP.PUT.BYTE \IP.PUT.CELL
                     \IP.PUT.STRING \IP.PUT.WORD))
        (P (MOVD? 'NILL 'IP.DEFAULT.CONFIGURATION))
        (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY 
                                                \IP.INIT.FILE \IP.SUBNET.MASKS 
                                                \PROCESS.AFTEREXIT.EVENT \PROC.READY 
                                                \AR.IP.TO.10MB.ALIST))))

(PUTPROPS TCPLLIP MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP"))



(* ;; "IP definitions and addressing")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS IP [(IPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM]
                  [BLOCKRECORD IPBASE ((IPVERSION BITS 4)    (* ; "Protocol version")
                                       (IPHEADERLENGTH BITS 4)
                                                             (* ; "Head length, in cells")
                                       (IPSERVICE BYTE)      (* ; "Service type")
                                       (IPTOTALLENGTH WORD)  (* ; "Packet length, in bytes")
                                       (IPID WORD)           (* ; "Packet id")
                                       (NIL BITS 1)
                                       (IPDONTFRAGMENT FLAG) (* ; "Don't fragment me")
                                       (IPMOREFRAGMENTS FLAG)(* ; "Last fragment")
                                       (IPFRAGMENTOFFSET BITS 13)
                                                             (* ; "Fragment position")
                                       (IPTIMETOLIVE BYTE)   (* ; "Hop limiter")
                                       (IPPROTOCOL BYTE)     (* ; "Client protocol")
                                       (IPHEADERCHECKSUM WORD)
                                                             (* ; "Header-only checksum")
                                       (IPSOURCEADDRESS FIXP)
                                       (IPDESTINATIONADDRESS FIXP)
                                       (IPOPTIONSSTART BYTE) (* ; "Options or data start here")
                                       )
                         [ACCESSFNS IPSERVICE ((IPSERVICEBASE (LOCF DATUM)))
                                (BLOCKRECORD IPSERVICEBASE ((IPPRECEDENCE BITS 3)
                                                            (IPDELAY FLAG)
                                                            (IPTHROUGHPUT FLAG)
                                                            (IPRELIABILITY FLAG)
                                                            (NIL BITS 2]
                         [ACCESSFNS IPDESTINATIONADDRESS ((IPDESTBASE (LOCF DATUM)))
                                (ACCESSFNS IPDESTBASE ([IPDESTINATIONNET
                                                        (COND
                                                           ((EQ \IP.CLASS.A (fetch (IPADDRESS
                                                                                        CLASSA)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSANET)
                                                               of DATUM))
                                                           ((EQ \IP.CLASS.B (fetch (IPADDRESS
                                                                                        CLASSB)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSBNET)
                                                               of DATUM))
                                                           ((EQ \IP.CLASS.C (fetch (IPADDRESS
                                                                                        CLASSC)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSCNET)
                                                               of DATUM))
                                                           (T (ERROR "Illegal address class" DATUM)))
                                                        (COND
                                                           ((EQ \IP.CLASS.A (fetch (IPADDRESS
                                                                                        CLASSA)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSANET)
                                                               of DATUM with NEWVALUE))
                                                           ((EQ \IP.CLASS.B (fetch (IPADDRESS
                                                                                        CLASSB)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSBNET)
                                                               of DATUM with NEWVALUE))
                                                           ((EQ \IP.CLASS.C (fetch (IPADDRESS
                                                                                        CLASSC)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSCNET)
                                                               of DATUM with NEWVALUE))
                                                           (T (ERROR "Illegal address class" DATUM]
                                                       (IPDESTINATIONHOST
                                                        (COND
                                                           ((EQ \IP.CLASS.A (fetch (IPADDRESS
                                                                                        CLASSA)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSAHOST)
                                                               of DATUM))
                                                           ((EQ \IP.CLASS.B (fetch (IPADDRESS
                                                                                        CLASSB)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSBHOST)
                                                               of DATUM))
                                                           ((EQ \IP.CLASS.C (fetch (IPADDRESS
                                                                                        CLASSC)
                                                                               of DATUM))
                                                            (fetch (IPADDRESS CLASSCHOST)
                                                               of DATUM))
                                                           (T (ERROR "Illegal address class" DATUM)))
                                                        (COND
                                                           ((EQ \IP.CLASS.A (fetch (IPADDRESS
                                                                                        CLASSA)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSAHOST)
                                                               of DATUM with NEWVALUE))
                                                           ((EQ \IP.CLASS.B (fetch (IPADDRESS
                                                                                        CLASSB)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSBHOST)
                                                               of DATUM with NEWVALUE))
                                                           ((EQ \IP.CLASS.C (fetch (IPADDRESS
                                                                                        CLASSC)
                                                                               of DATUM))
                                                            (replace (IPADDRESS CLASSCHOST)
                                                               of DATUM with NEWVALUE))
                                                           (T (ERROR "Illegal address class" DATUM]
                         (ACCESSFNS IPSOURCEADDRESS ((IPSOURCEBASE (LOCF DATUM)))
                                (ACCESSFNS IPSOURCEBASE ([IPSOURCENET (COND
                                                                         ((EQ \IP.CLASS.A
                                                                              (fetch (IPADDRESS
                                                                                          CLASSA)
                                                                                 of DATUM))
                                                                          (fetch (IPADDRESS
                                                                                      CLASSANET)
                                                                             of DATUM))
                                                                         ((EQ \IP.CLASS.B
                                                                              (fetch (IPADDRESS
                                                                                          CLASSB)
                                                                                 of DATUM))
                                                                          (fetch (IPADDRESS
                                                                                      CLASSBNET)
                                                                             of DATUM))
                                                                         ((EQ \IP.CLASS.C
                                                                              (fetch (IPADDRESS
                                                                                          CLASSC)
                                                                                 of DATUM))
                                                                          (fetch (IPADDRESS
                                                                                      CLASSCNET)
                                                                             of DATUM))
                                                                         (T (ERROR 
                                                                              "Illegal address class"
                                                                                   DATUM)))
                                                                (COND
                                                                   ((EQ \IP.CLASS.A
                                                                        (fetch (IPADDRESS CLASSA)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS CLASSANET
                                                                                        )
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   ((EQ \IP.CLASS.B
                                                                        (fetch (IPADDRESS CLASSB)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS CLASSBNET
                                                                                        )
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   ((EQ \IP.CLASS.C
                                                                        (fetch (IPADDRESS CLASSC)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS CLASSCNET
                                                                                        )
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   (T (ERROR "Illegal address class"
                                                                             DATUM]
                                                         (IPSOURCEHOST (COND
                                                                          ((EQ \IP.CLASS.A
                                                                               (fetch
                                                                                (IPADDRESS CLASSA)
                                                                                  of DATUM))
                                                                           (fetch (IPADDRESS
                                                                                       CLASSAHOST)
                                                                              of DATUM))
                                                                          ((EQ \IP.CLASS.B
                                                                               (fetch
                                                                                (IPADDRESS CLASSB)
                                                                                  of DATUM))
                                                                           (fetch (IPADDRESS
                                                                                       CLASSBHOST)
                                                                              of DATUM))
                                                                          ((EQ \IP.CLASS.C
                                                                               (fetch
                                                                                (IPADDRESS CLASSC)
                                                                                  of DATUM))
                                                                           (fetch (IPADDRESS
                                                                                       CLASSCHOST)
                                                                              of DATUM))
                                                                          (T (ERROR 
                                                                              "Illegal address class"
                                                                                    DATUM)))
                                                                (COND
                                                                   ((EQ \IP.CLASS.A
                                                                        (fetch (IPADDRESS CLASSA)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS 
                                                                                        CLASSAHOST)
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   ((EQ \IP.CLASS.B
                                                                        (fetch (IPADDRESS CLASSB)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS 
                                                                                        CLASSBHOST)
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   ((EQ \IP.CLASS.C
                                                                        (fetch (IPADDRESS CLASSC)
                                                                           of DATUM))
                                                                    (replace (IPADDRESS 
                                                                                        CLASSCHOST)
                                                                       of DATUM with NEWVALUE
                                                                           ))
                                                                   (T (ERROR "Illegal address class"
                                                                             DATUM]
                  (TYPE? (type? ETHERPACKET DATUM)))

(DATATYPE IPSOCKET ((PROTOCOL BYTE)
                        (IPSLINK POINTER)                    (* ; 
                                                           "Other sockets of this protocol type")
                        (NIL BYTE)
                        (IPSQUEUE POINTER)                   (* ; 
                                                           "Queue of packets for this protocol")
                        (IPSQUEUELENGTH WORD)                (* ; "Count of packets of input queue")
                        (IPSQUEUEALLOC WORD)                 (* ; "Max count allowed")
                        (IPSDESTSOCKETCOMPAREFN POINTER)     (* ; 
                                         "Call this to compare dest protocol socket to this socket")
                        (IPSOCKET POINTER)                   (* ; "This socket")
                        (IPSINPUTFN POINTER)                 (* ; "Call to hand packet to protocol")
                        (IPSEVENT POINTER)                   (* ; "Notify me when a packet arrives")
                        (IPSNOSOCKETFN POINTER)              (* ; "Call this when no socket found")
                        (IPSICMPFN POINTER)                  (* ; 
                                       "Call this when an ICMP packet is received on this protocol")
                        )
                       IPSQUEUE _ (create SYSQUEUE)
                       IPSQUEUEALLOC _ \IP.MAX.EPKTS.ON.QUEUE IPSEVENT _ (CREATE.EVENT)
                       IPSINPUTFN _ (FUNCTION \IP.DEFAULT.INPUTFN)
                       IPSICMPFN _ (FUNCTION \RELEASE.ETHERPACKET))

(BLOCKRECORD IPADDRESS ((ADDRESS FIXP))

                           (* ;; "Class A nets: high bit is 0")

                           (BLOCKRECORD IPADDRESS ((CLASSA BITS 1)
                                                   (CLASSANET BITS 7)
                                                   (CLASSAHOST BITS 24)))

                           (* ;; "Class B nets: high 2 bits are 10")

                           (BLOCKRECORD IPADDRESS ((CLASSB BITS 2)))
                           (BLOCKRECORD IPADDRESS ((CLASSBNET BITS 16)
                                                   (CLASSBHOST BITS 16)))

                           (* ;; "Class C nets: high 3 bits are 110")

                           (BLOCKRECORD IPADDRESS ((CLASSC BITS 3)))
                           (BLOCKRECORD IPADDRESS ((CLASSCNETB1 BITS 8)
                                                   (CLASSCNETB2 BITS 8)
                                                   (CLASSCNETB3 BITS 8)
                                                   (CLASSCHOST BITS 8)))
                                                             (* ; 
                          "I wish I could say just net bits 24, host bits 8, but BLOCKRECORD barfs")
                           (BLOCKRECORD IPADDRESS ((CLASSCNETHI BITS 16)))
                           [ACCESSFNS IPADDRESS ((CLASSCNET (\MAKENUMBER (FETCH CLASSCNETB1
                                                                            OF DATUM)
                                                                   (LOGOR (LLSH (FETCH 
                                                                                       CLASSCNETB2
                                                                                   OF DATUM)
                                                                                8)
                                                                          (FETCH CLASSCNETB3
                                                                             OF DATUM)))
                                                        (PROGN (REPLACE CLASSCNETHI OF DATUM
                                                                  WITH (LRSH NEWVALUE 8))
                                                               (REPLACE CLASSCNETB3 OF DATUM
                                                                  WITH (LOGAND NEWVALUE 255))
                                                               DATUM])
)

(/DECLAREDATATYPE 'IPSOCKET '(BYTE POINTER BYTE POINTER WORD WORD POINTER POINTER POINTER POINTER 
                                   POINTER POINTER)
       '((IPSOCKET 0 (BITS . 7))
         (IPSOCKET 0 POINTER)
         (IPSOCKET 2 (BITS . 7))
         (IPSOCKET 2 POINTER)
         (IPSOCKET 4 (BITS . 15))
         (IPSOCKET 5 (BITS . 15))
         (IPSOCKET 6 POINTER)
         (IPSOCKET 8 POINTER)
         (IPSOCKET 10 POINTER)
         (IPSOCKET 12 POINTER)
         (IPSOCKET 14 POINTER)
         (IPSOCKET 16 POINTER))
       '18)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \IPOVLEN 20)

(RPAQQ \MAX.IPDATALENGTH 556)

(RPAQQ \IP.PROTOCOLVERSION 4)

(RPAQQ \IP.MAX.EPKTS.ON.QUEUE 16)

(RPAQQ \IP.DEFAULT.TIME.TO.LIVE 120)

(RPAQQ \IP.WAKEUP.INTERVAL 15000)


(CONSTANTS \IPOVLEN \MAX.IPDATALENGTH \IP.PROTOCOLVERSION \IP.MAX.EPKTS.ON.QUEUE 
       \IP.DEFAULT.TIME.TO.LIVE \IP.WAKEUP.INTERVAL)
)

(RPAQQ IPPACKETTYPES ((\EPT.IP 2048)
                          (\EPT.AR 2054)
                          (\EET.IP 513)
                          (\EPT.CHAOS 2052)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \EPT.IP 2048)

(RPAQQ \EPT.AR 2054)

(RPAQQ \EET.IP 513)

(RPAQQ \EPT.CHAOS 2052)


(CONSTANTS (\EPT.IP 2048)
       (\EPT.AR 2054)
       (\EET.IP 513)
       (\EPT.CHAOS 2052))
)

(RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0)
                             (\ICMP.HOST.UNREACHABLE 1)
                             (\ICMP.PROTOCOL.UNREACHABLE 2)
                             (\ICMP.PORT.UNREACHABLE 3)
                             (\ICMP.CANT.FRAGMENT 4)
                             (\ICMP.SOURCE.ROUTE 5)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.NET.UNREACHABLE 0)

(RPAQQ \ICMP.HOST.UNREACHABLE 1)

(RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2)

(RPAQQ \ICMP.PORT.UNREACHABLE 3)

(RPAQQ \ICMP.CANT.FRAGMENT 4)

(RPAQQ \ICMP.SOURCE.ROUTE 5)


(CONSTANTS (\ICMP.NET.UNREACHABLE 0)
       (\ICMP.HOST.UNREACHABLE 1)
       (\ICMP.PROTOCOL.UNREACHABLE 2)
       (\ICMP.PORT.UNREACHABLE 3)
       (\ICMP.CANT.FRAGMENT 4)
       (\ICMP.SOURCE.ROUTE 5))
)
(DECLARE%: EVAL@COMPILE 

[PUTPROPS \IPDATABASE MACRO (LAMBDA (IP)                 (* ejs%: "26-Dec-84 17:50")
                                                             (* Returns the LOCF of the start of 
                                                           the data in the packet)
                              (\ADDBASE (fetch (IP IPBASE) of IP)
                                     (UNFOLD (fetch (IP IPHEADERLENGTH) of IP)
                                            2]

[PUTPROPS \IPDATALENGTH MACRO (LAMBDA (IP)
                                (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of IP)
                                       (LLSH (fetch (IP IPHEADERLENGTH) of IP)
                                             2]
)

(* "END EXPORTED DEFINITIONS")

)

(ADDTOVAR *IP-PROTOCOL-NAME-FROM-NUMBER* (17 . "UDP")
                                             (6 . "TCP")
                                             (1 . "ICMP"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *IP-PROTOCOL-NAME-FROM-NUMBER*)
)



(* ;; 
"value in sysout is too small.  This is 512-(indexf (fetch epencapsulation))-2.  489 is more correct, but let's leave a word of slop for off-by-ones"
)


(RPAQQ \10MBPACKETLENGTH 488)



(* ;; "Make it easier to see queuelength without opening up q.")

(DEFINEQ

(\SYSQUEUE.DEFPRINT
  [LAMBDA (Q STREAM)                                     (* ; "Edited  8-Sep-89 11:06 by bvm")
    (\DEFPRINT.BY.NAME Q STREAM (if (fetch (SYSQUEUE SYSQUEUEHEAD) of Q)
                                    then (\QUEUELENGTH Q)
                                  else "Empty")
           "SysQueue"])

(\IPSOCKET.DEFPRINT
  [LAMBDA (SOCKET STREAM)                                (* ; "Edited 25-Aug-88 17:51 by bvm")

    (* ;; "Print an object using its name, for example, #<FDev ERIS/76,5432>.  NAME is the object's name (or NIL if this one happens to be nameless), TYPENAME is a string giving the generic name you want to appear in front, e.g., %"FDev%"")

    (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
    (\OUTCHAR STREAM (CHARCODE <))
    (LET ((TYPE (CDR (ASSOC (fetch (IPSOCKET PROTOCOL) of SOCKET)
                            *IP-PROTOCOL-NAME-FROM-NUMBER*)))
          (NUM (fetch (IPSOCKET IPSOCKET) of SOCKET))
          (*PRINT-BASE* 10))
         (\SOUT (if TYPE
                    then (MKSTRING TYPE)
                  else "IP")
                STREAM)
         (\SOUT " Socket" STREAM)
         (if (if (FIXP NUM)
                   elseif (NULL NUM)
                     then                                (* ; "I assume this is the master")
                           (SETQ NUM "Head"))
             then (\OUTCHAR STREAM (CHARCODE SPACE))
                   (PRIN3 NUM STREAM)))
    (\OUTCHAR STREAM (CHARCODE /))
    (\PRINTADDR SOCKET STREAM)
    (\OUTCHAR STREAM (CHARCODE >))
    T])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(DEFPRINT 'IPSOCKET '\IPSOCKET.DEFPRINT)


(DEFPRINT 'SYSQUEUE '\SYSQUEUE.DEFPRINT)
)

(RPAQ? IPTRACETIME )

(RPAQ? IPONLYTYPES )

(RPAQ? IPIGNORETYPES )

(RPAQ? IPPRINTMACROS )

(RPAQ? IPTRACEFLG )

(RPAQ? IPTRACEFILE )

(RPAQ? \IP.INIT.FILE )

(RPAQ? \IP.DEFAULT.CONFIGURATION )

(RPAQ? \IP.HOSTNAMES (HASHARRAY 40 1.1))

(RPAQ? \IP.HOSTNUMBERS )

(RPAQ? INTERNET.LOCAL.DOMAIN )

(/DECLAREDATATYPE 'IPSOCKET '(BYTE POINTER BYTE POINTER WORD WORD POINTER POINTER POINTER POINTER 
                                   POINTER POINTER)
       '((IPSOCKET 0 (BITS . 7))
         (IPSOCKET 0 POINTER)
         (IPSOCKET 2 (BITS . 7))
         (IPSOCKET 2 POINTER)
         (IPSOCKET 4 (BITS . 15))
         (IPSOCKET 5 (BITS . 15))
         (IPSOCKET 6 POINTER)
         (IPSOCKET 8 POINTER)
         (IPSOCKET 10 POINTER)
         (IPSOCKET 12 POINTER)
         (IPSOCKET 14 POINTER)
         (IPSOCKET 16 POINTER))
       '18)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS IPTRACEFILE IPTRACEFLG IPIGNORETYPES IPONLYTYPES IPPRINTMACROS \IP.HOSTNAMES 
       \IP.INIT.FILE INTERNET.LOCAL.DOMAIN \IP.DEFAULT.CONFIGURATION \IP.HOSTNUMBERS)
)

(FILESLOAD (SYSLOAD)
       TCPHTE TCPLLICMP TCPLLAR)

(ADDTOVAR \PACKET.PRINTERS (2048 . PRINTIP))
(DEFINEQ

(\CANONICALIZE.IP.HOSTNAME
  [LAMBDA (NAME)                                         (* ; "Edited 12-Apr-88 17:18 by bvm")
    (AND \IP.READY (IPHOSTADDRESS NAME)
         NAME])

(DODIP.HOSTP
  [LAMBDA (NAME)                                         (* ; "Edited 27-Feb-89 21:49 by welch")
    (COND
       ((NULL NAME)
        NIL)
       ((NUMBERP NAME))
       (T (LET [(NAME (\DOMAIN.NAME.QUALIFY.FULLY (U-CASE NAME]
               (COND
                  ((IPHOSTADDRESS NAME))
                  (T (if (CL:FBOUNDP 'DOMAIN.LOOKUP.ADDRESS)
                         then (CAR (DOMAIN.LOOKUP.ADDRESS NAME])

(IPHOSTADDRESS
  [LAMBDA (NAME)                                         (* ; "Edited 19-Jan-88 14:41 by FS")
    (LET (ENTRY)

         (* ;; "Hack to handle strings, by canonicalizing NAME")

         (SETQ NAME (MKATOM (U-CASE NAME)))
         (SETQ ENTRY (GETHASH NAME \IP.HOSTNAMES))
         (COND
            (ENTRY (LET [(ADDRESS (CAR (fetch (HOSTS.TXT.ENTRY HTE.ADDRESSES) of ENTRY]
                        [COND
                           ((NOT (SASSOC ADDRESS \IP.HOSTNUMBERS))
                            (push \IP.HOSTNUMBERS (CONS ADDRESS NAME]
                        ADDRESS))
            ((\IP.READ.STRING.ADDRESS NAME])

(IPHOSTNAME
  [LAMBDA (IPADDRESS)                                    (* ejs%: "22-Apr-85 13:54")
    (OR (CDR (SASSOC IPADDRESS \IP.HOSTNUMBERS))
        (MKATOM (\IP.ADDRESS.TO.STRING IPADDRESS])

(IPTRACE
  [LAMBDA (FLG REGION)                                   (* ; "Edited 13-Sep-88 14:53 by bvm")
    (MAKE-NETWORK-TRACE-WINDOW 'IPTRACEFLG 'IPTRACEFILE "IP traffic" REGION FLG])

(IPTRACEWINDOW.BUTTONFN
  [LAMBDA (WINDOW)                                       (* ejs%: " 2-Jun-85 13:05")
    (COND
       ((MOUSESTATE (NOT UP))
        (SETQ IPTRACEFLG (SELECTQ IPTRACEFLG
                             (NIL T)
                             (T 'PEEK)
                             (PEEK NIL)
                             NIL))
        (printout WINDOW T "[Tracing " (SELECTQ IPTRACEFLG
                                           (T "on")
                                           (PEEK "peek")
                                           "off")
               "]" T])

(PRINTIP
  [LAMBDA (IP CALLER FILE PRE.NOTE DOFILTER)             (* ; "Edited 28-Apr-88 14:05 by bvm")
    (PROG ((*STANDARD-OUTPUT* (GETSTREAM (OR FILE IPTRACEFILE)
                                     'OUTPUT))
           (PROTOCOL (fetch (IP IPPROTOCOL) of IP))
           MACRO LENGTH)
          [COND
             (DOFILTER (COND
                          ((COND
                              (IPONLYTYPES (NOT (FMEMB PROTOCOL IPONLYTYPES)))
                              (IPIGNORETYPES (FMEMB PROTOCOL IPIGNORETYPES)))
                           (RETURN (PRIN1 (SELECTQ CALLER
                                              ((PUT RAWPUT) 
                                                   '!)
                                              ((GET RAWGET) 
                                                   '+)
                                              '?]
          (AND PRE.NOTE (printout NIL T PRE.NOTE))
          (if CALLER
              then                                       (* ; "Print GET or PUT")
                    (FRESHLINE)
                    (PRINTOUT NIL CALLER " "))
          (printout NIL "From " (\IP.ADDRESS.TO.STRING (fetch (IP IPSOURCEADDRESS)
                                                              of IP))
                 " to "
                 (\IP.ADDRESS.TO.STRING (fetch (IP IPDESTINATIONADDRESS) of IP)))
          (if IPTRACETIME
              then (LET ((CSECS (\CENTICLOCK IP)))
                            (PRINTOUT NIL " [" |.I4| (IQUOTIENT CSECS 100)
                                   "." |.I2..T| (IREMAINDER CSECS 100)
                                   "]")))
          (TERPRI)
          [COND
             ((AND (SETQ MACRO (CDR (FASSOC PROTOCOL IPPRINTMACROS)))
                   (NLISTP MACRO))                           (* ; 
                                       "Macro is a function to which to dispatch for the printing.")
              (CL:FUNCALL MACRO IP *STANDARD-OUTPUT*)
              (RETURN (TERPRI]
          (printout NIL "Length = " |.P2| (SETQ LENGTH (fetch (IP IPTOTALLENGTH) of IP))
                 " bytes" " (header + " |.P2| (IDIFFERENCE LENGTH \IPOVLEN)
                 ")" T "Protocol = ")
          (PRINTCONSTANT PROTOCOL IPPROTOCOLTYPES NIL)
          (TERPRI)
          [COND
             ((IGREATERP LENGTH \IPOVLEN)                    (* ; "MACRO tells how to print data.")
              (PRIN1 "Contents: ")
              (PRINTIPDATA IP (OR MACRO '(BYTES 12 |...|]
          (TERPRI)
          (RETURN IP])

(PRINTIPDATA
  [LAMBDA (IP MACRO OFFSET FILE)                         (* ejs%: "27-Dec-84 18:43")

         (* * Prints DATA part of IP starting at OFFSET
       (Default zero) according to MACRO. MACRO contains elements describing what 
       format the data is in -
       WORDS, BYTES, CHARS%: print as words, bytes
       (numeric) or ascii characters -
       <number>%: subsequent commands apply starting at this byte offset -
       ...%: print "..." and quit if you still have data at this point)

    (PROG ((DATA (\IPDATABASE IP))
           (LENGTH (\IPDATALENGTH IP)))
          (PRINTPACKETDATA DATA OFFSET MACRO LENGTH FILE])

(\IPADDRESSCLASS
  [LAMBDA (IPADDRESS)                                    (* ; "Edited 26-Oct-88 12:49 by bvm")
    (if (SMALLP IPADDRESS)
        then                                             (* ; "bogus unless it's broadcastp")
              '\IP.CLASS.A
      elseif (EQ \IP.CLASS.C (SETQ IPADDRESS (fetch (IPADDRESS CLASSC) of IPADDRESS)))
        then '\IP.CLASS.C
      elseif (EQ \IP.CLASS.B (SETQ IPADDRESS (LRSH IPADDRESS 1)))
        then '\IP.CLASS.B
      elseif (EQ \IP.CLASS.A (LRSH IPADDRESS 1))
        then '\IP.CLASS.A])

(\IPEVENTFN
  [LAMBDA (EVENT)                               (* ; "Edited 13-Sep-88 18:53 by Hiroshi Hayata")

    (* ;; "If maiko, do nothing. ")

    (* ;; "Call of \IPINIT with AFTERSYSOUT on maiko cause RAID.")

    (COND
       ((EQ \MACHINETYPE \MAIKO)
        NIL)
       (T (COND
             (\IPFLG (\IPINIT EVENT])

(\IPHOSTADDRESS
  [LAMBDA (IPADDRESS)                                    (* ; "Edited 26-Oct-88 12:43 by bvm")
    (if (SMALLP IPADDRESS)
        then                                             (* ; "can only be class a or bogus")
              (LOGAND IPADDRESS MAX.SMALLP)
      elseif (EQ (fetch (IPADDRESS CLASSA) of IPADDRESS)
                     \IP.CLASS.A)
        then (fetch (IPADDRESS CLASSAHOST) of IPADDRESS)
      elseif (EQ (fetch (IPADDRESS CLASSB) of IPADDRESS)
                     \IP.CLASS.B)
        then (fetch (IPADDRESS CLASSBHOST) of IPADDRESS)
      elseif (EQ (fetch (IPADDRESS CLASSC) of IPADDRESS)
                     \IP.CLASS.C)
        then (fetch (IPADDRESS CLASSCHOST) of IPADDRESS])

(\IPNETADDRESS
  [LAMBDA (IPADDRESS)                                    (* ; "Edited 26-Oct-88 12:45 by bvm")
    (if (SMALLP IPADDRESS)
        then                                             (* ; "bogus unless it's broadcastp")
              (if (< IPADDRESS 0)
                  then -1
                else 0)
      elseif (EQ (fetch (IPADDRESS CLASSA) of IPADDRESS)
                     \IP.CLASS.A)
        then (fetch (IPADDRESS CLASSANET) of IPADDRESS)
      elseif (EQ (fetch (IPADDRESS CLASSB) of IPADDRESS)
                     \IP.CLASS.B)
        then (fetch (IPADDRESS CLASSBNET) of IPADDRESS)
      elseif (EQ (fetch (IPADDRESS CLASSC) of IPADDRESS)
                     \IP.CLASS.C)
        then (fetch (IPADDRESS CLASSCNET) of IPADDRESS])

(\IP.ADDRESS.TO.STRING
  [LAMBDA (IPADDRESS)                                    (* ejs%: "28-Dec-84 08:43")
    (RESETFORM (RADIX 10)
           (CONCAT (LDB (BYTE 8 24)
                        IPADDRESS)
                  "."
                  (LDB (BYTE 8 16)
                       IPADDRESS)
                  "."
                  (LDB (BYTE 8 8)
                       IPADDRESS)
                  "."
                  (LDB (BYTE 8 0)
                       IPADDRESS])

(\IP.BROADCAST.ADDRESS
  [LAMBDA (IPADDRESS)                                    (* ; "Edited 26-Oct-88 14:59 by bvm")

    (* ;; 
  "0's in the host field are now considered broadcasts, so this code works with Berkeley Unix")

    (LET (HOST MASK)
         (if (SMALLP IPADDRESS)
             then (OR (EQ IPADDRESS 0)
                          (EQ IPADDRESS -1))
           elseif (EQ (fetch (IPADDRESS CLASSA) of IPADDRESS)
                          \IP.CLASS.A)
             then [if (AND \IP.SUBNET.MASKS (ASSOC (fetch (IPADDRESS CLASSANET)
                                                              of IPADDRESS)
                                                           \IP.LOCAL.NETWORKS))
                          then                           (* ; 
    "If it's our subnet, check only the subnetted host part.  The LOGOR patches bogus subnet masks")
                                [SETQ HOST (LOGAND IPADDRESS (SETQ MASK (LOGXOR (LOGOR (CDAR 
                                                                                     \IP.SUBNET.MASKS
                                                                                             )
                                                                                       -16777216)
                                                                               -1]
                                (OR (EQ HOST 0)
                                    (EQL HOST MASK))
                        else (SETQ HOST (fetch (IPADDRESS CLASSAHOST) of IPADDRESS))
                              (OR (EQ HOST 0)
                                  (EQL HOST (MASK.1'S 0 24]
           elseif (EQ (fetch (IPADDRESS CLASSB) of IPADDRESS)
                          \IP.CLASS.B)
             then [if (AND \IP.SUBNET.MASKS (ASSOC (fetch (IPADDRESS CLASSBNET)
                                                              of IPADDRESS)
                                                           \IP.LOCAL.NETWORKS))
                          then [SETQ HOST (LOGAND IPADDRESS (SETQ MASK (LOGXOR
                                                                            (LOGOR (CDAR 
                                                                                     \IP.SUBNET.MASKS
                                                                                         )
                                                                                   -65536)
                                                                            -1]
                                (OR (EQ HOST 0)
                                    (EQ HOST MASK))
                        else (SETQ HOST (fetch (IPADDRESS CLASSBHOST) of IPADDRESS))
                              (OR (EQ HOST 0)
                                  (EQ HOST (MASK.1'S 0 16]
           elseif (EQ (fetch (IPADDRESS CLASSC) of IPADDRESS)
                          \IP.CLASS.C)
             then (SETQ HOST (fetch (IPADDRESS CLASSCHOST) of IPADDRESS)) 
                                                             (* ; "No subnetting here")
                   (OR (EQ HOST 0)
                       (EQ HOST (MASK.1'S 0 8)))
           elseif (EQ (fetch (IPADDRESS CLASSBNET) of IPADDRESS)
                          MAX.SMALLP)
             then                                        (* ; 
                                             "Sort of illegal, but recognize all ones as broadcast")
                   (EQ (fetch (IPADDRESS CLASSBHOST) of IPADDRESS)
                       MAX.SMALLP])

(\IP.LEGAL.ADDRESS
  [LAMBDA (ADDRESS)                                      (* ejs%: "25-Mar-86 16:00")
    (AND (NOT (EQ ADDRESS 0))
         (NOT (EQ ADDRESS -1))
         (OR (EQ \IP.CLASS.C (SETQ ADDRESS (LRSH ADDRESS 29)))
             (EQ \IP.CLASS.B (SETQ ADDRESS (LRSH ADDRESS 1)))
             (EQ \IP.CLASS.A (LRSH ADDRESS 1])

(\IP.MAKE.BROADCAST.ADDRESS
  [LAMBDA (IPADDRESS)                                    (* ejs%: " 3-Jun-85 01:02")
    (SELECTQ (\IPADDRESSCLASS IPADDRESS)
        (\IP.CLASS.A (LOGOR (MASK.1'S 0 24)
                            IPADDRESS))
        (\IP.CLASS.B (LOGOR (MASK.1'S 0 16)
                            IPADDRESS))
        (\IP.CLASS.C (LOGOR (MASK.1'S 0 8)
                            IPADDRESS))
        (SHOULDNT])

(\IP.PRINT.ADDRESS
  [LAMBDA (IPADDRESS FILE)                               (* ejs%: "28-Dec-84 08:42")
    (RESETFORM (RADIX 10)
           (PRIN1 (LDB (BYTE 8 24)
                       IPADDRESS)
                  FILE)
           (PRIN1 "." FILE)
           (PRIN1 (LDB (BYTE 8 16)
                       IPADDRESS)
                  FILE)
           (PRIN1 "." FILE)
           (PRIN1 (LDB (BYTE 8 8)
                       IPADDRESS)
                  FILE)
           (PRIN1 "." FILE)
           (PRIN1 (LDB (BYTE 8 0)
                       IPADDRESS)
                  FILE)
           IPADDRESS])

(\IP.READ.STRING.ADDRESS
  [LAMBDA (STRING.OR.ATOM)                               (* ; "Edited 21-Apr-88 14:41 by bvm")
    (for CHAR instring (MKSTRING STRING.OR.ATOM) bind (RESULT _ (NCREATE 'FIXP))
                                                               (INDEX _ 0)
                                                               BYTE
       do (if (> INDEX 3)
                  then                                   (* ; 
                                            "Got 3 parts and there's still more to go, must be bad")
                        (RETURN NIL)
                elseif (EQ CHAR (CHARCODE %.))
                  then (if BYTE
                               then (\PUTBASEBYTE RESULT INDEX BYTE))
                        (SETQ BYTE NIL)
                        (add INDEX 1)
                elseif (AND (SETQ CHAR (CL:DIGIT-CHAR-P (CL:INT-CHAR CHAR)))
                                (< (SETQ BYTE (+ (if BYTE
                                                     then (TIMES BYTE 10)
                                                   else 0)
                                                 CHAR))
                                   256))
                  then                                   (* ; 
                                  "Accumulated decimal digit, and we haven't overflowed a byte yet")
                else                                     (* ; "Malformed")
                      (RETURN NIL)) finally (if BYTE
                                                    then (\PUTBASEBYTE RESULT INDEX BYTE)
                                                          (add INDEX 1))
                                          (RETURN (AND (EQ INDEX 4)
                                                       RESULT])

(\DOMAIN.NAME.QUALIFY.FULLY
  [LAMBDA (NAME)                                       (* ; "Edited 29-Aug-90 16:27 by gadener")
                                                             (* Make a fully qualified domain 
                                                           name from a partial one)
    (if (OR (NULL INTERNET.LOCAL.DOMAIN)
                (STRPOS "." NAME))
        then NAME
      else (MKATOM (CONCAT NAME "." INTERNET.LOCAL.DOMAIN])
)



(* ;; "Startup and shutdown")


(RPAQ? *IP-DEFAULT-HOSTS-FILE* )

(RPAQ? TCP.ALWAYS.READ.HOSTS.FILE T)

(RPAQ? \TCP.LAST.HOSTS.FILE.DATE )

(RPAQ? \TCP.LAST.HOSTS.FILE.READ )

(RPAQ? \IPFLG )

(RPAQ? \IP.READY )

(RPAQ? \IP.READY.EVENT (CREATE.EVENT "IP Ready"))

(RPAQ? \IP.WAKEUP.TIMER )

(RPAQ? IPTRACEFLG )

(RPAQ? \IP.WAKEUP.EVENT (CREATE.EVENT "IP Wakeup"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IPFLG \IP.READY \IP.READY.EVENT \IP.WAKEUP.TIMER \IP.WAKEUP.EVENT 
       TCP.ALWAYS.READ.HOSTS.FILE \TCP.LAST.HOSTS.FILE.DATE \TCP.LAST.HOSTS.FILE.READ 
       *IP-DEFAULT-HOSTS-FILE*)
)
(DEFINEQ

(STOPIP
  [LAMBDA NIL                                            (* ejs%: "28-Dec-84 08:10")
    (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.IP))
    (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.AR))
    (DEL.PROCESS '\IPLISTENER)
    (SETQ \IPFLG (SETQ \IP.READY NIL])

(\IPINIT
  [LAMBDA (EVENT)                                        (* ; "Edited 18-Mar-88 17:22 by bvm")

    (* ;; "Initialize IP protocol.  Called with EVENT NIL for explicit restart, RESTART from RESTART.ETHER, otherwise from usual around exit events via \ETHEREVENTFN and RESTARTETHERFNS after Pup and/an \icmp.echo.reply")

    (* ;; "or NS turned on.")

    (SELECTQ EVENT
        ((NIL RESTART AFTERSYSOUT AFTERMAKESYS AFTERLOGOUT AFTERSAVEVM) 
             (if (AND (NULL \IPFLG)
                          (NOT (NULL EVENT)))
                 then                                    (* ; 
                                     "Nothing to do.  Only turn IP on for explicit call to \IPINIT")
                       NIL
               elseif [OR (NULL EVENT)
                              (NULL \IP.DEFAULT.CONFIGURATION)
                              (NOT (EQUAL \MY.NSHOSTNUMBER (fetch (IPINIT LOCAL.NSHOSTNUMBER)
                                                              of \IP.DEFAULT.CONFIGURATION]
                 then                                    (* ; 
                           "Machine changed, or caller explicitly wants us to reread the init file")
                       (SETQ \IP.DEFAULT.CONFIGURATION NIL)
                       (SETQ \IP.LOCAL.ADDRESSES NIL)
                       (SETQ \IP.LOCAL.NETWORKS NIL)
                       (SETQ \IP.SUBNET.MASKS NIL)
                       (DEL.PROCESS '\IPLISTENER)
                       [SELECTQ EVENT
                           ((NIL RESTART)                    (* ; "Can do it here--explicit manual restart.  Otherwise spawn process, so that we can do arbitrary things like rely on other devices initialized later than ether")
                                (\IP.REINITIALIZE.FROM.SCRATCH))
                           (ADD.PROCESS `(\IP.REINITIALIZE.FROM.SCRATCH ',EVENT]
               else (\IP.RESTART.FROM.CONFIGURATION EVENT)))
        NIL])

(\IPLISTENER
  [LAMBDA NIL                                            (* ejs%: "25-Jun-85 18:52")

         (* * IP background process)

    (SETQ \IP.WAKEUP.TIMER (SETUPTIMER \IP.WAKEUP.INTERVAL))
    (bind [\AR.WAKEUP.TIMER _ (SETUPTIMER (CONSTANT (ITIMES 4 \IP.WAKEUP.INTERVAL] while
                                                                                       T
       do (AWAIT.EVENT \IP.WAKEUP.EVENT \IP.WAKEUP.INTERVAL)
             (\IP.CHECK.REASSEMBLY.TIMEOUTS)
             (COND
                ((TIMEREXPIRED? \AR.WAKEUP.TIMER)
                 (\AR.DAEMON)
                 (SETQ \AR.WAKEUP.TIMER (SETUPTIMER (CONSTANT (ITIMES 4 \IP.WAKEUP.INTERVAL))
                                               \AR.WAKEUP.TIMER])

(\IP.REINITIALIZE.FROM.SCRATCH
  [LAMBDA (EVENT)                                        (* ; "Edited 20-Jan-89 18:35 by bvm")
    (DECLARE (GLOBALVARS \IP.DEFAULT.CONFIGURATION \IP.LOCAL.ADDRESSES))

    (* ;; "Called when we have never enabled IP, or the machine's address has changed.")

    (RESETBUFS (PROG (FILE ADDRESS.STRING HOSTS.FILE HOSTNAME ADDRESSES)

                (* ;; 
         "This is a kludge until we know more about IP routing and reverse address resolution (??)")

                     [SETQ \IP.DEFAULT.CONFIGURATION (COND
                                                        ((AND (SETQ FILE (INFILEP '{DSK}IP.INIT))
                                                              (\IP.READ.INIT.FILE FILE)))
                                                        ((IP.DEFAULT.CONFIGURATION))
                                                        ((AND (SETQ FILE (\IP.PROMPT.FOR.FILE.NAME
                                                                          
                                "Please enter the name of the IP initialization file for this host: "
                                                                          ))
                                                              (\IP.READ.INIT.FILE FILE)))
                                                        (T   (* ; 
                                        "User declined to specify, or init file failed, so give up")
                                                           (PRINTOUT T "IP not initialized" T)
                                                           (RETURN NIL]
                     (COND
                        ((SETQ FILE (OR (fetch (IPINIT HTE.FILE) of \IP.DEFAULT.CONFIGURATION
                                               )
                                        *IP-DEFAULT-HOSTS-FILE*))

                         (* ;; 
               "there is a hosts file in the configuration.  Now see if we really want to read it.")

                         (\IP.MAYBE.READ.HOSTS.TXT T FILE)))
                     (COND
                        ([AND (NOT (SETQ HOSTNAME (fetch (IPINIT HOSTNAME) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                         )))
                              (SETQ HOSTNAME (AND (EQ \PUP.READY T)
                                                  (U-CASE (ETHERHOSTNAME]
                         (replace (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION with
                                                                                         HOSTNAME)))
                     [COND
                        [(SETQ ADDRESSES (fetch (IPINIT LOCAL.ADDRESSES) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                ))
                         (SETQ \IP.LOCAL.ADDRESSES (for ADDR in ADDRESSES
                                                      collect (\IP.READ.STRING.ADDRESS ADDR]
                        ((AND HOSTNAME (SETQ ADDRESSES (DODIP.HOSTP HOSTNAME)))
                         (SETQ \IP.LOCAL.ADDRESSES (LIST ADDRESSES)))
                        (T (until (SETQ ADDRESS.STRING (PROMPTFORWORD 
                                        "Please enter this machine's IP host address (e.g. 39.9.0.9)"
                                                                  )))
                           (SETQ \IP.LOCAL.ADDRESSES (LIST (\IP.READ.STRING.ADDRESS 
                                                                  ADDRESS.STRING)))
                           (COND
                              (HOSTNAME                      (* ; 
                                                           "Associate name with local address(es)")
                                     (PUTHASH HOSTNAME [create HOSTS.TXT.ENTRY
                                                              HTE.TYPE _ 'HOST
                                                              HTE.ADDRESSES _ \IP.LOCAL.ADDRESSES
                                                              HTE.NAMES _ (LIST HOSTNAME)
                                                              HTE.MACHINE.TYPE _
                                                              (SELECTQ (MACHINETYPE)
                                                                  (DOVE 'XEROX-1185)
                                                                  (DANDELION 'XEROX-1108)
                                                                  (DOLPHIN 'XEROX-1100)
                                                                  (DORADO 'XEROX-1132)
                                                                  'XEROX-11XX)
                                                              HTE.OS.TYPE _ 'INTERLISP
                                                              HTE.PROTOCOLS _ '((TCP)
                                                                                (IP]
                                            \IP.HOSTNAMES]
                     (\IP.RESTART.FROM.CONFIGURATION EVENT T])

(\IP.RESTART.FROM.CONFIGURATION
  [LAMBDA (EVENT NEW.INIT)                               (* ; "Edited 26-Feb-89 21:28 by welch")

    (* ;; "Reinitialize IP after logout, etc, from the info in the default configuration.  This is the only place that sets \IP.READY true.")

    (GLOBALVARS INTERNET.LOCAL.DOMAIN)
    (PROG ((GATE (fetch (IPINIT DEFAULT.GATEWAY) of \IP.DEFAULT.CONFIGURATION))
           (NETS (fetch (IPINIT LOCAL.NETWORKS) of \IP.DEFAULT.CONFIGURATION))
           PROC NDB)
          (SETQ \IP.DEFAULT.GATEWAY (AND GATE (\IP.READ.STRING.ADDRESS GATE)))
          (SETQ \IP.ROUTING.TABLE (CONS))
          (SETQ \AR.IP.TO.10MB.ALIST NIL)
          (SETQ INTERNET.LOCAL.DOMAIN (fetch (IPINIT LOCAL.DOMAIN) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                             ))
          [COND
             [(EQLENGTH NETS (LENGTH \IP.LOCAL.ADDRESSES))

              (* ;; 
  "List tells net numbers of each directly connected net.  Each element = (%"net.number%" . type).")

              (SETQ \IP.LOCAL.NETWORKS (bind NDB for NET.AND.TYPE in NETS as ADDRESS
                                          in \IP.LOCAL.ADDRESSES
                                          collect (LET* [(TYPE (CDR NET.AND.TYPE))
                                                             [NET (\IPNETADDRESS
                                                                   (\IP.READ.STRING.ADDRESS
                                                                    (CAR NET.AND.TYPE]
                                                             (NDB (SELECTQ TYPE
                                                                      (3 \3MBLOCALNDB)
                                                                      (10 \10MBLOCALNDB)
                                                                      (SHOULDNT]
                                                            (replace (NDB NDBIPNET#) of
                                                                                         NDB
                                                               with NET)
                                                            (replace (NDB NDBIPHOST#)
                                                               of NDB with ADDRESS)
                                                            (CONS NET NDB]
             ((NULL \IP.LOCAL.ADDRESSES)
              (RETURN (CL:WARN "Error in IP init file.  No local host address specified")))
             ((AND (NULL (CDR \IP.LOCAL.ADDRESSES))
                   (NULL (fetch (NDB NDBNEXT) of \LOCALNDBS)))
                                                             (* ; 
                                                    "Only one address, so it goes with our one net")
              [SETQ \IP.LOCAL.NETWORKS (LIST (CONS (\IPNETADDRESS (CAR \IP.LOCAL.ADDRESSES))
                                                   (SETQ NDB (OR \10MBLOCALNDB \3MBLOCALNDB]
              (replace (NDB NDBIPNET#) of NDB with (CAAR \IP.LOCAL.NETWORKS))
              (replace (NDB NDBIPHOST#) of NDB with (CAR \IP.LOCAL.ADDRESSES)))
             (T (RETURN (CL:WARN 
                      "Error in IP init file.  Network list and local address list do not correlate."
                               ]
          [SETQ \IP.SUBNET.MASKS (for LOCALADDR in \IP.LOCAL.ADDRESSES as MASK
                                    in (fetch (IPINIT SUBNETMASK) of 
                                                                            \IP.DEFAULT.CONFIGURATION
                                                  ) as NETADDRESS in NETS
                                    collect (CONS LOCALADDR (\IP.READ.STRING.ADDRESS
                                                                 (OR MASK (CAR NETADDRESS]
          (COND
             ((BOUNDP '\DOMAIN.NAMESERVERS)
              (\DOMAIN.INIT EVENT)))
          (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.IP))
          (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.AR))
          (SETQ \IPFLG T)
          (\IP.ADD.PROTOCOL \ICMP.PROTOCOL (FUNCTION TRUE)
                 (FUNCTION NILL)
                 (FUNCTION \ICMP.INPUT))
          (COND
             ((SETQ PROC (FIND.PROCESS '\IPLISTENER))
              (RESTART.PROCESS PROC))
             (T (ADD.PROCESS '(\IPLISTENER)
                       'RESTARTABLE
                       'SYSTEM
                       'AFTEREXIT \IP.READY.EVENT)))
          (if (NOT NEW.INIT)
              then                                       (* ; "Finally, check for new hosts.txt file, but we can do this in background.  If NEW.INIT, the configuration code has already read it.")
                    (ADD.PROCESS '(\IP.MAYBE.READ.HOSTS.TXT T)
                           'AFTEREXIT
                           'DELETE))
          (SETQ \IP.READY T)
          (NOTIFY.EVENT \IP.READY.EVENT)
          (\ICMP.REQUEST.ADDRESS.MASK)
          (RETURN T])

(\IP.MAYBE.READ.HOSTS.TXT
  [LAMBDA (AFTEREXIT FILE)                               (* ; "Edited 20-Jan-89 11:56 by bvm")

    (* ;; "Read the hosts.txt file if it has changed")

    (if AFTEREXIT
        then                                             (* ; 
                                                         "Have to wait until all devices are happy")
              (until \PROC.READY do (AWAIT.EVENT \PROCESS.AFTEREXIT.EVENT 10000)))
    (LET (FULLNAME)
         (COND
            ((NULL FILE))
            (TCP.ALWAYS.READ.HOSTS.FILE                      (* ; 
                                                       "the user wants us to always read it fresh.")
                   (\HTE.READ.FILE FILE))
            ((NULL (SETQ FULLNAME (INFILEP FILE)))
             (CL:FORMAT PROMPTWINDOW "~%%Couldn't find hosts file ~A" FILE))
            ([AND \TCP.LAST.HOSTS.FILE.DATE (STRING-EQUAL FULLNAME \TCP.LAST.HOSTS.FILE.READ)
                  (EQUAL \TCP.LAST.HOSTS.FILE.DATE (GETFILEINFO FILE 'ICREATIONDATE]
                                                             (* ; 
              "the file names and the file write dates are the same, don't re-read the hosts file.")
             NIL)
            (T                                               (* ; 
                                            "Haven't read this particular file before, so snarf it")
               (\HTE.READ.FILE FILE])

(\IP.READ.INIT.FILE
  [LAMBDA (FILE)                                         (* ; "Edited 18-Mar-88 18:34 by bvm")
    (CL:MULTIPLE-VALUE-BIND (CONFIGURATION CONDITION)
           [IGNORE-ERRORS (LET ((*UPPER-CASE-FILE-NAMES* NIL)
                                (*READTABLE* (FIND-READTABLE "INTERLISP")))
                               (CL:WITH-OPEN-FILE (S FILE)
                                      (READ S]
           (if CONDITION
               then (PRINTOUT T "Failed to read init file because: " CONDITION)
                     NIL
             else (LET ((HOST (fetch (IPINIT LOCAL.NSHOSTNUMBER) of CONFIGURATION)))
                           (if (NULL HOST)
                               then                      (* ; 
                                    "Old file that doesn't have its processor identification in it")
                                     (create IPINIT using CONFIGURATION LOCAL.NSHOSTNUMBER _
                                                              \MY.NSHOSTNUMBER)
                             elseif (EQUAL HOST \MY.NSHOSTNUMBER)
                               then                      (* ; "Good, init file for same host")
                                     CONFIGURATION
                             else (PRINTOUT T FILE " gives configuration for host " (
                                                                                 \COERCE.TO.NSADDRESS
                                                                                         HOST)
                                             " but this is machine "
                                             (\COERCE.TO.NSADDRESS \MY.NSHOSTNUMBER)
                                             T)
                                   NIL])

(\IP.PROMPT.FOR.FILE.NAME
  [LAMBDA (PROMPT DEFAULT)                               (* ; "Edited 18-Mar-88 18:14 by bvm")

    (* ;; "Prompts for a file name from user and returns its full name if it is infilep")

    (bind NAME do (if [NULL (SETQ NAME (PROG1 (PROMPTFORWORD PROMPT DEFAULT NIL NIL NIL 
                                                                 NIL (CHARCODE (CR)))
                                                          (TERPRI]
                              then (RETURN NIL)
                            elseif (SETQ NAME (INFILEP NAME))
                              then (RETURN NAME)
                            else (PRINTOUT T "File not found" T])
)

(ADDTOVAR RESTARTETHERFNS \IPEVENTFN)



(* ;; "Early IP reception functions")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")


(RPAQQ IPADDRESSTYPES ((\IP.CLASS.A 0)
                           (\IP.CLASS.A.BYTESPEC (BYTE 1 31))
                           (\IP.CLASS.A.NET.BYTESPEC (BYTE 8 24))
                           (\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0))
                           (\IP.CLASS.B 2)
                           (\IP.CLASS.B.BYTESPEC (BYTE 2 30))
                           (\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16))
                           (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0))
                           (\IP.CLASS.C 6)
                           (\IP.CLASS.C.BYTESPEC (BYTE 3 29))
                           (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8))
                           (\IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0))))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \IP.CLASS.A 0)

(RPAQ \IP.CLASS.A.BYTESPEC (BYTE 1 31))

(RPAQ \IP.CLASS.A.NET.BYTESPEC (BYTE 8 24))

(RPAQ \IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0))

(RPAQQ \IP.CLASS.B 2)

(RPAQ \IP.CLASS.B.BYTESPEC (BYTE 2 30))

(RPAQ \IP.CLASS.B.NET.BYTESPEC (BYTE 16 16))

(RPAQ \IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0))

(RPAQQ \IP.CLASS.C 6)

(RPAQ \IP.CLASS.C.BYTESPEC (BYTE 3 29))

(RPAQ \IP.CLASS.C.NET.BYTESPEC (BYTE 24 8))

(RPAQ \IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0))


(CONSTANTS (\IP.CLASS.A 0)
       (\IP.CLASS.A.BYTESPEC (BYTE 1 31))
       (\IP.CLASS.A.NET.BYTESPEC (BYTE 8 24))
       (\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0))
       (\IP.CLASS.B 2)
       (\IP.CLASS.B.BYTESPEC (BYTE 2 30))
       (\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16))
       (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0))
       (\IP.CLASS.C 6)
       (\IP.CLASS.C.BYTESPEC (BYTE 3 29))
       (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8))
       (\IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0)))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? \IP.LOCAL.ADDRESSES )

(RPAQ? \IP.SUBNET.MASKS )

(RPAQ? \IP.GATEWAY.FLG )

(RPAQ \IP.ADDRESS.BOX (\CREATECELL \FIXP))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.LOCAL.ADDRESSES \IP.SUBNET.MASKS \IP.GATEWAY.FLG \IP.ADDRESS.BOX)
)
(DECLARE%: EVAL@COMPILE 

[PUTPROPS \IP.FIX.DEST.HOST MACRO (LAMBDA (IP NDB)       (* ejs%: "26-Dec-84 15:07")
                                    (replace (IP IPDESTINATIONHOST) of IP
                                       with (ffetch (NDB NDBIPHOST#) of NDB]

[PUTPROPS \IP.FIX.DEST.NET MACRO (LAMBDA (IP NDB)        (* ejs%: "26-Dec-84 15:08")

         (* * Put the IP net# corresponding to the given NDB into the destination net 
       field of the dest address of the IP packet)

                                   (replace (IP IPDESTINATIONADDRESS) of IP
                                      with (LOGOR (fetch (IP IPDESTINATIONADDRESS)
                                                         of IP)
                                                      (LLSH (fetch (NDB NDBIPNET#) of NDB)
                                                            (SELECTQ (\IPADDRESSCLASS
                                                                      (fetch (NDB NDBIPHOST#)
                                                                         of NDB))
                                                                (\IP.CLASS.A 24)
                                                                (\IP.CLASS.B 16)
                                                                (\IP.CLASS.C 8)
                                                                (SHOULDNT]

[PUTPROPS \IP.FIX.SOURCE.HOST MACRO (LAMBDA (IP NDB)     (* ejs%: "26-Dec-84 15:07")
                                      (replace (IP IPSOURCEHOST) of IP
                                         with (ffetch (NDB NDBIPHOST#) of NDB]

[PUTPROPS \IP.FIX.SOURCE.NET MACRO (LAMBDA (IP NDB)      (* ejs%: "26-Dec-84 15:08")

         (* * Put the IP net# corresponding to the given NDB into the destination net 
       field of the dest address of the IP packet)

                                     (replace (IP IPSOURCENET) of IP
                                        with (ffetch (NDB NDBIPNET#) of NDB]
)
(DEFINEQ

(\HANDLE.RAW.IP
  [LAMBDA (IP TYPE)                                      (* ejs%: " 3-Feb-86 11:01")
    (PROG ((NDB (ffetch (ETHERPACKET EPNETWORK) of IP)))
          (COND
             ((NOT (type? NDB NDB))
              (ERROR "No NDB in ETHERPACKET!" IP)))
          (SELECTQ (ffetch (NDB NETTYPE) of NDB)
              (10 (COND
                     ((NEQ TYPE \EPT.IP)
                      (RETURN))))
              (3 (COND
                    ((NEQ TYPE \EET.IP)
                     (RETURN))))
              (ERROR "Unknown net type" (ffetch (NDB NETTYPE) of NDB)))
          [COND
             ((NOT \IP.READY)
              (\RELEASE.ETHERPACKET IP))
             ([NOT (\IP.CHECKSUM.OK (\IPCHECKSUM IP (ffetch (IP IPBASE) of IP)
                                               (TIMES (ffetch (IP IPHEADERLENGTH) of IP)
                                                      BYTESPERCELL]
              (AND IPTRACEFLG (PRINTPACKET IP 'GET IPTRACEFILE 
                                     "[Packet dropped--bad IP header checksum]"))
              (\RELEASE.ETHERPACKET IP))
             ((ZEROP (ffetch (IP IPTIMETOLIVE) of IP))
              (\ICMP.TIME.EXCEEDED IP \ICMP.TRANSIT.TIME.EXCEEDED)
              (\RELEASE.ETHERPACKET IP))
             ((\IP.PROCESS.OPTIONS IP)
              (COND
                 ((NOT (\IP.LOCAL.DESTINATION IP))
                  (\FORWARD.IP IP))
                 [(\IP.FRAGMENTED.PACKET IP)
                  (COND
                     ((SETQ IP (\HANDLE.RAW.IP.FRAGMENT IP))
                      [COND
                         (IPTRACEFLG (COND
                                        ((EQ IPTRACEFLG T)
                                         (PRINTIP IP 'GETFRAGMENT IPTRACEFILE NIL T))
                                        (T (PRIN1 "+" IPTRACEFILE]
                      (\IP.HAND.TO.PROTOCOL IP]
                 (T [COND
                       (IPTRACEFLG (COND
                                      ((EQ IPTRACEFLG T)
                                       (PRINTIP IP 'GET IPTRACEFILE NIL T))
                                      (T (PRIN1 "+" IPTRACEFILE]
                    (\IP.HAND.TO.PROTOCOL IP]
          (RETURN T])

(\FORWARD.IP
  [LAMBDA (IP)                                           (* ejs%: "10-Feb-86 11:32")
    (DECLARE (GLOBALVARS \IP.GATEWAY.FLG \IP.GATEWAY.FORWARDING.FUNCTIONS))
    (COND
       [\IP.GATEWAY.FLG (LET* ((DESTADDRESS (ffetch (IP IPDESTINATIONADDRESS) of IP))
                               (NETADDRESS (\IPNETADDRESS DESTADDRESS))
                               (NDB (fetch (ETHERPACKET EPNETWORK) of IP))
                               (SOURCEADDRESS (fetch NDBIPHOST# of NDB))
                               (SUBNETMASK (CDR (SASSOC SOURCEADDRESS \IP.SUBNET.MASKS)))
                               SUBNETINUSE ROUTE FORWARDING.FUNCTION)
                              [COND
                                 [(AND NDB SUBNETMASK (OR (EQP (LOGAND SOURCEADDRESS SUBNETMASK)
                                                               (LOGAND DESTADDRESS SUBNETMASK))
                                                          (PROGN (SETQ SUBNETINUSE T)
                                                                 NIL]
                                 ((NULL NDB)
                                  (COND
                                     ((SETQ ROUTE (CDR (SASSOC NETADDRESS \IP.ROUTING.TABLE)))
                                      (SETQ NDB (CDR (SASSOC (\IPNETADDRESS ROUTE)
                                                            \IP.LOCAL.NETWORKS]
                              (COND
                                 [NDB (replace EPREQUEUE of IP with 'FREE)
                                      (add (ffetch (IP IPTIMETOLIVE) of IP)
                                             -1)
                                      [SETQ NETADDRESS (COND
                                                          (SUBNETINUSE (LOGAND DESTADDRESS SUBNETMASK
                                                                              ))
                                                          (T (BITCLEAR DESTADDRESS (\IPHOSTADDRESS
                                                                                    DESTADDRESS]
                                      (COND
                                         ((SETQ FORWARDING.FUNCTION (CDR (SASSOC NETADDRESS 
                                                                     \IP.GATEWAY.FORWARDING.FUNCTIONS
                                                                                )))
                                          (APPLY* FORWARDING.FUNCTION IP NDB NETADDRESS ROUTE))
                                         (T (\RELEASE.ETHERPACKET IP]
                                 (T (\ICMP.REDIRECT IP \ICMP.REDIRECT.NET]
       (T (\RELEASE.ETHERPACKET IP])

(\IP.LOCAL.DESTINATION
  [LAMBDA (IP)                                           (* ejs%: "25-Mar-86 16:03")

         (* * Return T if IP packet is destined for us)

    (UNINTERRUPTABLY
        (\BLT \IP.ADDRESS.BOX (LOCF (fetch (IP IPDESTINATIONADDRESS) of IP))
              WORDSPERCELL)
        [LET [(LOCALNETADDRESS (fetch NDBIPNET# of (fetch EPNETWORK of IP]
             (COND
                ((MEMBER \IP.ADDRESS.BOX \IP.LOCAL.ADDRESSES)
                 T)
                ((AND (\IP.BROADCAST.ADDRESS \IP.ADDRESS.BOX)
                      (EQP LOCALNETADDRESS (\IPNETADDRESS \IP.ADDRESS.BOX)))
                 T)
                ((NOT (\IP.LEGAL.ADDRESS \IP.ADDRESS.BOX))
                                                             (* Bogus destination address)
                 NIL)
                ((EQP 0 (\IPNETADDRESS \IP.ADDRESS.BOX)) (* Source doesn't know its network?)
                 (SELECTQ (INTEGERLENGTH LOCALNETADDRESS)
                     (8 (\PUTBASEBYTE \IP.ADDRESS.BOX 0 LOCALNETADDRESS))
                     (16 (\PUTBASE \IP.ADDRESS.BOX 0 LOCALNETADDRESS))
                     (24 [for I from 0 to 2
                            do (\PUTBASEBYTE \IP.ADDRESS.BOX I
                                          (LOGAND 255 (LRSH LOCALNETADDRESS (ITIMES 8
                                                                                   (IDIFFERENCE
                                                                                    2 I])
                     NIL)
                 (COND
                    ((\IP.BROADCAST.ADDRESS \IP.ADDRESS.BOX)
                     T)
                    ((MEMBER \IP.ADDRESS.BOX \IP.LOCAL.ADDRESSES)
                     T])])

(\IPCHECKSUM
  [LAMBDA (ETHERPACKET CHECKSUMBASE NBYTES IGNOREDWORD)  (* ejs%: "31-Dec-84 13:53")

         (* * Compute a general checksum for a packet starting at CHECKSUMBASE and 
       extending NBYTES. If NBYTES is odd, a 0 byte is padded on the end.
       The IGNOREDWORD field is the LOCF of the field which will contain the checksum, 
       and is to be considered 0 for the calculation.)

    (PROG ((MAXINDEX (SUB1 (FOLDHI NBYTES BYTESPERWORD)))
           (CHECKSUM 0)
           (ODDFLG (ODDP NBYTES))
           DIFF WORDCONTENTS)
          (AND IGNOREDWORD (\PUTBASE IGNOREDWORD 0 0))
          [for WORD from 0 to MAXINDEX
             do (SETQ CHECKSUM (COND
                                      [(AND ODDFLG (EQ WORD MAXINDEX))
                                       (COND
                                          ([ILEQ CHECKSUM (SETQ DIFF (IDIFFERENCE
                                                                      MAX.SMALL.INTEGER
                                                                      (SETQ WORDCONTENTS
                                                                       (LOGAND (\GETBASE CHECKSUMBASE
                                                                                      WORD)
                                                                              (MASK.1'S 8 8]
                                           (IPLUS CHECKSUM WORDCONTENTS))
                                          (T (IDIFFERENCE CHECKSUM DIFF]
                                      (T (COND
                                            ([ILEQ CHECKSUM (SETQ DIFF (IDIFFERENCE MAX.SMALL.INTEGER
                                                                              (SETQ WORDCONTENTS
                                                                               (\GETBASE CHECKSUMBASE
                                                                                      WORD]
                                             (IPLUS CHECKSUM WORDCONTENTS))
                                            (T (IDIFFERENCE CHECKSUM DIFF]
          (RETURN CHECKSUM])

(\IP.CHECKSUM.OK
  [LAMBDA (CHECKSUM)                                     (* ejs%: "28-Dec-84 19:40")
    (OR (EQ CHECKSUM (MASK.1'S 0 16))
        (EQ CHECKSUM 0])

(\IP.SET.CHECKSUM
  [LAMBDA (PACKET CHECKSUMBASE NBYTES CHECKSUMWORD)      (* ejs%: " 4-Jun-85 22:47")
    (PROG ((CHECKSUM (\IPCHECKSUM PACKET CHECKSUMBASE NBYTES CHECKSUMWORD)))
          (\PUTBASE CHECKSUMWORD 0 (COND
                                      ((EQ CHECKSUM (MASK.1'S 0 16))
                                       CHECKSUM)
                                      (T (LOGAND (LOGNOT CHECKSUM)
                                                (MASK.1'S 0 16])
)



(* ;; "Protocol Distribution")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")


(RPAQQ IPPROTOCOLTYPES ((\ICMP.PROTOCOL 1)
                            (\TCP.PROTOCOL 6)
                            (\UDP.PROTOCOL 17)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \ICMP.PROTOCOL 1)

(RPAQQ \TCP.PROTOCOL 6)

(RPAQQ \UDP.PROTOCOL 17)


(CONSTANTS (\ICMP.PROTOCOL 1)
       (\TCP.PROTOCOL 6)
       (\UDP.PROTOCOL 17))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? \IP.PROTOCOLS )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.PROTOCOLS)
)
(DEFINEQ

(\IP.HAND.TO.PROTOCOL
  [LAMBDA (IP)                                           (* ejs%: "31-Mar-86 15:39")
    (PROG ((PROTOCOL (ffetch (IP IPPROTOCOL) of IP))
           PROTOCOLCHAIN IPSOCKET)
          (COND
             ((NOT (SETQ PROTOCOLCHAIN (\IP.FIND.PROTOCOL PROTOCOL \IP.PROTOCOLS)))
              (OR (\IP.BROADCAST.ADDRESS (fetch (IP IPDESTINATIONADDRESS) of IP))
                  (\ICMP.DEST.UNREACHABLE IP \ICMP.PROTOCOL.UNREACHABLE)))
             ((NOT (SETQ IPSOCKET (\IP.FIND.PROTOCOL.SOCKET IP PROTOCOLCHAIN)))
              (APPLY* (ffetch (IPSOCKET IPSNOSOCKETFN) of PROTOCOLCHAIN)
                     IP))
             (T (APPLY* (ffetch (IPSOCKET IPSINPUTFN) of (COND
                                                                    ((type? IPSOCKET IPSOCKET)
                                                                     IPSOCKET)
                                                                    (T PROTOCOLCHAIN)))
                       IP IPSOCKET])

(\IP.DEFAULT.INPUTFN
  [LAMBDA (IP IPSOCKET)                                  (* ejs%: " 3-Feb-85 19:19")
    (COND
       ((EQ (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET)
            (fetch (IPSOCKET IPSQUEUEALLOC) of IPSOCKET))
        (\RELEASE.ETHERPACKET IP))
       (T (UNINTERRUPTABLY
              (\ENQUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)
                     IP)
              (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET)
                     1)
              (NOTIFY.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET)))])

(\IP.DEFAULT.NOSOCKETFN
  [LAMBDA (IP)                                           (* ejs%: " 2-Feb-86 11:38")
    (COND
       ([OR (NEQ 0 (fetch (IP IPDESTINATIONHOST) of IP))
            (NOT (\IP.BROADCAST.ADDRESS (fetch (IP IPDESTINATIONADDRESS) of IP]
        (\ICMP.DEST.UNREACHABLE IP \ICMP.PORT.UNREACHABLE))
       (T (\RELEASE.ETHERPACKET IP])

(\IP.ADD.PROTOCOL
  [LAMBDA (PROTOCOL SOCKETCOMPAREFN NOSOCKETFN INPUTFN ICMPFN)
                                                             (* ; "Edited 25-Aug-88 12:10 by bvm")

(* ;;; "Find an existing protocol, or create a new one, and return the socket chain head.  If the protocol already exists, the remaining arguments redefine the current slots.")

    (LET* [(FOUND (find SOCKET in \IP.PROTOCOLS suchthat (EQ (fetch (IPSOCKET 
                                                                                           PROTOCOL)
                                                                            of SOCKET)
                                                                         PROTOCOL)))
           (SOCKET (OR FOUND (create IPSOCKET
                                    PROTOCOL _ PROTOCOL
                                    IPSQUEUE _ NIL
                                    IPSQUEUEALLOC _ 0
                                    IPSEVENT _ NIL]
          (replace (IPSOCKET IPSDESTSOCKETCOMPAREFN) of SOCKET with SOCKETCOMPAREFN)
          (replace (IPSOCKET IPSINPUTFN) of SOCKET with (OR INPUTFN
                                                                        (FUNCTION \IP.DEFAULT.INPUTFN
                                                                         )))
          (replace (IPSOCKET IPSNOSOCKETFN) of SOCKET with (OR NOSOCKETFN
                                                                           (FUNCTION 
                                                                            \IP.DEFAULT.NOSOCKETFN)))
          (replace (IPSOCKET IPSICMPFN) of SOCKET with (OR ICMPFN (FUNCTION 
                                                                               \RELEASE.ETHERPACKET))
                 )
          (if (NOT FOUND)
              then                                       (* ; 
                                          "Now that it's all filled in, add it to the protocol set")
                    (push \IP.PROTOCOLS SOCKET))
          SOCKET])

(\IP.DELETE.PROTOCOL
  [LAMBDA (PROTOCOL)                                     (* ejs%: "10-Apr-85 16:24")
    (LET ((PROTOCOLCHAIN (\IP.FIND.PROTOCOL PROTOCOL)))
         (COND
            (PROTOCOLCHAIN (until (NULL (fetch (IPSOCKET IPSLINK) of PROTOCOLCHAIN))
                              do (\IP.CLOSE.SOCKET (fetch (IPSOCKET IPSOCKET)
                                                              of (fetch (IPSOCKET IPSLINK)
                                                                        of PROTOCOLCHAIN))
                                            PROTOCOL))
                   (SETQ \IP.PROTOCOLS (DREMOVE PROTOCOLCHAIN \IP.PROTOCOLS))
                   T])

(\IP.FIND.PROTOCOL
  [LAMBDA (PROTOCOL)                                     (* ejs%: "27-Dec-84 11:18")

         (* * Find the protocol chain for this protocol#)

    (CAR (SOME \IP.PROTOCOLS (FUNCTION (LAMBDA (IPSOCKET)
                                         (EQ (ffetch (IPSOCKET PROTOCOL) of IPSOCKET)
                                             PROTOCOL])

(\IP.FIND.PROTOCOL.SOCKET
  [LAMBDA (IP PROTOCOLCHAIN)                             (* ; "Edited 26-Aug-88 12:44 by bvm")

    (* ;; "Find the socket specified by IP packet.  PROTOCOLCHAIN is the head of the socket chain for this protocol; if NIL we look it up.")

    (LET ([SOCKET (OR PROTOCOLCHAIN (\IP.FIND.PROTOCOL (ffetch (IP IPPROTOCOL) of IP]
          RESULT)

         (* ;; "Note that we start the comparisons with the dummy head, even though we expect that to fail.  This is so that a socketless protocol, such as ICMP can use this dummy head as the sole handler of the protocol.")

         (AND SOCKET (when (SETQ RESULT (CL:FUNCALL (ffetch (IPSOCKET IPSDESTSOCKETCOMPAREFN)
                                                           of SOCKET)
                                                   IP SOCKET))
                        do (RETURN (COND
                                          ((EQ RESULT T)
                                           SOCKET)
                                          (T                 (* ; "This is a little strange.  Non-T comparison result will be passed as the second arg to the chain head's inputfn when a packet arrives here.")
                                             RESULT))) repeatwhile (SETQ SOCKET
                                                                        (ffetch (IPSOCKET IPSLINK
                                                                                           )
                                                                           of SOCKET])

(\IP.FIND.SOCKET
  [LAMBDA (SOCKET# SOCKETCHAIN)                          (* ejs%: "27-Dec-84 11:39")

         (* * Called to find the socket open on the socketchain, or NIL if no such open 
       socket. Socketchain comes from \IP.FIND.PROTOCOL)

    (while SOCKETCHAIN until (COND
                                        ((EQUAL SOCKET# (ffetch (IPSOCKET IPSOCKET) of 
                                                                                          SOCKETCHAIN
                                                               ))
                                         SOCKETCHAIN)
                                        (T (SETQ SOCKETCHAIN (ffetch (IPSOCKET IPSLINK)
                                                                of SOCKETCHAIN))
                                           NIL)) finally (RETURN SOCKETCHAIN])

(\IP.OPEN.SOCKET
  [LAMBDA (PROTOCOL SOCKET NOERRORFLG DESTSOCKETCOMPAREFN NOSOCKETFN INPUTFN ICMPFN)
                                                             (* ; "Edited 25-Aug-88 12:43 by bvm")

(* ;;; "Open a new socket for a protocol.  The last 4 fns default to those specified when the protocol was enabled.")

    (* ;; "Keeping NOSOCKETFN for back compatibility, but it doesn't really make any sense --bvm.")

    (LET ((MASTERSOC (\IP.FIND.PROTOCOL PROTOCOL))
          OLDSOC NEWSOC)
         (COND
            [(NOT (type? IPSOCKET MASTERSOC))
             (COND
                ((NOT NOERRORFLG)
                 (ERROR "Attempt to open socket in unknown protocol" PROTOCOL SOCKET]
            [(if SOCKET
                 then (SETQ OLDSOC (\IP.FIND.SOCKET SOCKET MASTERSOC))
               else                                      (* ; 
        "Pick a random socket that is smallp but not very small, so as to avoid well-known sockets")
                     (SETQ SOCKET (LOGOR (LOGAND (DAYTIME)
                                                65535)
                                         32768))
                     (while (\IP.FIND.SOCKET SOCKET MASTERSOC)
                        do (SETQ SOCKET (- SOCKET 1)))
                     NIL)
             (COND
                (NOERRORFLG OLDSOC)
                (T (ERROR "Attempt to open an existing socket" OLDSOC]
            (T [SETQ NEWSOC (create IPSOCKET
                                   IPSLINK _ (ffetch (IPSOCKET IPSLINK) of MASTERSOC)
                                   IPSOCKET _ SOCKET
                                   PROTOCOL _ PROTOCOL
                                   IPSDESTSOCKETCOMPAREFN _ (OR DESTSOCKETCOMPAREFN
                                                                (ffetch (IPSOCKET 
                                                                               IPSDESTSOCKETCOMPAREFN
                                                                                   ) of MASTERSOC
                                                                       ))
                                   IPSNOSOCKETFN _ (OR NOSOCKETFN (ffetch (IPSOCKET IPSNOSOCKETFN
                                                                                     ) of 
                                                                                            MASTERSOC
                                                                         ))
                                   IPSINPUTFN _ (OR INPUTFN (ffetch (IPSOCKET IPSINPUTFN)
                                                               of MASTERSOC))
                                   IPSICMPFN _ (OR ICMPFN (ffetch (IPSOCKET IPSICMPFN)
                                                             of MASTERSOC]
               (freplace (IPSOCKET IPSLINK) of MASTERSOC with NEWSOC)
               NEWSOC])

(\IP.CLOSE.SOCKET
  [LAMBDA (SOCKET PROTOCOL NOERRORFLG)                   (* ; "Edited 26-Aug-88 12:33 by bvm")

(* ;;; "Close the given socket.  Call this only after the higher level protocol has finished doing its closing operations.")

    (* ;; "For some silly reason, this fn was defined to take not an IPSOCKET object but rather the socket number, or whatever was in the socket slot.  For backward compatibility, let's do both (sigh).")

    (LET ((PREV (\IP.FIND.PROTOCOL PROTOCOL))
          NEXT)
         (COND
            [(AND PREV (while (SETQ NEXT (ffetch (IPSOCKET IPSLINK) of PREV))
                          do (if (OR (EQ SOCKET NEXT)
                                             (EQ SOCKET (ffetch (IPSOCKET IPSOCKET) of NEXT))
                                             )
                                     then                (* ; "Found it, so splice it out")
                                           (freplace (IPSOCKET IPSLINK) of PREV
                                              with (ffetch (IPSOCKET IPSLINK) of NEXT))
                                           (freplace (IPSOCKET IPSLINK) of NEXT with
                                                                                        NIL)
                                           (RETURN T))
                                (SETQ PREV NEXT]
            ((NOT NOERRORFLG)
             (ERROR "Socket not found" SOCKET])
)



(* ;; "Fragmentation Handling")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(RECORD AssemblyRecord (Packet FirstHole Fragments Timeout)
                           Packet _ (\ALLOCATE.ETHERPACKET)
                           FirstHole _ 0)

(RECORD FragmentRecord (Start Length LastFragment))

(RECORD FragmentID (AssemblyRecord SourceAddress ID Protocol . DestinationAddress))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? \IP.FRAGMENT.LIST )

(RPAQ? \IP.FRAGMENT.LOCK (CREATE.MONITORLOCK "IP Fragment Processing Lock"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.FRAGMENT.LIST \IP.FRAGMENT.LOCK)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \IP.FRAGMENTATION.UNIT 8)


(CONSTANTS (\IP.FRAGMENTATION.UNIT 8))
)
(DEFINEQ

(\HANDLE.RAW.IP.FRAGMENT
  [LAMBDA (IP)                                           (* ejs%: " 1-Feb-86 14:24")

         (* * Add the next fragment to a packet under assembly.
       If this fragment completes a packet, return the completed packet to be 
       processed by higher-level protocol routines.)

    (WITH.MONITOR \IP.FRAGMENT.LOCK
        (LET ((AssemblyRecord (\IP.FIND.MATCHING.FRAGMENTS IP)))
             (COND
                (AssemblyRecord (\IP.ADD.FRAGMENT AssemblyRecord IP))
                (T (\IP.NEW.FRAGMENT.LST IP)
                   NIL))))])

(\IP.NEW.FRAGMENT.LST
  [LAMBDA (IP)                                           (* ejs%: " 3-Feb-86 10:57")

         (* * Add a new fragment to the fragment list)

    (PROG ((Source (ffetch (IP IPSOURCEADDRESS) of IP))
           (Dest (ffetch (IP IPDESTINATIONADDRESS) of IP))
           (Protocol (ffetch (IP IPPROTOCOL) of IP))
           (ID (ffetch (IP IPID) of IP))
           NewFragmentID FragmentRecord AssemblyPacket AssemblyRecord)
          [SETQ NewFragmentID
           (create FragmentID
                  SourceAddress _ Source
                  ID _ ID
                  Protocol _ Protocol
                  DestinationAddress _ Dest
                  AssemblyRecord _ (SETQ AssemblyRecord
                                    (create AssemblyRecord
                                           Timeout _ (SETUPTIMER (ITIMES 1000 (ffetch
                                                                               (IP IPTIMETOLIVE)
                                                                                 of IP)))
                                           Fragments _
                                           (LIST (SETQ FragmentRecord
                                                  (create FragmentRecord
                                                         Start _ (UNFOLD (ffetch (IP 
                                                                                     IPFRAGMENTOFFSET
                                                                                         )
                                                                            of IP)
                                                                        \IP.FRAGMENTATION.UNIT)
                                                         Length _ (IDIFFERENCE
                                                                   (ffetch (IP IPTOTALLENGTH)
                                                                      of IP)
                                                                   (UNFOLD (ffetch (IP 
                                                                                       IPHEADERLENGTH
                                                                                           )
                                                                              of IP)
                                                                          BYTESPERCELL]
          (COND
             ((EQ IPTRACEFLG T)
              (\IP.PRINT.FRAGMENT NewFragmentID IP IPTRACEFILE)))
          (SETQ AssemblyPacket (fetch (AssemblyRecord Packet) of AssemblyRecord))
          (\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER AssemblyPacket IP)

         (* * Copy the packet data to the packet)

          (\BLT (\ADDBASE (\IPDATABASE AssemblyPacket)
                       (FOLDLO (fetch (FragmentRecord Start) of FragmentRecord)
                              BYTESPERWORD))
                (\IPDATABASE IP)
                (FOLDLO (fetch (FragmentRecord Length) of FragmentRecord)
                       BYTESPERWORD))
          (\RELEASE.ETHERPACKET IP)
          (push \IP.FRAGMENT.LIST NewFragmentID])

(\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER
  [LAMBDA (Packet Fragment)                              (* ejs%: " 1-Feb-86 14:14")

         (* * Copy information from the header of the fragment packet into the header of 
       the reassembled packet)

    (\MOVEBYTES (fetch (IP IPBASE) of Fragment)
           0
           (fetch (IP IPBASE) of Packet)
           0
           (UNFOLD (fetch (IP IPHEADERLENGTH) of Fragment)
                  BYTESPERCELL])

(\IP.ADD.FRAGMENT
  [LAMBDA (FragmentID NewIP)                             (* ejs%: " 1-Feb-86 18:41")

         (* * Called to add a fragment to a fragment list.
       The fragment is added in order. If the fragment completes a fragmented IP 
       packet, a new packet is assembled and returned, else NIL is returned)

    (LET*
     ((AssemblyRecord (fetch (FragmentID AssemblyRecord) of FragmentID))
      [NewFrag (create FragmentRecord
                      Start _ (UNFOLD (ffetch (IP IPFRAGMENTOFFSET) of NewIP)
                                     \IP.FRAGMENTATION.UNIT)
                      Length _ (IDIFFERENCE (ffetch (IP IPTOTALLENGTH) of NewIP)
                                      (UNFOLD (ffetch (IP IPHEADERLENGTH) of NewIP)
                                             BYTESPERCELL))
                      LastFragment _ (NOT (fetch (IP IPMOREFRAGMENTS) of NewIP]
      (Fragments (fetch (AssemblyRecord Fragments) of AssemblyRecord))
      Status NextHole AssemblyPacket)
     (COND
        ((EQ IPTRACEFLG T)
         (\IP.PRINT.FRAGMENT FragmentID NewIP IPTRACEFILE)))
     (SETQ AssemblyPacket (fetch (AssemblyRecord Packet) of AssemblyRecord))
     (replace (AssemblyRecord Timeout) of AssemblyRecord
        with (SETUPTIMER (ITIMES 1000 (ffetch (IP IPTIMETOLIVE) of NewIP))
                        (fetch (AssemblyRecord Timeout) of AssemblyRecord)))
     [SETQ Status (COND
                     ((ILESSP (fetch (FragmentRecord Start) of NewFrag)
                             (fetch (FragmentRecord Start) of (CAR Fragments)))
                                                             (* Earlier than the earliest 
                                                           existing fragment)
                      (SETQ Fragments (push (fetch (AssemblyRecord Fragments) of 
                                                                                       AssemblyRecord
                                                       )
                                             NewFrag))
                      'INSERTED.FRAGMENT)
                     ((EQ (fetch (FragmentRecord Start) of NewFrag)
                          (fetch (FragmentRecord Start) of (CAR Fragments)))
                                                             (* Duplicate of earliest fragment)
                      'DUPLICATE)
                     (T                                      (* Have to search)
                        (for OldFragTail on Fragments while (CDR OldFragTail)
                           thereis (COND
                                          ((EQ (fetch (FragmentRecord Start) of NewFrag)
                                               (fetch (FragmentRecord Start) of (CADR 
                                                                                          OldFragTail
                                                                                              )))
                                                             (* Duplicate)
                                           (SETQ Status 'DUPLICATE)
                                           T)
                                          ((ILESSP (fetch (FragmentRecord Start) of NewFrag)
                                                  (fetch (FragmentRecord Start)
                                                     of (CADR OldFragTail)))
                                                             (* Found the hole to insert)
                                           T)) finally (COND
                                                              (Status 
                                                             (* Duplicate)
                                                                     (RETURN Status))
                                                              ((CDR OldFragTail)
                                                             (* Inserted in middle of list)
                                                               (RPLACD OldFragTail
                                                                      (CONS NewFrag (CDR OldFragTail)
                                                                            ))
                                                               (RETURN 'INSERTED.FRAGMENT))
                                                              (T 
                                                             (* Inserted at end of list)
                                                                 (NCONC1 OldFragTail NewFrag)
                                                                 (RETURN 'INSERTED.FRAGMENT]
     (PROG1 (SELECTQ Status
                (DUPLICATE NIL)
                (INSERTED.FRAGMENT                           (* Copy bytes into assembly)
                     (\MOVEBYTES (\IPDATABASE NewIP)
                            0
                            (\IPDATABASE AssemblyPacket)
                            (fetch (FragmentRecord Start) of NewFrag)
                            (fetch (FragmentRecord Length) of NewFrag))
                     (add (ffetch (IP IPTOTALLENGTH) of AssemblyPacket)
                            (fetch (FragmentRecord Length) of NewFrag))
                                                             (* Update Assembly record)
                     [COND
                        ((ILESSP (fetch (FragmentRecord Start) of NewFrag)
                                (fetch (AssemblyRecord FirstHole) of AssemblyRecord))
                         (ERROR "Error in IP fragment reassembly!" NewFrag))
                        (T (COND
                              ((EQ [bind End Status for FragTail on Fragments
                                      while (CDR FragTail)
                                      thereis [COND
                                                     ((NEQ [SETQ End (IPLUS (fetch (
                                                                                       FragmentRecord
                                                                                        Start)
                                                                               of (CAR FragTail))
                                                                            (fetch (
                                                                                       FragmentRecord
                                                                                        Length)
                                                                               of (CAR FragTail]
                                                           (fetch (FragmentRecord Start)
                                                              of (CADR FragTail)))
                                                      (replace (AssemblyRecord FirstHole)
                                                         of AssemblyRecord with End)
                                                      (SETQ Status 'FOUND.HOLE]
                                      finally (RETURN (COND
                                                             [(NULL Status)
                                                              (COND
                                                                 ((fetch (FragmentRecord 
                                                                                    LastFragment)
                                                                     of (CAR FragTail))
                                                                  (COND
                                                                     ((EQ IPTRACEFLG T)
                                                                      (printout IPTRACEFILE T 
                                                                      "Complete IP Fragment received"
                                                                             T)))
                                                                  'COMPLETE.PACKET)
                                                                 (T (replace (AssemblyRecord
                                                                                  FirstHole)
                                                                       of AssemblyRecord
                                                                       with End)
                                                                    'INCOMPLETE.BUT.NO.HOLES]
                                                             (T Status]
                                   'COMPLETE.PACKET)
                               (\IP.DELETE.FRAGMENT FragmentID)
                               AssemblyPacket])
                NIL)
            (\RELEASE.ETHERPACKET NewIP])

(\IP.FIND.MATCHING.FRAGMENTS
  [LAMBDA (IP)                                           (* ejs%: " 1-Feb-86 14:41")

         (* * Find the list of fragments matching this IP packet, or NIL if none exists)

    (DECLARE (GLOBALVARS \IP.FRAGMENT.LIST))
    (LET* ((Source (ffetch (IP IPSOURCEADDRESS) of IP))
           (Dest (ffetch (IP IPDESTINATIONADDRESS) of IP))
           (Protocol (ffetch (IP IPPROTOCOL) of IP))
           (ID (ffetch (IP IPID) of IP))
           (FragmentEntry))
          (for FragmentID in \IP.FRAGMENT.LIST thereis (AND (EQP (fetch (FragmentID
                                                                                         
                                                                                        SourceAddress
                                                                                         )
                                                                                of FragmentID)
                                                                             Source)
                                                                        (EQ (fetch (FragmentID
                                                                                        ID)
                                                                               of FragmentID)
                                                                            ID)
                                                                        (EQ (fetch (FragmentID
                                                                                        Protocol)
                                                                               of FragmentID)
                                                                            Protocol)
                                                                        (EQP (fetch (FragmentID
                                                                                         
                                                                                   DestinationAddress
                                                                                         )
                                                                                of FragmentID)
                                                                             Dest])

(\IP.FRAGMENTED.PACKET
  [LAMBDA (IP)                                           (* ejs%: " 1-Feb-86 16:50")

         (* * Return T if IP packet is a fragment)

    (OR (ffetch (IP IPMOREFRAGMENTS) of IP)
        (NEQ 0 (ffetch (IP IPFRAGMENTOFFSET) of IP])

(\IP.CHECK.REASSEMBLY.TIMEOUTS
  [LAMBDA NIL                                            (* ejs%: " 3-Feb-86 11:00")

         (* * Kill any fragments in the process of reassembly if their timeout has 
       expired. Report timeout via ICMP)

    (WITH.MONITOR \IP.FRAGMENT.LOCK
        (bind AssemblyRecord for Fragment in \IP.FRAGMENT.LIST
           when [TIMEREXPIRED? (fetch (AssemblyRecord Timeout) of (SETQ AssemblyRecord
                                                                               (fetch
                                                                                (FragmentID 
                                                                                       AssemblyRecord
                                                                                       ) of
                                                                                         Fragment]
           do (COND
                     ((EQ IPTRACEFLG T)
                      (printout IPTRACEFILE T "IP Fragment timeout expired" T)))
                 (\ICMP.TIME.EXCEEDED (fetch (AssemblyRecord Packet) of AssemblyRecord)
                        \ICMP.FRAGMENT.TIME.EXCEEDED)
                 (\IP.DELETE.FRAGMENT Fragment T)))])

(\IP.DELETE.FRAGMENT
  [LAMBDA (FragmentID FreePacketToo)                     (* ejs%: " 3-Feb-86 10:59")

         (* * Delete FragmentID from the list of Fragment ID's)

    (PROG [(IP (fetch (AssemblyRecord Packet) of (fetch (FragmentID AssemblyRecord)
                                                            of FragmentID]
          (SETQ \IP.FRAGMENT.LIST (DREMOVE FragmentID \IP.FRAGMENT.LIST))
          (AND FreePacketToo (\RELEASE.ETHERPACKET IP])

(\IP.PRINT.FRAGMENT
  [LAMBDA (FragmentID IPFragment File)                   (* ejs%: " 2-Feb-86 10:39")

         (* * Print information about this fragement to File)

    (printout File T "Received IP Fragment:" T "Source " (\IP.ADDRESS.TO.STRING
                                                          (fetch (FragmentID SourceAddress)
                                                             of FragmentID))
           " Dest "
           (\IP.ADDRESS.TO.STRING (fetch (FragmentID DestinationAddress) of FragmentID))
           T "Protocol ")
    (PRINTCONSTANT (fetch (FragmentID Protocol) of FragmentID)
           IPPROTOCOLTYPES File)
    (printout File " ID " (fetch (FragmentID ID) of FragmentID)
           T "Covering [" (UNFOLD (ffetch (IP IPFRAGMENTOFFSET) of IPFragment)
                                 \IP.FRAGMENTATION.UNIT)
           ".."
           (IPLUS (UNFOLD (ffetch (IP IPFRAGMENTOFFSET) of IPFragment)
                         \IP.FRAGMENTATION.UNIT)
                  (IDIFFERENCE (ffetch (IP IPTOTALLENGTH) of IPFragment)
                         (UNFOLD (ffetch (IP IPHEADERLENGTH) of IPFragment)
                                BYTESPERCELL)))
           "]" T)
    (bind C for I from 0 to [SUB1 (IMIN 40 (IDIFFERENCE (ffetch (IP IPTOTALLENGTH
                                                                                        )
                                                                           of IPFragment)
                                                                  (UNFOLD (ffetch (IP 
                                                                                       IPHEADERLENGTH
                                                                                          )
                                                                             of IPFragment)
                                                                         BYTESPERCELL]
       do (SETQ C (\GETBASEBYTE (\IPDATABASE IPFragment)
                             I))
             (COND
                ((AND (IGEQ C (CHARCODE SPACE))
                      (ILEQ C 126))
                 (BOUT File C))
                (T (printout File "[" C "]"])
)



(* ;; "Option Processing")

(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")


(RPAQQ IPOPTIONTYPES ((IPOPT.END 0)
                          (IPOPT.NOP 1)
                          (IPOPT.SECURITY 2)
                          (IPOPT.LSRR 3)
                          (IPOPT.TIMESTAMP 4)
                          (IPOPT.RECRT 7)
                          (IPOPT.STREAMID 8)
                          (IPOPT.SSSR 9)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ IPOPT.END 0)

(RPAQQ IPOPT.NOP 1)

(RPAQQ IPOPT.SECURITY 2)

(RPAQQ IPOPT.LSRR 3)

(RPAQQ IPOPT.TIMESTAMP 4)

(RPAQQ IPOPT.RECRT 7)

(RPAQQ IPOPT.STREAMID 8)

(RPAQQ IPOPT.SSSR 9)


(CONSTANTS (IPOPT.END 0)
       (IPOPT.NOP 1)
       (IPOPT.SECURITY 2)
       (IPOPT.LSRR 3)
       (IPOPT.TIMESTAMP 4)
       (IPOPT.RECRT 7)
       (IPOPT.STREAMID 8)
       (IPOPT.SSSR 9))
)
(DECLARE%: EVAL@COMPILE 

(RPAQ IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0))


(CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0)))
)

(* "END EXPORTED DEFINITIONS")

)
(DEFINEQ

(\IP.PROCESS.OPTIONS
  [LAMBDA (IP)                                           (* ; "Edited 20-Jan-89 12:24 by bvm")

(* ;;; "Process option fields in IP header.  Return T if OK, else handle internally needed actions like redirection or reporting of parameter problems")

    (bind (OPTIONSSTART _ (LOCF (ffetch (IP IPOPTIONSSTART) of IP)))
           (INDEX _ 0)
           (RESULT _ T)
           REROUTING OPTION until (OR (>= INDEX (- (UNFOLD (fetch (IP IPHEADERLENGTH)
                                                                  of IP)
                                                              BYTESPERCELL)
                                                       \IPOVLEN))
                                          (EQ (SETQ OPTION (LDB (BYTE 5 0)
                                                                (\GETBASEBYTE OPTIONSSTART INDEX)))
                                              IPOPT.END))
       do (if (EQ OPTION IPOPT.NOP)
                  then                                   (* ; 
                                 "This is the only one-byte option we know of other than IPOPT.END")
                        (add INDEX 1)
                else (SELECTC OPTION
                             ((LIST IPOPT.LSRR IPOPT.SSSR) 
                                  (COND
                                     (REROUTING (SETQ RESULT INDEX))
                                     ((NEQ (SETQ RESULT (\IP.OPTION.STRICT.SOURCE.ROUTE IP INDEX)
                                            )
                                           'REROUTE)
                                      (SETQ REROUTING T))))
                             (IPOPT.RECRT (SETQ RESULT (\IP.OPTION.RECORD.ROUTE IP INDEX)))
                             (IPOPT.TIMESTAMP 
                                  (\IP.OPTION.TIMESTAMP IP INDEX))
                             (IPOPT.SECURITY)
                             (IPOPT.STREAMID)
                             (PROGN                          (* ; 
            "Unknown option code-- we can't continue, since it could be some unknown 1-byte option")
                                    (RETURN NIL)))
                      (COND
                         ((NUMBERP RESULT)

                          (* ;; 
        "If the result is a number then there was a parameter problem. We could process them here.")

                          (RETURN NIL)))
                      (add INDEX (\GETBASEBYTE OPTIONSSTART (ADD1 INDEX))) 
                                                             (* ; "Increment by the length field")
                     ) finally (RETURN RESULT])

(\IP.OPTION.RECORD.ROUTE
  [LAMBDA (IP INDEX)                                     (* ; "Edited  2-Aug-88 14:57 by atm")
    (LET* [(OPTIONSSTART (LOCF (ffetch (IP IPOPTIONSSTART) of IP)))
           (LENGTH (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 1)))
           (PTR (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 2]

          (* ;; "From RFC 791: If the route data area is already full just forward. If there is room , but not enough for a full address to be inserted, signal an ICMP error. Otherwise insert the address into the datagram and update PTR.")

          (COND
             ((IGREATERP PTR LENGTH)
              NIL)
             ((ILESSP (IDIFFERENCE LENGTH PTR)
                     3)
              INDEX)
             (T (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR)
                       (CAR \IP.LOCAL.ADDRESSES))
                (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2)
                       (LDB (BYTE 8 0)
                            (IPLUS PTR 4)))
                T])

(\IP.OPTION.STRICT.SOURCE.ROUTE
  [LAMBDA (IP INDEX)                                     (* ; "Edited  8-Aug-88 12:05 by atm")
    (LET* ((OPTIONSSTART (LOCF (ffetch (IP IPOPTIONSSTART) of IP)))
           (LENGTH (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 1)))
           (PTR (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 2)))
           (DESTINATIONADDRESSLOC (LOCF (ffetch (IP IPDESTINATIONADDRESS) of IP)))
           (DESTINATIONADDRESS (\GETBASEFIXP DESTINATIONADDRESSLOC 0)))

          (* ;; "From RFC 791: If the address in the destination field has been reached and PTR is not greater than LENGTH, the next address in the source route replaces the address in the destination address field, and the recorded route address replaces the source address just used, and PTR is increased by four.")

          (COND
             ((IGREATERP PTR LENGTH)
              NIL)
             ((ILESSP (IDIFFERENCE LENGTH PTR)
                     3)
              INDEX)
             (T (COND
                   ((MEMBER DESTINATIONADDRESS \IP.LOCAL.ADDRESSES)
                    (\PUTBASEFIXP OPTIONSSTART (IPLUS PTR INDEX 4)
                           DESTINATIONADDRESS)
                    (\PUTBASEFIXP DESTINATIONADDRESSLOC 0 (\GETBASEFIXP OPTIONSSTART (IPLUS PTR INDEX
                                                                                            )))
                    (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2)
                           (LDB (BYTE 8 0)
                                (IPLUS PTR 4)))
                    'REROUTE)
                   (T])

(\IP.OPTION.TIMESTAMP
  [LAMBDA (IP INDEX)                                     (* ; "Edited  8-Aug-88 12:08 by atm")
    (LET* ((OPTIONSSTART (LOCF (ffetch (IP IPOPTIONSSTART) of IP)))
           (LENGTH (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 1)))
           (PTR (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 2)))
           (OFLW/FLG (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 3)))
           FLAG)

          (* ;; "From RFC 791: If the timestamp area is already full then increment the overflow flag and forward the datagram without inserting the timestamp. If there is room but not enough for a full timestamp to be inserted then signal an ICMP error. Otherwise insert the timestamp or the timestamp and the internet address depending on the flag; 0 indicates timestamp only, 1 indicates timestamp and address, 3 indicates that the address is prespecified.")

          (COND
             ((IGREATERP PTR LENGTH)
              (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 3)
                     (IPLUS OFLW/FLG (LSH 1 4)))
              T)
             (T (SELECTQ (LOGAND 15 OFLW/FLG)
                    (0 (COND
                          ((ILESSP (IDIFFERENCE LENGTH PTR)
                                  3)
                           INDEX)
                          (T (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR)
                                    (\CLOCK0 (\CREATECELL \FIXP)))
                             (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2)
                                    (LDB (BYTE 8 0)
                                         (IPLUS PTR 4)))
                             T)))
                    (1 (COND
                          ((IGREATERP 8 (IDIFFERENCE LENGTH (SUB1 PTR)))
                           INDEX)
                          (T (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR)
                                    (CAR \IP.LOCAL.ADDRESSES))
                             (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR 4)
                                    (\CLOCK0 (\CREATECELL \FIXP)))
                             (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2)
                                    (LDB (BYTE 8 0)
                                         (IPLUS PTR 8)))
                             T)))
                    (3 [COND
                          ((IGREATERP 8 (IDIFFERENCE LENGTH (SUB1 PTR)))
                           INDEX)
                          (T (COND
                                ((MEMBER (\GETBASEFIXP OPTIONSSTART (IPLUS INDEX PTR))
                                        \IP.LOCAL.ADDRESSES)
                                 (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR 4)
                                        (\CLOCK0 (\CREATECELL \FIXP)))
                                 (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2)
                                        (LDB (BYTE 8 0)
                                             (IPLUS PTR 8)))
                                 T)
                                (T NIL])
                    INDEX])
)



(* ;; "Packet Transmission and routing")


(RPAQ? \IP.ROUTING.TABLE (CONS))

(RPAQ? \IP.DEFAULT.GATEWAY )

(RPAQ? \IP.LOCAL.NETWORKS )

(RPAQ? \IP.GATEWAY.FORWARDING.FUNCTIONS )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.ROUTING.TABLE \IP.DEFAULT.GATEWAY \IP.LOCAL.NETWORKS \IP.GATEWAY.FORWARDING.FUNCTIONS
       )
)
(DEFINEQ

(\IP.SETUPIP
  [LAMBDA (IP DESTHOST ID SOCKET REQUEUE)                (* ejs%: "31-Mar-86 15:01")

         (* * Initialize IP header of packet.)

    (OR IP (SETQ IP (\ALLOCATE.ETHERPACKET)))
    (replace (IP IPVERSION) of IP with \IP.PROTOCOLVERSION)
    (freplace (IP IPHEADERLENGTH) of IP with (FOLDHI \IPOVLEN BYTESPERCELL))
    (freplace (IP IPTOTALLENGTH) of IP with \IPOVLEN)
    [freplace (IP IPID) of IP with (OR (SMALLP ID)
                                                   (LOGAND (DAYTIME)
                                                          (MASK.1'S 0 16]
    (freplace (IP IPMOREFRAGMENTS) of IP with NIL)
    (freplace (IP IPFRAGMENTOFFSET) of IP with 0)
    (freplace (IP IPTIMETOLIVE) of IP with \IP.DEFAULT.TIME.TO.LIVE)
    (freplace (IP IPPROTOCOL) of IP with (fetch (IPSOCKET PROTOCOL) of SOCKET))
    (freplace (IP IPSOURCEADDRESS) of IP with (CAR \IP.LOCAL.ADDRESSES))
    (freplace (IP IPDESTINATIONADDRESS) of IP with DESTHOST)
    (freplace EPREQUEUE of IP with REQUEUE)
    IP])

(\IP.TRANSMIT
  [LAMBDA (IP ROUTINGREADONLY)                           (* ejs%: "27-Jan-86 15:59")

         (* * Sends an IP packet, after first computing the IP header checksum)

    (PROG (NDB)
          (SETQ IP (\DTEST IP 'ETHERPACKET))
          (until \IP.READY do (AWAIT.EVENT \IP.READY.EVENT))
          (\RCLK (LOCF (ffetch EPTIMESTAMP of IP)))
          (replace EPTYPE of IP with \EPT.IP)
          (RETURN (COND
                     ((ffetch EPTRANSMITTING of IP)
                      (AND IPTRACEFLG (printout IPTRACEFILE 
                                             "[Put fails--packet already being transmitted]"))
                      'AlreadyQueued)
                     ((NOT (SETQ NDB (\IP.ROUTE.PACKET IP ROUTINGREADONLY)))
                      (AND IPTRACEFLG (PRINTPACKET IP 'PUT IPTRACEFILE "[Put fails--no routing]"))
                      (\REQUEUE.ETHERPACKET IP)
                      'NoRouting)
                     (T (\IP.SET.CHECKSUM IP (ffetch (IP IPBASE) of IP)
                               (LLSH (ffetch (IP IPHEADERLENGTH) of IP)
                                     2)
                               (LOCF (ffetch (IP IPHEADERCHECKSUM) of IP)))
                        [COND
                           (IPTRACEFLG (COND
                                          ((EQ IPTRACEFLG T)
                                           (PRINTPACKET IP 'PUT IPTRACEFILE))
                                          (T (PRIN1 "!" IPTRACEFILE]
                        (TRANSMIT.ETHERPACKET NDB IP)
                        NIL])

(\IP.ROUTE.PACKET
  [LAMBDA (IP READONLY)                                  (* ; "Edited 19-Jan-89 18:00 by bvm")

    (* ;; "Encapsulates XIP, choosing the right network and immediate destination host.  Returns an NDB for the transmission.  Unless READONLY is true, defaults source and destination nets if needed")

    (DECLARE (GLOBALVARS \10MBLOCALNDB \3MBLOCALNDB \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY))
    (PROG ((DESTADDRESS (fetch (IP IPDESTINATIONADDRESS) of IP))
           DESTNET SUBNETMASK SOURCEHOSTADDRESS SUBNETINUSE PDH ROUTE NDB EPTYPE BROADCASTP)
          (SETQ DESTNET (\IPNETADDRESS DESTADDRESS))

     (* ;; "Try to resolve a destination network of 0.0 If we have two attached networks, fail.")

          [COND
             ((AND (EQ 0 DESTADDRESS)
                   \10MBLOCALNDB \3MBLOCALNDB)
              (RETURN))
             ((EQ 0 DESTADDRESS)
              '[SETQ DESTADDRESS (\IP.MAKE.BROADCAST.ADDRESS (fetch NDBIPHOST#
                                                                    of (OR \10MBLOCALNDB 
                                                                               \3MBLOCALNDB]
              (SETQ DESTADDRESS -1)
              (SETQ BROADCASTP T)
              '(SETQ DESTNET (\IPNETADDRESS DESTADDRESS))
              (SETQ DESTNET (CAAR \IP.LOCAL.NETWORKS]

     (* ;; "First see if the destination network is one of our local networks")

          [COND
             [(AND (SETQ NDB (CDR (SASSOC DESTNET \IP.LOCAL.NETWORKS)))
                   (SETQ SUBNETMASK (CDR (SASSOC (SETQ SOURCEHOSTADDRESS (fetch (NDB NDBIPHOST#)
                                                                            of NDB))
                                                \IP.SUBNET.MASKS)))
                   (OR (AND (\IP.BROADCAST.ADDRESS DESTADDRESS)
                            (SETQ BROADCASTP T))
                       (EQP (LOGAND SOURCEHOSTADDRESS SUBNETMASK)
                            (LOGAND DESTADDRESS SUBNETMASK))
                       (PROGN (SETQ SUBNETINUSE T)
                              NIL)))

              (* ;; "A local net.  Try to find the Ethernet address of the host")

              (COND
                 [(SETQ PDH (SELECTQ (fetch (NDB NETTYPE) of NDB)
                                (10 (SETQ EPTYPE \EPT.IP)
                                    (COND
                                       (BROADCASTP BROADCASTNSHOSTNUMBER)
                                       (T (\AR.TRANSLATE.TO.10MB DESTADDRESS))))
                                (3 (SETQ EPTYPE \EET.IP)
                                   (\AR.TRANSLATE.TO.3MB DESTADDRESS))
                                (SHOULDNT]
                 (T                                          (* ; "Nope")
                    (RETURN]
             (T 
                (* ;; "The host is not on a local net.  See if we have a route to that host, or use the default route if necessary")

                (COND
                   [(SETQ ROUTE (OR [COND
                                       (SUBNETINUSE (CDR (SASSOC (LOGAND DESTADDRESS SUBNETMASK)
                                                                \IP.ROUTING.TABLE)))
                                       (T (CDR (SASSOC DESTNET \IP.ROUTING.TABLE]
                                    \IP.DEFAULT.GATEWAY))

                    (* ;; "We've got the IP address of the gateway")

                    (COND
                       [(SETQ NDB (CDR (SASSOC (\IPNETADDRESS ROUTE)
                                              \IP.LOCAL.NETWORKS)))

                        (* ;; "We know what network it's on")

                        (COND
                           [(SETQ PDH (SELECTQ (fetch (NDB NETTYPE) of NDB)
                                          (10 (SETQ EPTYPE \EPT.IP)
                                              (\AR.TRANSLATE.TO.10MB ROUTE))
                                          (3 (SETQ EPTYPE \EET.IP)
                                             (\AR.TRANSLATE.TO.3MB ROUTE))
                                          (SHOULDNT]
                           (T (RETURN]
                       (T (ERROR "IP routing table contains non-local gateway address for network" 
                                 DESTNET]
                   (T (RETURN]
          (freplace EPNETWORK of IP with NDB)
          (ENCAPSULATE.ETHERPACKET NDB IP PDH (ffetch (IP IPTOTALLENGTH) of IP)
                 EPTYPE)
          (replace EPTYPE of IP with EPTYPE)
          [COND
             ((NOT READONLY)
              (COND
                 ((EQ 0 (fetch (IP IPDESTINATIONADDRESS) of IP))
                  (freplace (IP IPDESTINATIONADDRESS) of IP with DESTADDRESS)))
              (freplace (IP IPSOURCEADDRESS) of IP with (fetch NDBIPHOST#
                                                                       of NDB]
          (RETURN NDB])
)
(DEFINEQ

(IP.GET
  [LAMBDA (IPSOCKET WAIT)                                (* ejs%: "31-Mar-86 14:30")

         (* * Returns the next IP packet on the queue, or NIL if none exist and WAIT is 
       NIL. If WAIT is T, this function waits forever.
       If WAIT is an integer, it is interpreted as the number of milliseconds to wait 
       before returning NIL or a packet which arrives during that time.
       This function therefore is like GETXIP and GETPUP)

    (PROG ((QUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET))
           IP TIMER)
      LP  (UNINTERRUPTABLY
              (COND
                 ((SETQ IP (\DEQUEUE QUEUE))
                  (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET)
                         -1))))
          [COND
             ((NULL IP)
              (COND
                 (WAIT (COND
                          ((EQ WAIT T))
                          [TIMER (COND
                                    ((TIMEREXPIRED? TIMER)
                                     (RETURN]
                          (T (OR (FIXP WAIT)
                                 (LISPERROR "NON-NUMERIC ARG" WAIT))
                             (SETQ TIMER (SETUPTIMER WAIT))
                             T))
                       (AWAIT.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET)
                              TIMER T)
                       (GO LP))
                 (T (BLOCK]
          (RETURN IP])

(IP.SEND
  [LAMBDA (IP)                                           (* ejs%: "31-Mar-86 15:07")
    (\IP.TRANSMIT IP])

(IP.PACKET.WATCHER
  [LAMBDA (IPSOCKET PACKET.FUNCTION)                     (* ejs%: "31-Mar-86 15:50")

         (* * Infinite loop which waits for packet on IPSOCKET, and calls 
       PACKET.FUNCTION whenever one arrives)

    (COND
       ((NOT (type? IPSOCKET IPSOCKET))
        (ERROR "ARG NOT IPSOCKET" IPSOCKET))
       ((NOT (FNTYP PACKET.FUNCTION))
        (ERROR "UNDEFINED FUNCTION" PACKET.FUNCTION))
       (T (while T do (APPLY* PACKET.FUNCTION (IP.GET IPSOCKET T)
                                     IPSOCKET])
)
(DECLARE%: EVAL@COMPILE 

[PUTPROPS IP.SEND MACRO (LAMBDA (IP)                     (* ejs%: "31-Mar-86 15:07")
                          (\IP.TRANSMIT IP]
)



(* ;; "Client functions for building packets")

(DEFINEQ

(\IP.APPEND.BYTE
  [LAMBDA (IP BYTE INHEADER)                             (* ejs%: "28-Dec-84 08:23")

         (* * Append a byte to an IP packet. If INHEADER is not NIL, we adjust the 
       header length field as well.)

    (PROG (NEWLENGTH)
          (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                 (fetch (IP IPTOTALLENGTH) of IP)
                 BYTE)
          (SETQ NEWLENGTH (add (ffetch (IP IPTOTALLENGTH) of IP)
                                 1))
          [COND
             (INHEADER (freplace (IP IPHEADERLENGTH) of IP with (FOLDHI NEWLENGTH 4]
          (RETURN NEWLENGTH])

(\IP.APPEND.CELL
  [LAMBDA (IP CELL INHEADER)                             (* ejs%: "28-Dec-84 08:33")

         (* * Append a cell to an IP packet. If INHEADER is not NIL, we adjust the 
       header length field as well.)

    (PROG (NEWLENGTH (OFFSET (fetch (IP IPTOTALLENGTH) of IP)))
          [COND
             ((EVENP OFFSET)
              (\PUTBASEFIXP (fetch (IP IPBASE) of IP)
                     (FOLDLO OFFSET 2)
                     CELL))
             (T (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       OFFSET
                       (LDB (BYTE 8 24)
                            CELL))
                (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       (\ADDBASE OFFSET 1)
                       (LDB (BYTE 8 16)
                            CELL))
                (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       (\ADDBASE OFFSET 2)
                       (LDB (BYTE 8 8)
                            CELL))
                (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       (\ADDBASE OFFSET 3)
                       (LDB (BYTE 8 0)
                            CELL]
          (SETQ NEWLENGTH (add (ffetch (IP IPTOTALLENGTH) of IP)
                                 4))
          (COND
             (INHEADER (add (ffetch (IP IPHEADERLENGTH) of IP)
                              1)))
          (RETURN NEWLENGTH])

(\IP.APPEND.STRING
  [LAMBDA (IP STRING)                                    (* ejs%: " 9-Feb-85 19:44")
    (PROG ((LENGTH (fetch (STRINGP LENGTH) of STRING)))
          (\MOVEBYTES (fetch (STRINGP BASE) of STRING)
                 (fetch (STRINGP OFFST) of STRING)
                 (fetch (IP IPBASE) of IP)
                 (fetch (IP IPTOTALLENGTH) of IP)
                 LENGTH)
          (RETURN (add (ffetch (IP IPTOTALLENGTH) of IP)
                         LENGTH])

(\IP.APPEND.WORD
  [LAMBDA (IP WORD INHEADER)                             (* ejs%: "28-Dec-84 08:28")

         (* * Append a word to an IP packet. If INHEADER is not NIL, we adjust the 
       header length field as well.)

    (PROG (NEWLENGTH (OFFSET (fetch (IP IPTOTALLENGTH) of IP)))
          [COND
             ((EVENP OFFSET)
              (\PUTBASE (fetch (IP IPBASE) of IP)
                     (FOLDLO OFFSET 2)
                     WORD))
             (T (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       OFFSET
                       (LDB (BYTE 8 8)
                            WORD))
                (\PUTBASEBYTE (fetch (IP IPBASE) of IP)
                       (\ADDBASE OFFSET 1)
                       (LDB (BYTE 8 0)
                            WORD]
          (SETQ NEWLENGTH (add (ffetch (IP IPTOTALLENGTH) of IP)
                                 2))
          [COND
             (INHEADER (freplace (IP IPHEADERLENGTH) of IP with (FOLDHI NEWLENGTH 4]
          (RETURN NEWLENGTH])

(\IP.GET.BYTE
  [LAMBDA (IP BYTE INHEADER)                             (* ejs%: "30-Mar-86 14:49")

         (* * Retrieve a byte from an IP packet.
       If INHEADER is T, BYTE is an offset from the start of the packet, else it's an 
       offset from the start of the IP data section)

    (\GETBASEBYTE (COND
                     (INHEADER (fetch (IP IPBASE) of IP))
                     (T (\IPDATABASE IP)))
           BYTE])

(\IP.GET.CELL
  [LAMBDA (IP CELL INHEADER)                             (* ejs%: "30-Mar-86 15:07")

         (* * Retrieve a cell from an IP packet.
       If INHEADER is not NIL, the cell is written to the header portion of the IP 
       packet, else it's written to the data portion.
       CELL is the offset, in 16-bit units)

    (\GETBASEFIXP (COND
                     (INHEADER (fetch (IP IPBASE) of IP))
                     (T (\IPDATABASE IP)))
           CELL])

(\IP.GET.STRING
  [LAMBDA (IP BYTEOFFSET NCHARS INHEADER)                (* ejs%: "30-Mar-86 15:13")

         (* * Retrieve a string from an IP packet.
       If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else 
       it's an offset from the start of the IP data section)

    (\GETBASESTRING (COND
                       (INHEADER (fetch (IP IPBASE) of IP))
                       (T (\IPDATABASE IP)))
           BYTEOFFSET NCHARS])

(\IP.GET.WORD
  [LAMBDA (IP WORD INHEADER)                             (* ejs%: "30-Mar-86 14:51")

         (* * Retrieve a word from an IP packet.
       If INHEADER is T, WORD is an offset from the start of the packet, else it's an 
       offset from the start of the IP data section)

    (\GETBASE (COND
                 (INHEADER (fetch (IP IPBASE) of IP))
                 (T (\IPDATABASE IP)))
           WORD])

(\IP.PUT.BYTE
  [LAMBDA (IP BYTE VALUE INHEADER)                       (* ejs%: "30-Mar-86 14:52")

         (* * Store a byte in an IP packet. If INHEADER is T, BYTE is an offset from the 
       start of the packet, else it's an offset from the start of the IP data section)

    (\PUTBASEBYTE (COND
                     (INHEADER (fetch (IP IPBASE) of IP))
                     (T (\IPDATABASE IP)))
           BYTE VALUE])

(\IP.PUT.CELL
  [LAMBDA (IP CELL VALUE INHEADER)                       (* ejs%: "30-Mar-86 15:06")

         (* * Store a cell in an IP packet. If INHEADER is not NIL, the cell is written 
       to the header portion of the IP packet, else it's written to the data portion.
       CELL is the offset, in 16-bit units)

    (\PUTBASEFIXP (COND
                     (INHEADER (fetch (IP IPBASE) of IP))
                     (T (\IPDATABASE IP)))
           CELL VALUE])

(\IP.PUT.STRING
  [LAMBDA (IP BYTEOFFSET STRING INHEADER)                (* ejs%: "30-Mar-86 15:13")

         (* * Store a string ib an IP packet. If INHEADER is T, BYTEOFFSET is an offset 
       from the start of the packet, else it's an offset from the start of the IP data 
       section)

    (\PUTBASESTRING (COND
                       (INHEADER (fetch (IP IPBASE) of IP))
                       (T (\IPDATABASE IP)))
           BYTEOFFSET STRING])

(\IP.PUT.WORD
  [LAMBDA (IP WORD VALUE INHEADER)                       (* ejs%: "30-Mar-86 14:50")

         (* * Store a word in an IP packet. If INHEADER is T, WORD is an offset from the 
       start of the packet, else it's an offset from the start of the IP data section)

    (\PUTBASE (COND
                 (INHEADER (fetch (IP IPBASE) of IP))
                 (T (\IPDATABASE IP)))
           WORD VALUE])
)
(DECLARE%: EVAL@COMPILE 

[PUTPROPS \IP.GET.BYTE DMACRO (LAMBDA (IP BYTE INHEADER) (* ejs%: "30-Mar-86 14:49")

         (* * Retrieve a byte from an IP packet.
       If INHEADER is T, BYTE is an offset from the start of the packet, else it's an 
       offset from the start of the IP data section)

                                (\GETBASEBYTE (COND
                                                 (INHEADER (fetch (IP IPBASE) of IP))
                                                 (T (\IPDATABASE IP)))
                                       BYTE]

[PUTPROPS \IP.GET.CELL DMACRO (LAMBDA (IP CELL INHEADER) (* ejs%: "30-Mar-86 15:07")

         (* * Retrieve a cell from an IP packet.
       If INHEADER is not NIL, the cell is written to the header portion of the IP 
       packet, else it's written to the data portion.
       CELL is the offset, in 16-bit units)

                                (\GETBASEFIXP (COND
                                                 (INHEADER (fetch (IP IPBASE) of IP))
                                                 (T (\IPDATABASE IP)))
                                       CELL]

[PUTPROPS \IP.GET.STRING DMACRO (LAMBDA (IP BYTEOFFSET NCHARS INHEADER)
                                                             (* ejs%: "30-Mar-86 15:13")

         (* * Retrieve a string from an IP packet.
       If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else 
       it's an offset from the start of the IP data section)

                                  (\GETBASESTRING (COND
                                                     (INHEADER (fetch (IP IPBASE) of IP))
                                                     (T (\IPDATABASE IP)))
                                         BYTEOFFSET NCHARS]

[PUTPROPS \IP.GET.WORD DMACRO (LAMBDA (IP WORD INHEADER) (* ejs%: "30-Mar-86 14:51")

         (* * Retrieve a word from an IP packet.
       If INHEADER is T, WORD is an offset from the start of the packet, else it's an 
       offset from the start of the IP data section)

                                (\GETBASE (COND
                                             (INHEADER (fetch (IP IPBASE) of IP))
                                             (T (\IPDATABASE IP)))
                                       WORD]

[PUTPROPS \IP.PUT.BYTE DMACRO (LAMBDA (IP BYTE VALUE INHEADER)
                                                             (* ejs%: "30-Mar-86 14:52")

         (* * Store a byte in an IP packet. If INHEADER is T, BYTE is an offset from the 
       start of the packet, else it's an offset from the start of the IP data section)

                                (\PUTBASEBYTE (COND
                                                 (INHEADER (fetch (IP IPBASE) of IP))
                                                 (T (\IPDATABASE IP)))
                                       BYTE VALUE]

[PUTPROPS \IP.PUT.CELL DMACRO (LAMBDA (IP CELL VALUE INHEADER)
                                                             (* ejs%: "30-Mar-86 15:06")

         (* * Store a cell in an IP packet. If INHEADER is not NIL, the cell is written 
       to the header portion of the IP packet, else it's written to the data portion.
       CELL is the offset, in 16-bit units)

                                (\PUTBASEFIXP (COND
                                                 (INHEADER (fetch (IP IPBASE) of IP))
                                                 (T (\IPDATABASE IP)))
                                       CELL VALUE]

[PUTPROPS \IP.PUT.STRING DMACRO (LAMBDA (IP BYTEOFFSET STRING INHEADER)
                                                             (* ejs%: "30-Mar-86 15:13")

         (* * Store a string ib an IP packet. If INHEADER is T, BYTEOFFSET is an offset 
       from the start of the packet, else it's an offset from the start of the IP data 
       section)

                                  (\PUTBASESTRING (COND
                                                     (INHEADER (fetch (IP IPBASE) of IP))
                                                     (T (\IPDATABASE IP)))
                                         BYTEOFFSET STRING]

[PUTPROPS \IP.PUT.WORD DMACRO (LAMBDA (IP WORD VALUE INHEADER)
                                                             (* ejs%: "30-Mar-86 14:50")

         (* * Store a word in an IP packet. If INHEADER is T, WORD is an offset from the 
       start of the packet, else it's an offset from the start of the IP data section)

                                (\PUTBASE (COND
                                             (INHEADER (fetch (IP IPBASE) of IP))
                                             (T (\IPDATABASE IP)))
                                       WORD VALUE]
)

(MOVD? 'NILL 'IP.DEFAULT.CONFIGURATION)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY \IP.INIT.FILE \IP.SUBNET.MASKS 
       \PROCESS.AFTEREXIT.EVENT \PROC.READY \AR.IP.TO.10MB.ALIST)
)
)
(PUTPROPS TCPLLIP COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (33488 35161 (\SYSQUEUE.DEFPRINT 33498 . 33847) (\IPSOCKET.DEFPRINT 33849 . 35159)) (
36483 52693 (\CANONICALIZE.IP.HOSTNAME 36493 . 36686) (DODIP.HOSTP 36688 . 37144) (IPHOSTADDRESS 37146
 . 37814) (IPHOSTNAME 37816 . 38028) (IPTRACE 38030 . 38227) (IPTRACEWINDOW.BUTTONFN 38229 . 38826) (
PRINTIP 38828 . 41424) (PRINTIPDATA 41426 . 42106) (\IPADDRESSCLASS 42108 . 42705) (\IPEVENTFN 42707
 . 43055) (\IPHOSTADDRESS 43057 . 43873) (\IPNETADDRESS 43875 . 44739) (\IP.ADDRESS.TO.STRING 44741 . 
45229) (\IP.BROADCAST.ADDRESS 45231 . 48921) (\IP.LEGAL.ADDRESS 48923 . 49271) (
\IP.MAKE.BROADCAST.ADDRESS 49273 . 49713) (\IP.PRINT.ADDRESS 49715 . 50333) (\IP.READ.STRING.ADDRESS 
50335 . 52200) (\DOMAIN.NAME.QUALIFY.FULLY 52202 . 52691)) (53342 70901 (STOPIP 53352 . 53628) (
\IPINIT 53630 . 55639) (\IPLISTENER 55641 . 56413) (\IP.REINITIALIZE.FROM.SCRATCH 56415 . 61690) (
\IP.RESTART.FROM.CONFIGURATION 61692 . 66877) (\IP.MAYBE.READ.HOSTS.TXT 66879 . 68355) (
\IP.READ.INIT.FILE 68357 . 70174) (\IP.PROMPT.FOR.FILE.NAME 70176 . 70899)) (75225 84872 (
\HANDLE.RAW.IP 75235 . 77533) (\FORWARD.IP 77535 . 80265) (\IP.LOCAL.DESTINATION 80267 . 82052) (
\IPCHECKSUM 82054 . 84204) (\IP.CHECKSUM.OK 84206 . 84382) (\IP.SET.CHECKSUM 84384 . 84870)) (85442 
97726 (\IP.HAND.TO.PROTOCOL 85452 . 86504) (\IP.DEFAULT.INPUTFN 86506 . 87105) (\IP.DEFAULT.NOSOCKETFN
 87107 . 87491) (\IP.ADD.PROTOCOL 87493 . 89620) (\IP.DELETE.PROTOCOL 89622 . 90351) (
\IP.FIND.PROTOCOL 90353 . 90740) (\IP.FIND.PROTOCOL.SOCKET 90742 . 92342) (\IP.FIND.SOCKET 92344 . 
93234) (\IP.OPEN.SOCKET 93236 . 96216) (\IP.CLOSE.SOCKET 96218 . 97724)) (98507 118821 (
\HANDLE.RAW.IP.FRAGMENT 98517 . 99124) (\IP.NEW.FRAGMENT.LST 99126 . 102391) (
\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER 102393 . 102894) (\IP.ADD.FRAGMENT 102896 . 111986) (
\IP.FIND.MATCHING.FRAGMENTS 111988 . 114409) (\IP.FRAGMENTED.PACKET 114411 . 114700) (
\IP.CHECK.REASSEMBLY.TIMEOUTS 114702 . 116007) (\IP.DELETE.FRAGMENT 116009 . 116501) (
\IP.PRINT.FRAGMENT 116503 . 118819)) (119865 128230 (\IP.PROCESS.OPTIONS 119875 . 122592) (
\IP.OPTION.RECORD.ROUTE 122594 . 123607) (\IP.OPTION.STRICT.SOURCE.ROUTE 123609 . 125209) (
\IP.OPTION.TIMESTAMP 125211 . 128228)) (128581 136430 (\IP.SETUPIP 128591 . 129761) (\IP.TRANSMIT 
129763 . 131402) (\IP.ROUTE.PACKET 131404 . 136428)) (136431 138607 (IP.GET 136441 . 137907) (IP.SEND 
137909 . 138041) (IP.PACKET.WATCHER 138043 . 138605)) (138832 146433 (\IP.APPEND.BYTE 138842 . 139504)
 (\IP.APPEND.CELL 139506 . 140978) (\IP.APPEND.STRING 140980 . 141518) (\IP.APPEND.WORD 141520 . 
142611) (\IP.GET.BYTE 142613 . 143077) (\IP.GET.CELL 143079 . 143589) (\IP.GET.STRING 143591 . 144084)
 (\IP.GET.WORD 144086 . 144538) (\IP.PUT.BYTE 144540 . 144994) (\IP.PUT.CELL 144996 . 145496) (
\IP.PUT.STRING 145498 . 145987) (\IP.PUT.WORD 145989 . 146431)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPNAMES b/obsolete/tcp/TCPNAMES
deleted file mode 100644
index 13c7aa25..00000000
--- a/obsolete/tcp/TCPNAMES
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 8-Oct-90 17:23:42" |{LISPDEV:LAIR:OHIO-STATE}<WELCH>TCPNAMES.;2| 70558  

      changes to%:  (VARS TCPNAMESCOMS)
                    (FNS REPACKFILENAME.STRING REPACKFILENAME.STRING.D REPACKFILENAME.STRING.MSDOS 
                         REPACKFILENAME.STRING.TI REPACKFILENAME.STRING.VMS 
                         REPACKFILENAME.STRING.3600 REPACKFILENAME.STRING.TOPS20 
                         REPACKFILENAME.STRING.UNIX \REPACKFILENAME.NEW.TRANSLATION 
                         \REPACKFILENAME.NEW.TRANSLATIONS)

      previous date%: "12-Sep-90 17:37:35" {DSK}<users>gadener>medley>work>tcp>tcpnames.;2)


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

(PRETTYCOMPRINT TCPNAMESCOMS)

(RPAQQ TCPNAMESCOMS [(PROP MAKEFILE-ENVIRONMENT TCPNAMES)
                         (PROP FILETYPE TCPNAMES)
                         (FNS REPACKFILENAME.STRING REPACKFILENAME.STRING.D 
                              REPACKFILENAME.STRING.MSDOS REPACKFILENAME.STRING.TI 
                              REPACKFILENAME.STRING.VMS REPACKFILENAME.STRING.3600 
                              REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.UNIX 
                              \REPACKFILENAME.NEW.TRANSLATION \REPACKFILENAME.NEW.TRANSLATIONS)
                         (INITVARS (\REPACKFILENAME.OSTYPE.TABLE (HASHARRAY 30 1.1)))
                         (GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE)
                         (P (\REPACKFILENAME.NEW.TRANSLATIONS (INTERLISP IFS)
                                   REPACKFILENAME.STRING.D
                                   (TOPS-20 TOPS20)
                                   REPACKFILENAME.STRING.TOPS20
                                   (SYMBOLICS-3600 LISPM GENERA)
                                   REPACKFILENAME.STRING.3600 VMS REPACKFILENAME.STRING.VMS UNIX 
                                   REPACKFILENAME.STRING.UNIX MS-DOS REPACKFILENAME.STRING.MSDOS))
                         (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
                                (ADDVARS (NLAMA \REPACKFILENAME.NEW.TRANSLATIONS)
                                       (NLAML)
                                       (LAMA REPACKFILENAME.STRING.UNIX REPACKFILENAME.STRING.TOPS20
                                             REPACKFILENAME.STRING.3600 REPACKFILENAME.STRING.VMS 
                                             REPACKFILENAME.STRING.TI REPACKFILENAME.STRING.MSDOS 
                                             REPACKFILENAME.STRING.D])

(PUTPROPS TCPNAMES MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10))

(PUTPROPS TCPNAMES FILETYPE :BCOMPL)
(DEFINEQ

(REPACKFILENAME.STRING
  [LAMBDA (NAME FOROSTYPE)                               (* ; "Edited 29-Sep-90 11:47 by welch")
    (DECLARE (GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE))
    (LET ((REPACKFUNCTION (GETHASH FOROSTYPE \REPACKFILENAME.OSTYPE.TABLE)))
         (COND
            ((NULL REPACKFUNCTION)
             NAME)
            (T (APPLY REPACKFUNCTION (UNPACKFILENAME.STRING NAME])

(REPACKFILENAME.STRING.D
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:23 by welch")

         (* * Convert file names to native format)

    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.D)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY DIR NAME EXTENSION 
             VERSION PACKLIST VAR VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.D VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST "{" HOST "}"))
                            [AND DEVICE (NEQ DEVICE BLIP)
                                 (SELCHARQ (NTHCHARCODE DEVICE -1)
                                      (%: (LIST DEVICE))
                                      (LIST DEVICE '%:]
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE \)
                                                                             (CHARCODE /]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE >]
                                        (LIST "<" DIRECTORY ">"))
                                 (LIST "<" DIRECTORY ">"))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (CHARCODE >)
                                                                    (LIST (CHARCODE \)
                                                                          (CHARCODE /]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE >]
                                        (LIST "<" SUBDIRECTORY ">"))
                                 (LIST "<" SUBDIRECTORY ">"))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (CHARCODE >)
                                                                    (LIST (CHARCODE \)
                                                                          (CHARCODE /]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        >]
                                        (LIST "<" RELATIVEDIRECTORY ">"))
                                 (LIST "<" RELATIVEDIRECTORY ">"))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                              (CHARCODE %.)))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP)))
                            (AND VERSION (NEQ VERSION BLIP)
                                 (COND
                                    ((FIXP VERSION)
                                     (LIST '; VERSION))
                                    (T (SELCHARQ (CHCON1 VERSION)
                                            (; (LIST VERSION))
                                            ((%. !) 
                                                 (LIST '; (SUBSTRING VERSION 2 -1)))
                                            (LIST '; VERSION])

(REPACKFILENAME.STRING.MSDOS
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:48 by welch")
    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.MSDOS)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR RELATIVEDIRECTORY 
             SUBDIRECTORY VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY 
                                NAME EXTENSION VERSION))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.MSDOS VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST "{" HOST "}"))
                            (AND DEVICE (NEQ DEVICE BLIP)
                                 (LIST ":" DEVICE))
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE \]
                                        (LIST "\" DIRECTORY "\"))
                                 (LIST "\" DIRECTORY "\"))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE \]
                                        (LIST "\" SUBDIRECTORY "\"))
                                 (LIST "\" SUBDIRECTORY "\"))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        \]
                                        (LIST "\" RELATIVEDIRECTORY "\"))
                                 (LIST "\" RELATIVEDIRECTORY "\"))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((OR (AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                                  (CHARCODE %.)))
                                               (OR (NULL EXTENSION)
                                                   (EQ EXTENSION BLIP)
                                                   (STREQUAL EXTENSION "")))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP])

(REPACKFILENAME.STRING.TI
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:59 by welch")

         (* * Can you believe this???)

    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.TI)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY NAME EXTENSION VERSION 
             PACKLIST VAR VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY 
                                NAME EXTENSION VERSION))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.TI VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST HOST ":"))
                            (AND DEVICE (NEQ DEVICE BLIP)
                                 (SELCHARQ (NTHCHARCODE DEVICE -1)
                                      (%: (LIST DEVICE))
                                      (LIST DEVICE |':|)))
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE %.]
                                        (LIST DIRECTORY ";")))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE %.]
                                        (LIST SUBDIRECTORY ";")))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE >)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        %.]
                                        (LIST RELATIVEDIRECTORY ";")))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                              (CHARCODE %.)))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP)))
                            (AND VERSION (NEQ VERSION BLIP)
                                 (COND
                                    ((FIXP VERSION)
                                     (LIST '%# VERSION))
                                    (T (SELCHARQ (CHCON1 VERSION)
                                            (%# (LIST VERSION))
                                            ((%. ! ;) 
                                                 (LIST '%# (SUBSTRING VERSION 2 -1)))
                                            (L (LIST '%# 'OLDEST))
                                            ((H 0) 
                                                 (LIST '%# '>))
                                            (LIST '%# VERSION])

(REPACKFILENAME.STRING.VMS
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:52 by welch")
    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.VMS)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY NAME EXTENSION VERSION 
             TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY 
                                NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.VMS VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST "{" HOST "}"))
                            [AND DEVICE (NEQ DEVICE BLIP)
                                 (SELCHARQ (NTHCHARCODE DEVICE -1)
                                      (%: (LIST DEVICE))
                                      (LIST DEVICE '%:]
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE %.]
                                        (LIST "[" DIRECTORY "]")))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE %.]
                                        (LIST "[" SUBDIRECTORY "]")))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        %.]
                                        (LIST "[" RELATIVEDIRECTORY "]")))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                              (CHARCODE %.)))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP)))
                            (AND VERSION (NEQ VERSION BLIP)
                                 (COND
                                    ((FIXP VERSION)
                                     (LIST '; VERSION))
                                    (T (SELCHARQ (CHCON1 VERSION)
                                            (; (LIST VERSION))
                                            ((%. !) 
                                                 (LIST '; (SUBSTRING VERSION 2 -1)))
                                            (LIST '; VERSION])

(REPACKFILENAME.STRING.3600
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:46 by welch")

         (* * Can you believe this???)

    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.3600)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR VAL TEMP 
             RELATIVEDIRECTORY SUBDIRECTORY)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION 
                                SUBDIRECTORY RELATIVEDIRECTORY))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.3600 VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST HOST ":"))
                            [AND DEVICE (NEQ DEVICE BLIP)
                                 (SELCHARQ (NTHCHARCODE DEVICE -1)
                                      (%: (LIST DEVICE))
                                      (LIST DEVICE '%:]
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE >]
                                        (LIST ">" DIRECTORY ">")))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE >]
                                        (LIST ">" SUBDIRECTORY ">")))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE %.)
                                                                             (CHARCODE /)
                                                                             (CHARCODE \]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        >]
                                        (LIST ">" RELATIVEDIRECTORY ">")))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                              (CHARCODE %.)))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP)))
                            (AND VERSION (NEQ VERSION BLIP)
                                 (COND
                                    ((FIXP VERSION)
                                     (LIST '%. VERSION))
                                    (T (SELCHARQ (CHCON1 VERSION)
                                            (; (LIST VERSION))
                                            ((%. !) 
                                                 (LIST '%. (SUBSTRING VERSION 2 -1)))
                                            (L (LIST '%. 'OLDEST))
                                            ((H 0) 
                                                 (LIST '%. 'NEWEST))
                                            (LIST '%. VERSION])

(REPACKFILENAME.STRING.TOPS20
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:42 by welch")
    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.TOPS20)
                     (ARG N 1))
      else
      (PROG ((BLIP "")
             (I 1)
             HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY RELATIVEDIRECTORY 
             SUBDIRECTORY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP)
            (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY 
                                PROTECTION ACCOUNT))
        LP  (COND
               ((NOT (IGREATERP I N))
                (COND
                   ((LISTP (SETQ VAR (ARG N I)))
                    (SETQ VAL (CDR VAR))
                    (SETQ VAR (CAR VAR)))
                   ((NOT (IGREATERP (SETQ I (ADD1 I))
                                N))
                    (SETQ VAL (ARG N I)))
                   (T (SETQ VAL)))
                (OR (STRINGP VAL)
                    (ATOM VAL)
                    (ERRORX (LIST 27 VAL)))                  (* fields must be atom)
                (SELECTQ VAR
                    (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                         ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                          (REPACKFILENAME.STRING.TOPS20 VAL))
                                                         (T VAL)))
                               [FUNCTION (LAMBDA (X)         (* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                           (OR (EVALV (CAR X))
                                               (SET (CAR X)
                                                    (OR (CADR X)
                                                        BLIP]
                               (FUNCTION CDDR)))
                    (HOST (OR HOST (SETQ HOST (if VAL
                                                  then (SELCHARQ (CHCON1 VAL)
                                                                (({ %[ %() 
                                                                     (SUBSTRING VAL 2
                                                                            (SELCHARQ (NTHCHARCODE
                                                                                       VAL -1)
                                                                                 ((} %] %)) 
                                                                                      -2)
                                                                                 -1)))
                                                                VAL)
                                                else BLIP))))
                    (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                    (if VAL
                                                        then (CONCAT (CL:STRING-LEFT-TRIM
                                                                          "<"
                                                                          (CL:DIRECTORY-NAMESTRING
                                                                           
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                           ))
                                                                        VAL)
                                                      else BLIP))))
                    (RELATIVEDIRECTORY 
                         (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                (if VAL
                                                    then (CONCAT (CL:STRING-LEFT-TRIM
                                                                      "<"
                                                                      (CL:DIRECTORY-NAMESTRING 
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                             ))
                                                                    VAL)
                                                  else BLIP))))
                    (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                    ((DEVICE HOST NAME EXTENSION VERSION) 
                         (OR (EVALV VAR)
                             (SET VAR (OR VAL BLIP))))
                    (\ILLEGAL.ARG VAR))
                (SETQ I (ADD1 I))
                (GO LP)))
            (SELECTQ TEMPORARY
                ((T S ;S)                                    (* hack for Interlisp-D!)
                     (OR HOST DEVICE (PROGN (SETQ HOST 'CORE)
                                            (SETQ TEMPORARY))))
                NIL)
            (RETURN (CONCATLIST
                     (NCONC (AND HOST (NEQ HOST BLIP)
                                 (LIST "{" HOST "}"))
                            [AND DEVICE (NEQ DEVICE BLIP)
                                 (SELCHARQ (NTHCHARCODE DEVICE -1)
                                      (%: (LIST DEVICE))
                                      (LIST DEVICE '%:]
                            (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                 (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                        [for C from 1 to (NCHARS DIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE DIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE DIRECTORY C (CHARCODE %.]
                                        (LIST "<" DIRECTORY ">")))
                            (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                 (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                        [for C from 1 to (NCHARS SUBDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE SUBDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE SUBDIRECTORY C (CHARCODE %.]
                                        (LIST "<" SUBDIRECTORY ">")))
                            (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                 (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                        [for C from 1 to (NCHARS RELATIVEDIRECTORY)
                                           do (COND
                                                     ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C)
                                                             (CONSTANT (LIST (CHARCODE /)
                                                                             (CHARCODE >]
                                                      (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE
                                                                                        %.]
                                        (LIST "<" RELATIVEDIRECTORY ">")))
                            (AND NAME (NEQ NAME BLIP)
                                 (LIST NAME))
                            (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                     (AND VERSION (NEQ VERSION BLIP)))
                                 (LIST (COND
                                          ((AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                              (CHARCODE %.)))
                                           BLIP)
                                          (T '%.))
                                       (OR EXTENSION BLIP)))
                            [AND VERSION (NEQ VERSION BLIP)
                                 (COND
                                    ((FIXP VERSION)
                                     (LIST '%. VERSION))
                                    (T (SELCHARQ (CHCON1 VERSION)
                                            (; (LIST VERSION))
                                            ((%. !) 
                                                 (LIST '%. (SUBSTRING VERSION 2 -1)))
                                            (L (LIST '%. -2))
                                            (H (LIST '%. 0))
                                            (LIST '%. VERSION]
                            (AND TEMPORARY (NEQ TEMPORARY BLIP)
                                 (LIST '; (SELECTQ TEMPORARY
                                              ((S ;S) 
                                                   'S)
                                              T])

(REPACKFILENAME.STRING.UNIX
  [LAMBDA N                                              (* ; "Edited  8-Oct-90 16:48 by welch")
    (if (AND (EQ N 1)
                 (LISTP (ARG N 1)))
        then                                             (* spread argument list)
              (APPLY (FUNCTION REPACKFILENAME.STRING.UNIX)
                     (ARG N 1))
      else (PROG ((BLIP "")
                      (I 1)
                      HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY DIR NAME 
                      EXTENSION VERSION PACKLIST VAR VAL TEMP)
                     (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME RELATIVEDIRECTORY 
                                         SUBDIRECTORY EXTENSION VERSION))
                 LP  (COND
                        ((NOT (IGREATERP I N))
                         (COND
                            ((LISTP (SETQ VAR (ARG N I)))
                             (SETQ VAL (CDR VAR))
                             (SETQ VAR (CAR VAR)))
                            ((NOT (IGREATERP (SETQ I (ADD1 I))
                                         N))
                             (SETQ VAL (ARG N I)))
                            (T (SETQ VAL)))
                         (OR (STRINGP VAL)
                             (ATOM VAL)
                             (ERRORX (LIST 27 VAL)))         (* fields must be atom)
                         (SELECTQ VAR
                             (BODY (MAP (UNPACKFILENAME.STRING (COND
                                                                  ((LISTP VAL)
                                                             (* PACKFILENAME.STRING for error 
                                                           checking of fields)
                                                                   (REPACKFILENAME.STRING.UNIX
                                                                    VAL))
                                                                  (T VAL)))
                                        [FUNCTION (LAMBDA (X)(* NIL => not yet seen, BLIP => seen 
                                                           as NIL.)
                                                    (OR (EVALV (CAR X))
                                                        (SET (CAR X)
                                                             (OR (CADR X)
                                                                 BLIP]
                                        (FUNCTION CDDR)))
                             (HOST (OR HOST (SETQ HOST
                                             (if VAL
                                                 then (SELCHARQ (CHCON1 VAL)
                                                               (({ %[ %() 
                                                                    (SUBSTRING VAL 2
                                                                           (SELCHARQ (NTHCHARCODE
                                                                                      VAL -1)
                                                                                ((} %] %)) 
                                                                                     -2)
                                                                                -1)))
                                                               VAL)
                                               else BLIP))))
                             (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY
                                                             (if VAL
                                                                 then (CONCAT (
                                                                                  CL:STRING-LEFT-TRIM
                                                                                   "<"
                                                                                   (
                                                                              CL:DIRECTORY-NAMESTRING
                                                                                    
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                                    ))
                                                                                 VAL)
                                                               else BLIP))))
                             (RELATIVEDIRECTORY 
                                  (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY
                                                         (if VAL
                                                             then (CONCAT (CL:STRING-LEFT-TRIM
                                                                               "<"
                                                                               (
                                                                              CL:DIRECTORY-NAMESTRING
                                                                                
                                                                          *DEFAULT-PATHNAME-DEFAULTS*
                                                                                ))
                                                                             VAL)
                                                           else BLIP))))
                             (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP))))
                             ((DEVICE HOST NAME EXTENSION VERSION) 
                                  (OR (EVALV VAR)
                                      (SET VAR (OR VAL BLIP))))
                             (\ILLEGAL.ARG VAR))
                         (SETQ I (ADD1 I))
                         (GO LP)))
                     (RETURN (CONCATLIST
                              (NCONC (AND HOST (NEQ HOST BLIP)
                                          (LIST "{" HOST "}"))
                                     (AND DEVICE (NEQ DEVICE BLIP)
                                          (LIST "/" DEVICE))
                                     (AND DIRECTORY (NEQ DIRECTORY BLIP)
                                          (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
                                                 [for C from 1 to (NCHARS DIRECTORY)
                                                    do (COND
                                                              ((EQ (NTHCHARCODE DIRECTORY C)
                                                                   (CONSTANT (CHARCODE >)))
                                                               (RPLCHARCODE DIRECTORY C (CHARCODE
                                                                                         /]
                                                 (LIST "/" DIRECTORY "/"))
                                          (LIST "/" DIRECTORY "/"))
                                     (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP)
                                          (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY))
                                                 [for C from 1 to (NCHARS SUBDIRECTORY)
                                                    do (COND
                                                              ((EQ (NTHCHARCODE SUBDIRECTORY C)
                                                                   (CONSTANT (CHARCODE >)))
                                                               (RPLCHARCODE SUBDIRECTORY C
                                                                      (CHARCODE /]
                                                 (LIST "/" SUBDIRECTORY "/"))
                                          (LIST "/" SUBDIRECTORY "/"))
                                     (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP)
                                          (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY))
                                                 [for C from 1 to (NCHARS 
                                                                                    RELATIVEDIRECTORY
                                                                                     )
                                                    do (COND
                                                              ((EQ (NTHCHARCODE RELATIVEDIRECTORY C)
                                                                   (CONSTANT (CHARCODE >)))
                                                               (RPLCHARCODE RELATIVEDIRECTORY C
                                                                      (CHARCODE /]
                                                 (LIST "/" RELATIVEDIRECTORY "/"))
                                          (LIST "/" RELATIVEDIRECTORY "/"))
                                     (AND NAME (NEQ NAME BLIP)
                                          (LIST NAME))
                                     (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
                                              (AND VERSION (NEQ VERSION BLIP)))
                                          (LIST (COND
                                                   ((OR (AND EXTENSION (EQ (CHCON1 EXTENSION)
                                                                           (CHARCODE %.)))
                                                        (OR (NULL EXTENSION)
                                                            (EQ EXTENSION BLIP)
                                                            (STREQUAL EXTENSION "")))
                                                    BLIP)
                                                   (T '%.))
                                                (OR EXTENSION BLIP])

(\REPACKFILENAME.NEW.TRANSLATION
  [LAMBDA (OSTYPE FUNCTION)
    (DECLARE (GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE))
                                                             (* ejs%: "27-Apr-85 13:36")
    (PUTHASH OSTYPE FUNCTION \REPACKFILENAME.OSTYPE.TABLE])

(\REPACKFILENAME.NEW.TRANSLATIONS
  [NLAMBDA NAMES                                         (* ejs%: "27-Apr-85 13:36")

         (* * Supply a property-list format argument of ostypes and translating 
       functions to be added to ostype table)

    (for TAIL on NAMES by (CDDR TAIL) do (for OSTYPE inside (CAR TAIL)
                                                            do (\REPACKFILENAME.NEW.TRANSLATION
                                                                    OSTYPE
                                                                    (CADR TAIL])
)

(RPAQ? \REPACKFILENAME.OSTYPE.TABLE (HASHARRAY 30 1.1))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE)
)

(\REPACKFILENAME.NEW.TRANSLATIONS (INTERLISP IFS)
       REPACKFILENAME.STRING.D
       (TOPS-20 TOPS20)
       REPACKFILENAME.STRING.TOPS20
       (SYMBOLICS-3600 LISPM GENERA)
       REPACKFILENAME.STRING.3600 VMS REPACKFILENAME.STRING.VMS UNIX REPACKFILENAME.STRING.UNIX 
       MS-DOS REPACKFILENAME.STRING.MSDOS)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA \REPACKFILENAME.NEW.TRANSLATIONS)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA REPACKFILENAME.STRING.UNIX REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.3600
                         REPACKFILENAME.STRING.VMS REPACKFILENAME.STRING.TI 
                         REPACKFILENAME.STRING.MSDOS REPACKFILENAME.STRING.D)
)
(PUTPROPS TCPNAMES COPYRIGHT ("Xerox Corporation" 1985 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2757 69593 (REPACKFILENAME.STRING 2767 . 3171) (REPACKFILENAME.STRING.D 3173 . 12368) (
REPACKFILENAME.STRING.MSDOS 12370 . 21255) (REPACKFILENAME.STRING.TI 21257 . 30611) (
REPACKFILENAME.STRING.VMS 30613 . 39537) (REPACKFILENAME.STRING.3600 39539 . 49180) (
REPACKFILENAME.STRING.TOPS20 49182 . 58763) (REPACKFILENAME.STRING.UNIX 58765 . 68684) (
\REPACKFILENAME.NEW.TRANSLATION 68686 . 68967) (\REPACKFILENAME.NEW.TRANSLATIONS 68969 . 69591)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPOPS b/obsolete/tcp/TCPOPS
deleted file mode 100644
index 5e47a466..00000000
--- a/obsolete/tcp/TCPOPS
+++ /dev/null
@@ -1,212 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
-(FILECREATED "22-May-90 10:55:20" |{DSK}/home/neptune/jds/TCPOPS.;17| 14660  
-
-      |changes| |to:|  (FNS TCP-ACCEPT TCP-LISTEN UDP-RECV)
-
-      |previous| |date:| " 3-May-90 11:40:39" |{DSK}/home/neptune/jds/TCPOPS.;16|)
-
-
-; Copyright (c) 1989, 1990 by Savoir, Inc..  All rights reserved.
-
-(PRETTYCOMPRINT TCPOPSCOMS)
-
-(RPAQQ TCPOPSCOMS ((FILES CHARDEVICE) (ADDVARS (\\INITSUBRS (TCP 144))) (COMS (* |;;| "TCP Streams") (FNS \\TCP-DEV-INIT \\TCP-OPENFILE \\TCP-FORCEOUTPUT \\TCP-GETNEXTBUFFER \\TCP-EOFP \\TCP-CLOSEFILE \\TCP-EVENTFN \\TCP.BUFFERED.BOUTS) (P (\\TCP-DEV-INIT))) (COMS (* |;;| "User-level TCP operations") (FNS TCP OPENTCPSTREAM TCP-ACCEPT TCP-LISTEN TCP-CLOSE) (FNS UDP-LISTEN UDP-SEND UDP-RECV) (FNS GETHOSTFROMNAME GETHOSTFROMADDR GETHOSTFROMSOCKET GETHOSTNAME)) (DECLARE\: EVAL@LOAD DONTCOPY (COMS (* |;;| "Debugging functions &c") (VARS (BUFFER (\\ALLOCBLOCK 100))) (FNS TCPRECV TCPSEND SEEBUFFER FOON)))))
-
-(FILESLOAD CHARDEVICE)
-
-(ADDTOVAR \\INITSUBRS (TCP 144))
-
-
-
-(* |;;| "TCP Streams")
-
-(DEFINEQ
-
-(\\TCP-DEV-INIT
-(LAMBDA NIL (* \; "Edited 20-Feb-90 12:51 by jds") (* |;;| "Initialization for buffered Unix-character-oriented device (e.g. for TCP streams on SUN)") (SETQ \\TCP-FDEV (|create| FDEV DEVICENAME _ "TCP" FDBINABLE _ T FDBOUTABLE _ T BUFFERED _ T BIN _ (FUNCTION \\BUFFERED.BIN) BOUT _ (FUNCTION \\BUFFCHAR-OTHER-BOUT) OPENFILE _ (FUNCTION \\BUFFCHAR-DEV-OPENFILE) EVENTFN _ (FUNCTION \\CHAR-DEV-EVENTFN) REOPENFILE _ (FUNCTION \\BUFFCHAR-DEV-OPENFILE) CLOSEFILE _ (FUNCTION \\TCP-CLOSEFILE) FORCEOUTPUT _ (FUNCTION \\TCP-FORCEOUTPUT) EOFP _ (FUNCTION \\TCP-EOFP) BLOCKIN _ (FUNCTION \\BUFFERED.BINS) BLOCKOUT _ (FUNCTION \\TCP.BUFFERED.BOUTS) READP _ (FUNCTION \\GENERIC.READP) PEEKBIN _ (FUNCTION \\BUFFERED.PEEKBIN) GETNEXTBUFFER _ (FUNCTION \\TCP-GETNEXTBUFFER))) (\\DEFINEDEVICE (QUOTE TCP) \\TCP-FDEV))
-)
-
-(\\TCP-OPENFILE
-(LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) (* \; "Edited  7-Mar-90 10:11 by jds") (LET ((UNIX-NAME (SUBSTRING NAME (ADD1 (STRPOS "}" NAME)))) (ERRNO (CREATECELL \\FIXP)) IODESCRIPTOR ACCESS-VALUE STREAM OTHER-STREAM) (SETQ STREAM (|create| STREAM BINABLE _ T BOUTABLE _ NIL DEVICE _ FDEV FULLFILENAME _ NAME USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC)) (SELECTQ ACCESS (INPUT (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (SETQ ACCESS-VALUE 0)) (OUTPUT (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (REPLACE F2 OF STREAM WITH (SETQ OTHER-STREAM (|create| STREAM BINABLE _ NIL BOUTABLE _ NIL DEVICE _ FDEV FULLFILENAME _ NAME STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC))) (SETQ ACCESS-VALUE 1)) (BOTH (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (REPLACE F2 OF STREAM WITH (SETQ OTHER-STREAM (|create| STREAM BINABLE _ NIL BOUTABLE _ NIL DEVICE _ FDEV FULLFILENAME _ NAME STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC))) (SETQ ACCESS-VALUE 2)) (APPEND (\\ILLEGAL.ARG ACCESS)) (\\ILLEGAL.ARG ACCESS)) (COND ((SETQ IODESCRIPTOR (SUBRCALL CHAR-OPENFILE UNIX-NAME ACCESS-VALUE ERRNO)) (* |;;| "Open happened, so put things together.") (|replace| (STREAM F1) |of| STREAM |with| IODESCRIPTOR) (COND (OTHER-STREAM (|replace| (STREAM F1) |of| OTHER-STREAM |with| IODESCRIPTOR)))) (T (\\CHAR-ERROR ERRNO NAME))) STREAM))
-)
-
-(\\TCP-FORCEOUTPUT
-  (LAMBDA (STREAM WAIT)                                  (* \; "Edited 15-Dec-89 16:09 by jds")
-
-(* |;;;| "Generic buffer refiller for Buffered character streams (e.g. TCP streams on Sun, or the Lisp side of a shell CHAT, eventually)")
-
-    (PROG (ERRCODE (OTHER-STREAM (|fetch| F2 |of| STREAM))
-                 (ERRNO (\\CREATECELL \\FIXP))
-                 BUFFER)
-          (COND
-             ((NULL (|fetch| CPPTR |of| OTHER-STREAM))
-
-              (* |;;| "No buffer allocated yet; create one.")
-
-              (REPLACE CPPTR OF OTHER-STREAM WITH (NCREATE 'VMEMPAGEP))
-              (REPLACE CBUFSIZE OF OTHER-STREAM WITH 512)
-              (REPLACE CBUFMAXSIZE OF OTHER-STREAM WITH 512)
-              (REPLACE COFFSET OF OTHER-STREAM WITH 0)
-              T)
-             ((ZEROP (|fetch| COFFSET |of| OTHER-STREAM))
-              T)
-             ((SETQ ERRCODE (\\CHAR-BOUTS OTHER-STREAM (|fetch| CPPTR |of| OTHER-STREAM)
-                                   0
-                                   (|fetch| COFFSET |of| OTHER-STREAM)
-                                   NIL))
-
-              (* |;;| "WRITE HAPPENED.")
-
-              (|replace| CBUFSIZE |of| OTHER-STREAM |with| 512)
-              (|replace| CBUFMAXSIZE |of| OTHER-STREAM |with| 512)
-              (|replace| COFFSET |of| OTHER-STREAM |with| 0)
-              T)))))
-
-(\\TCP-GETNEXTBUFFER
-(LAMBDA (STREAM WHATFOR NOERRORFLG EOF-TEST) (* \; "Edited 20-Feb-90 12:43 by jds") (* |;;;| "Generic buffer refiller for Buffered character streams (e.g. TCP streams on Sun, or the Lisp side of a shell CHAT, eventually).") (PROG (ERRCODE (ERRNO (\\CREATECELL \\FIXP)) BUFFER) READ-LOOP (RETURN (SELECTQ WHATFOR (READ (* |;;| "READING; GET A FRESH BUFFER FULL OF UN-READ CHARACTERS.") (SETQ BUFFER (OR (FETCH (STREAM CPPTR) OF STREAM) (NCREATE (QUOTE VMEMPAGEP)))) (|replace| CPPTR |of| STREAM |with| BUFFER) (COND ((ZEROP (SETQ ERRCODE (TCP 6 (|fetch| (STREAM F1) |of| STREAM) BUFFER 512))) (AND (NULL NOERRORFLG) (\\EOF.ACTION STREAM)) NIL) ((EQ ERRCODE T) (AND EOF-TEST (RETURN T)) (BLOCK) (GO READ-LOOP)) (ERRCODE (* |;;| "Read succeeded, and ERRCODE has # of chars read.") (|replace| CPPTR |of| STREAM |with| BUFFER) (|replace| COFFSET |of| STREAM |with| 0) (|replace| CBUFSIZE |of| STREAM |with| ERRCODE) (|replace| CBUFMAXSIZE |of| STREAM |with| ERRCODE) T) ((NULL NOERRORFLG) (\\CHAR-ERROR ERRNO STREAM)))) (WRITE (COND ((NULL (FETCH CPPTR OF STREAM)) (* |;;| "No buffer allocated yet; create one.") (REPLACE CPPTR OF STREAM WITH (NCREATE (QUOTE VMEMPAGEP))) (REPLACE CBUFSIZE OF STREAM WITH 512) (REPLACE CBUFMAXSIZE OF STREAM WITH 512) (REPLACE COFFSET OF STREAM WITH 0) T) ((ZEROP (FETCH COFFSET OF STREAM)) T) ((SETQ ERRCODE (\\CHAR-BOUTS STREAM (FETCH CPPTR OF STREAM) 0 (FETCH COFFSET OF STREAM) NOERRORFLG)) (* |;;| "WRITE HAPPENED.") (REPLACE CBUFSIZE OF STREAM WITH 512) (REPLACE CBUFMAXSIZE OF STREAM WITH 512) (REPLACE COFFSET OF STREAM WITH 0) T))) (SHOULDNT)))))
-)
-
-(\\TCP-EOFP
-(LAMBDA (STREAM) (* \; "Edited 20-Feb-90 12:42 by jds") (* |;;| "T if there will be no more data on the stream") (AND (OR (NOT (|fetch| (STREAM CPPTR) |of| STREAM)) (IEQP (FETCH (STREAM COFFSET) OF STREAM) (FETCH (STREAM CBUFSIZE) OF STREAM))) (NOT (\\TCP-GETNEXTBUFFER STREAM (QUOTE READ) T T))))
-)
-
-(\\TCP-CLOSEFILE
-  (LAMBDA (STREAM)                                       (* \; "Edited 18-Dec-89 11:17 by jds")
-
-    (* |;;| "Close a TCP connection or listening-socket cleanly.")
-
-    (TCP 3 (|fetch| (STREAM F1) |of| STREAM))
-    STREAM))
-
-(\\TCP-EVENTFN
-  (LAMBDA (FDEV EVENT)                                   (* \; "Edited 30-Jan-90 13:56 by jds")
-    (SELECTQ EVENT
-        ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS BEFORESAVEVM) 
-                                                                (* |;;| 
-                              "Clean up existing connections, and remember any LISTENS in progress")
-
-             )
-        ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) 
-
-                                                  (* |;;| 
-"Try to reopen streams that had been open, and re-establish any LISTENs in progress when we exited.")
-
-             )
-        NIL)))
-
-(\\TCP.BUFFERED.BOUTS
-(LAMBDA (STREAM SBASE OFFSET NBYTES) (\\BUFFERED.BOUTS (FETCH F2 OF STREAM) SBASE OFFSET NBYTES)))
-)
-
-(\\TCP-DEV-INIT)
-
-
-
-(* |;;| "User-level TCP operations")
-
-(DEFINEQ
-
-(TCP
-(LAMBDA (A B C D E F G H I J K L M) (* \; "Edited  4-Apr-90 17:29 by jds") (* |;;| "Generic TCP-operation hider function.  Hides the fact of TCP ops being SUBRCALLs.") (* |;;| "Returns whatever result the TCP operation returns.") (SUBRCALL TCP A B C D E F G H I J K L M))
-)
-
-(OPENTCPSTREAM
-(LAMBDA (HOST PORT) (* \; "Edited  3-May-90 11:38 by jds") (LET ((ERRNO (CREATECELL \\FIXP)) IODESCRIPTOR ACCESS-VALUE STREAM OTHER-STREAM) (SETQ STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ HOST USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC)) (|replace| (STREAM ACCESS) |of| STREAM |with| (QUOTE BOTH)) (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (|replace| F2 |of| STREAM |with| (SETQ OTHER-STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ HOST STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ NIL USERVISIBLE _ NIL EOLCONVENTION _ LF.EOLC))) (COND ((SETQ IODESCRIPTOR (TCP 4 HOST PORT)) (* |;;| "Open happened, so put things together.") (|replace| (STREAM F1) |of| STREAM |with| IODESCRIPTOR) (|replace| (STREAM F1) |of| OTHER-STREAM |with| IODESCRIPTOR)) (T (\\CHAR-ERROR ERRNO HOST))) STREAM))
-)
-
-(TCP-ACCEPT
-(LAMBDA (WAITING-SOCKET) (* \; "Edited 22-May-90 10:18 by jhb") (LET ((ERRNO (CREATECELL \\FIXP)) IODESCRIPTOR ACCESS-VALUE STREAM OTHER-STREAM SOCKET) (|while| (OR (NOT SOCKET) (< SOCKET 0)) |do| (BLOCK) (SETQ SOCKET (TCP 8 WAITING-SOCKET))) (PRINTOUT *TRACE-OUTPUT* "SOCKET ACCEPTED " SOCKET T) (SETQ STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ (GETHOSTFROMSOCKET SOCKET) USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC)) (|replace| (STREAM ACCESS) |of| STREAM |with| (QUOTE BOTH)) (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (|replace| F2 |of| STREAM |with| (SETQ OTHER-STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ HOST STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ NIL USERVISIBLE _ NIL EOLCONVENTION _ LF.EOLC))) (COND (SOCKET (* |;;| "Open happened, so put things together.") (|replace| (STREAM F1) |of| STREAM |with| SOCKET) (|replace| (STREAM F1) |of| OTHER-STREAM |with| SOCKET)) (T (\\CHAR-ERROR ERRNO HOST))) STREAM))
-)
-
-(TCP-LISTEN
-(LAMBDA (SOCKET-NUMBER ACCEPT-FUNCTION ACCEPT-DATA) (* \; "Edited 22-May-90 10:54 by jhb") (LET ((SOCKET (TCP 7 SOCKET-NUMBER))) (SETQ \\MAIKO.IO-INTERRUPT-VECTOR (CONS (LIST (LLSH 1 SOCKET) ACCEPT-FUNCTION SOCKET ACCEPT-DATA) \\MAIKO.IO-INTERRUPT-VECTOR)) SOCKET))
-)
-
-(TCP-CLOSE
-(LAMBDA (DESCRIPTOR-NUMBER) (* \; "Edited  4-Apr-90 14:51 by jds") (LET ((ACCEPTOR (ASSOC (LLSH 1 DESCRIPTOR-NUMBER) \\MAIKO.IO-INTERRUPT-VECTOR))) (TCP 3 DESCRIPTOR-NUMBER) (* \; "Close the TCP connection") (DREMOVE ACCEPTOR \\MAIKO.IO-INTERRUPT-VECTOR) (* \; "REmove any acceptor.") DESCRIPTOR-NUMBER))
-)
-)
-(DEFINEQ
-
-(UDP-LISTEN
-(LAMBDA (SOCKET-NUMBER ACCEPT-FUNCTION ACCEPT-INFO) (* \; "Edited  4-Apr-90 15:49 by jds") (* |;;| "Listen on a particular UDP socket for incoming packet traffic.  Also has the effect of opening the socket for outgoing traffic.") (LET ((SOCKET (TCP 128 SOCKET-NUMBER))) (SETQ \\MAIKO.IO-INTERRUPT-VECTOR (CONS (LIST (LLSH 1 SOCKET) ACCEPT-FUNCTION SOCKET ACCEPT-INFO) \\MAIKO.IO-INTERRUPT-VECTOR)) SOCKET))
-)
-
-(UDP-SEND
-(LAMBDA (SOCKET BUFFER LEN ADDR PORT) (TCP 130 SOCKET ADDR PORT BUFFER LEN)))
-
-(UDP-RECV
-(LAMBDA (SOCKET) (* \; "Edited  3-May-90 11:40 by jds") (* |;;| "Xall recvfrom() to get an incoming packet on a UDP socket.") (* |;;| "Returns 4 results:") (* |;;| "   The 1500-byte buffer containing the packet") (* |;;| "   The length of the incoming packet") (* |;;| "   The address of the guy who sent it") (* |;;| "   The port to answer him on (or where he sent it from)") (LET ((BUFFER (NCREATE (QUOTE VMEMPAGEP))) LEN (ADDR (\\CREATECELL \\FIXP)) (PORT (\\CREATECELL \\FIXP))) (SETQ LEN (TCP 131 SOCKET BUFFER 512 ADDR PORT)) (CL:VALUES BUFFER LEN ADDR PORT)))
-)
-)
-(DEFINEQ
-
-(GETHOSTFROMNAME
-  (LAMBDA (NAME)                                         (* \; "Edited  1-Feb-90 11:26 by jds")
-
-    (* |;;| 
-  "Given a host name, return the IP address for that host.  If the host isn't found, return NIL.")
-
-    (TCP 0 NAME)))
-
-(GETHOSTFROMADDR
-(LAMBDA (ADDR) (* \; "Edited  6-Apr-90 20:23 by jds") (* |;;| "Given a host's IP address, return the string name of the host, or NIL if it can't be found.") (LET* ((BUF (\\ALLOCBLOCK 100 NIL)) (LEN (TCP 66 ADDR BUF))) (COND ((ZEROP LEN) NIL) (T (\\GETBASESTRING BUF 0 LEN)))))
-)
-
-(GETHOSTFROMSOCKET
-  (LAMBDA (SOCKET)                                       (* \; "Edited  1-Feb-90 11:30 by jds")
-
-    (* |;;| "Given the socket FD of a TCP connection, return the NAME of the remote host, or NIL if it can't be found.")
-
-    (LET* ((BUF (\\ALLOCBLOCK 100 NIL))
-           (LEN (TCP 65 SOCKET BUF)))
-          (COND
-             ((ZEROP LEN)
-              NIL)
-             (T (CONCATLIST (FOR I FROM 0 TO (SUB1 LEN) COLLECT (\\GETBASEBYTE BUF I)
-                                   )))))))
-
-(GETHOSTNAME
-(LAMBDA NIL (* \; "Edited  6-Apr-90 20:25 by jds") (* |;;| "Given a host's IP address, return the string name of the host, or NIL if it can't be found.") (LET* ((BUF (\\ALLOCBLOCK 100 NIL)) (LEN (TCP 67 BUF))) (COND ((ZEROP LEN) NIL) (T (\\GETBASESTRING BUF 0 LEN)))))
-)
-)
-(DECLARE\: EVAL@LOAD DONTCOPY 
-
-
-
-(* |;;| "Debugging functions &c")
-
-
-(RPAQ BUFFER (\\ALLOCBLOCK 100))
-(DEFINEQ
-
-(TCPRECV
-  (LAMBDA (PORT)
-    (LET ((LEN (TCP 6 PORT BUFFER 100)))
-         (|for| I |from| 0 |to| (SUB1 LEN) |do| (PRIN1 (CHARACTER (\\GETBASEBYTE
-                                                                                   BUFFER I))))
-         (TERPRI))))
-
-(TCPSEND
-  (LAMBDA (PORT BASE LEN)                                (* \; "Edited 15-Dec-89 15:13 by jds")
-    (TCP 5 PORT BASE OFFSET LEN)))
-
-(SEEBUFFER
-(LAMBDA (BUF) (|for| I |from| 0 |to| 11 |do| (PRIN1 (CHARACTER (\\GETBASEBYTE BUF I))))))
-
-(FOON
-(LAMBDA (INFO) (* \; "Edited  4-Apr-90 17:35 by jds") (LET ((RES (CL:MULTIPLE-VALUE-LIST (UDP-RECV (CADDR INFO))))) (AND (CADR RES) (SETQ RESULT RES))))
-)
-)
-)
-(PUTPROPS TCPOPS COPYRIGHT ("Savoir, Inc." 1989 1990))
-(DECLARE\: DONTCOPY
-  (FILEMAP (NIL (1081 8055 (\\TCP-DEV-INIT 1091 . 1918) (\\TCP-OPENFILE 1920 . 3557) (\\TCP-FORCEOUTPUT 
-3559 . 5060) (\\TCP-GETNEXTBUFFER 5062 . 6672) (\\TCP-EOFP 6674 . 6989) (\\TCP-CLOSEFILE 6991 . 7259) 
-(\\TCP-EVENTFN 7261 . 7927) (\\TCP.BUFFERED.BOUTS 7929 . 8053)) (8119 11214 (TCP 8129 . 8411) (
-OPENTCPSTREAM 8413 . 9441) (TCP-ACCEPT 9443 . 10604) (TCP-LISTEN 10606 . 10889) (TCP-CLOSE 10891 . 
-11212)) (11215 12328 (UDP-LISTEN 11225 . 11649) (UDP-SEND 11651 . 11742) (UDP-RECV 11744 . 12326)) (
-12329 13743 (GETHOSTFROMNAME 12339 . 12608) (GETHOSTFROMADDR 12610 . 12909) (GETHOSTFROMSOCKET 12911
- . 13452) (GETHOSTNAME 13454 . 13741)) (13851 14580 (TCPRECV 13861 . 14149) (TCPSEND 14151 . 14306) (
-SEEBUFFER 14308 . 14412) (FOON 14414 . 14578)))))
-STOP
diff --git a/obsolete/tcp/TCPTFTP b/obsolete/tcp/TCPTFTP
deleted file mode 100644
index 9f1b3327..00000000
--- a/obsolete/tcp/TCPTFTP
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jun-90 17:44:14" {DSK}<usr>local>lde>lispcore>library>TCPTFTP.;2 53424  

      changes to%:  (VARS TCPTFTPCOMS)

      previous date%: " 1-Jul-87 10:52:03" {DSK}<usr>local>lde>lispcore>library>TCPTFTP.;1)


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

(PRETTYCOMPRINT TCPTFTPCOMS)

(RPAQQ TCPTFTPCOMS
       ((COMS 
              (* ;; "Trivial File Transfer Protocol")

              (INITVARS (\TFTP.DEVICE)
                     (TFTP.MAXRETRIES 20))
              (GLOBALVARS \TFTP.DEVICE TFTP.MAXRETRIES)
              (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS TFTPCON TFTP TFTPSTREAM)
                                                      (CONSTANTS (\TFTPOVLEN 4)
                                                             (\TFTP.SOCKET 69))
                                                      (CONSTANTS * TFTPOPCODES)))
              (INITVARS (TFTP.MAXRETRIES 20))
              (FNS \TFTP.ACKNOWLEDGE \TFTP.CLOSEFILE \TFTP.EOFP \TFTP.ERROR \TFTP.GETNEXTBUFFER 
                   \TFTP.INIT \TFTP.INPUT.BUFFER \TFTP.OPENFILE \TFTP.READP \TFTP.SEND.ERROR 
                   \TFTP.SETUP)
              (FILES (SYSLOAD)
                     TCPUDP))
        (COMS 
              (* ;; "TFTP Server functions")

              (INITVARS (\TFTP.SERVER.CONNECTIONS))
              (GLOBALVARS \TFTP.SERVER.CONNECTIONS)
              (FNS TFTP.SERVER.PROCESS \TFTP.GET.FILE \TFTP.SEND.FILE))
        (COMS 
              (* ;; "User functions")

              (FNS TFTP.SERVER TFTP.GET TFTP.PUT))
        (COMS 
              (* ;; "Tracing functions")

              (FNS PRINTTFTP \TFTP.PRINT.ACK \TFTP.PRINT.DATA \TFTP.PRINT.ERROR \TFTP.PRINT.REQUEST))
        (P (\TFTP.INIT))))



(* ;; "Trivial File Transfer Protocol")


(RPAQ? \TFTP.DEVICE )

(RPAQ? TFTP.MAXRETRIES 20)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TFTP.DEVICE TFTP.MAXRETRIES)
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(RECORD TFTPCON (UDPSOCKET DESTSOCKET STREAM HOST))

(ACCESSFNS TFTP ((TFTPBASE (fetch (UDP UDPCONTENTS) of DATUM)))
                    (BLOCKRECORD TFTPBASE ((OPCODE WORD)
                                           (BLOCK# WORD)))
                    [ACCESSFNS TFTP ((TFTPCONTENTS (\ADDBASE (fetch (UDP UDPCONTENTS)
                                                                of DATUM)
                                                          (FOLDHI \TFTPOVLEN BYTESPERWORD]
                    (BLOCKRECORD TFTPBASE ((NIL WORD)
                                           (ERRORCODE WORD))))

(ACCESSFNS TFTPSTREAM ((TFTPCON (fetch (STREAM F1) of DATUM)
                                  (replace (STREAM F1) of DATUM with NEWVALUE))
                           (LASTPACKETIN (fetch (STREAM F2) of DATUM)
                                  (replace (STREAM F2) of DATUM with NEWVALUE))))
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TFTPOVLEN 4)

(RPAQQ \TFTP.SOCKET 69)


(CONSTANTS (\TFTPOVLEN 4)
       (\TFTP.SOCKET 69))
)

(RPAQQ TFTPOPCODES ((\TFTP.RRQ 1)
                        (\TFTP.WRQ 2)
                        (\TFTP.DATA 3)
                        (\TFTP.ACK 4)
                        (\TFTP.ERROR 5)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \TFTP.RRQ 1)

(RPAQQ \TFTP.WRQ 2)

(RPAQQ \TFTP.DATA 3)

(RPAQQ \TFTP.ACK 4)

(RPAQQ \TFTP.ERROR 5)


(CONSTANTS (\TFTP.RRQ 1)
       (\TFTP.WRQ 2)
       (\TFTP.DATA 3)
       (\TFTP.ACK 4)
       (\TFTP.ERROR 5))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? TFTP.MAXRETRIES 20)
(DEFINEQ

(\TFTP.ACKNOWLEDGE
  [LAMBDA (STREAM ACK#)                                      (* MPL " 2-Jun-85 17:07")
    (LET ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM))
          (ACK (\ALLOCATE.ETHERPACKET)))
         (\TFTP.SETUP ACK TFTPCON \TFTP.ACK 'FREE)
         (UDP.APPEND.WORD ACK ACK#)
         (UDP.SEND (fetch (TFTPCON UDPSOCKET) of TFTPCON)
                ACK)
         (BLOCK)
         (COND
            ((AND (EQ (fetch (STREAM ACCESS) of STREAM)
                      'INPUT)
                  (fetch (TFTPSTREAM LASTPACKETIN) of STREAM))
             (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON])

(\TFTP.CLOSEFILE
  [LAMBDA (STREAM)                                           (* ejs%: " 9-Feb-85 23:47")
    (LET ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM)))
         (SELECTQ (fetch (STREAM ACCESS) of STREAM)
             (OUTPUT [COND
                        ((AND (fetch (STREAM CBUFPTR) of STREAM)
                              (NOT (fetch (TFTPSTREAM LASTPACKETIN) of STREAM)))
                         (\TFTP.GETNEXTBUFFER STREAM 'WRITE])
             NIL)
         (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)
                T)
         (replace (STREAM ACCESS) of STREAM with NIL)
         STREAM])

(\TFTP.EOFP
  [LAMBDA (STREAM)                                           (* ejs%: " 9-Feb-85 21:23")
    (OR (NULL (fetch (STREAM CBUFPTR) of STREAM))
        (AND (fetch (TFTPSTREAM LASTPACKETIN) of STREAM)
             (EQ (fetch (STREAM COFFSET) of STREAM)
                 (fetch (STREAM CBUFSIZE) of STREAM])

(\TFTP.ERROR
  [LAMBDA (TFTP TFTPCON)                                     (* ejs%: " 9-Feb-85 19:04")
          
          (* * Called upon receipt of error packet in TFTP stream)

    (LET [(ERRORSTRING (ALLOCSTRING (IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP)
                                           (CONSTANT (IPLUS \UDPOVLEN (ADD1 \TFTPOVLEN]
         (\MOVEBYTES (fetch (TFTP TFTPCONTENTS) of TFTP)
                0
                (fetch (STRINGP BASE) of ERRORSTRING)
                (fetch (STRINGP OFFST) of ERRORSTRING)
                (fetch (STRINGP LENGTH) of ERRORSTRING))
         (ERROR (CONCAT "TFTP error message: " ERRORSTRING " for code")
                (fetch (TFTP ERRORCODE) of TFTP])

(\TFTP.GETNEXTBUFFER
  [LAMBDA (STREAM WHATFOR NOERRORFLG)                        (* MPL " 2-Jun-85 19:48")
    (DECLARE (GLOBALVARS TFTP.MAXRETRIES))
    (LET*
     ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM))
      (IPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON))
      (RETRYCOUNT 0)
      (BUFFER (fetch (STREAM CBUFPTR) of STREAM))
      UDP)
     (SELECTQ WHATFOR
         (READ [COND
                  [(fetch (TFTPSTREAM LASTPACKETIN) of STREAM)
                   (replace (STREAM ACCESS) of STREAM with NIL)
                   (\RELEASE.ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM))
                   (replace (STREAM CBUFPTR) of STREAM with NIL)
                   (COND
                      (NOERRORFLG NIL)
                      (T (\EOF.ACTION STREAM]
                  (T (PROG [(NEXT# (COND
                                      (BUFFER (ADD1 (fetch (TFTP BLOCK#) of BUFFER)))
                                      (T 1]
                       LP  [for I from 1 to TFTP.MAXRETRIES until UDP
                              do (SETQ UDP (UDP.GET IPSOCKET \ETHERTIMEOUT))
                                 (COND
                                    ((NOT UDP)
                                     (\TFTP.ACKNOWLEDGE STREAM (SUB1 NEXT#]
                           (COND
                              [UDP (COND
                                      [(EQ (fetch (TFTP OPCODE) of UDP)
                                           \TFTP.DATA)
                                       (COND
                                          ((IEQP (fetch (TFTP BLOCK#) of UDP)
                                                 NEXT#)
                                           (\TFTP.INPUT.BUFFER STREAM UDP)
                                           (\TFTP.ACKNOWLEDGE STREAM NEXT#)
                                           (RETURN T))
                                          [(ILESSP (fetch (TFTP BLOCK#) of UDP)
                                                  NEXT#)
                                           [COND
                                              (IPTRACEFLG (COND
                                                             ((EQ IPTRACEFLG T)
                                                              (printout IPTRACEFILE 
                                                                     "Retransmitting ACK for block "
                                                                     (SUB1 NEXT#)
                                                                     T))
                                                             (T (PRIN1 "R" IPTRACEFILE]
                                           (\TFTP.ACKNOWLEDGE STREAM (SUB1 NEXT#))
                                           (\RELEASE.ETHERPACKET UDP)
                                           (SETQ UDP NIL)
                                           (COND
                                              ((EQ (add RETRYCOUNT 1)
                                                   TFTP.MAXRETRIES)
                                               (\TFTP.SEND.ERROR TFTPCON 0 
                                                      "Timeout awaiting next data packet; aborting")
                                               (replace (STREAM STRMBINFN) of STREAM
                                                  with (FUNCTION \STREAM.NOT.OPEN))
                                               (ERROR "Timeout awaiting next data packet; aborting" 
                                                      STREAM))
                                              (T (GO LP]
                                          (T (\TFTP.SEND.ERROR TFTPCON 0 
                                                    "Protocol error: Block # too high.  Aborting...")
                                             (replace (STREAM STRMBINFN) of STREAM
                                                with (FUNCTION \STREAM.NOT.OPEN))
                                             (ERROR "Protocol error: Block # too high.  Aborting..." 
                                                    STREAM]
                                      ((EQ (fetch (TFTP OPCODE) of UDP)
                                           \TFTP.ERROR)
                                       (replace (STREAM STRMBINFN) of STREAM
                                          with (FUNCTION STREAM.NOT.OPEN))
                                       (\TFTP.ERROR UDP TFTPCON))
                                      (T [\TFTP.SEND.ERROR TFTPCON 0
                                                (CONCAT 
                                        "Protocol error: Illegal TFTP opcode, expected DATA but got "
                                                       (SELECTC (fetch (TFTP OPCODE) of UDP)
                                                           (\TFTP.RRQ "read request.")
                                                           (\TFTP.WRQ "write request.")
                                                           (\TFTP.ACK "ack.")
                                                           (CONCAT "unknown type "
                                                                  (fetch (TFTP OPCODE) of UDP)
                                                                  "."]
                                         (replace (STREAM STRMBINFN) of STREAM
                                            with (FUNCTION \STREAM.NOT.OPEN))
                                         (ERROR "Illegal TFTP opcode rec'd" STREAM]
                              (T (\TFTP.SEND.ERROR TFTPCON 0 
                                        "Timeout awaiting next data packet; aborting")
                                 (replace (STREAM STRMBINFN) of STREAM with (FUNCTION 
                                                                             \STREAM.NOT.OPEN))
                                 (ERROR "Timeout awaiting next data packet; aborting" STREAM])
         (WRITE [COND
                   [(fetch (TFTPSTREAM LASTPACKETIN) of STREAM)
                    (replace (STREAM ACCESS) of STREAM with NIL)
                    (COND
                       (NOERRORFLG NIL)
                       (T (\EOF.ACTION STREAM]
                   (T (PROG (ACK# NBYTES)
                            (SETQ ACK# (fetch (TFTP BLOCK#) of BUFFER))
                            (SETQ NBYTES (IDIFFERENCE (fetch (STREAM COFFSET) of STREAM)
                                                (UNFOLD (IDIFFERENCE (\LOLOC (fetch (TFTP 
                                                                                         TFTPCONTENTS
                                                                                          )
                                                                                of BUFFER))
                                                               (\LOLOC BUFFER))
                                                       BYTESPERWORD)))
                            [replace (IP IPTOTALLENGTH) of BUFFER
                               with (IPLUS NBYTES (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN \IPOVLEN]
                            [replace (UDP UDPLENGTH) of BUFFER with (IPLUS NBYTES
                                                                           (CONSTANT (IPLUS \UDPOVLEN 
                                                                                           \TFTPOVLEN
                                                                                            ]
                            (COND
                               ((ILESSP NBYTES 512)
                                (replace (TFTPSTREAM LASTPACKETIN) of STREAM with T)))
                        LP  (for I from 1 to TFTP.MAXRETRIES until UDP
                               do (SETQ UDP (UDP.EXCHANGE IPSOCKET BUFFER)))
                            (COND
                               [(AND UDP (EQ (fetch (TFTP OPCODE) of UDP)
                                             \TFTP.ACK))
                                (COND
                                   ((EQ (fetch (TFTP BLOCK#) of UDP)
                                        ACK#)
                                    [COND
                                       ((EQ NBYTES 512)
                                        (\TFTP.SETUP UDP TFTPCON \TFTP.DATA NIL)
                                        (UDP.APPEND.WORD UDP (ADD1 ACK#))
                                        (replace (UDP UDPLENGTH) of UDP
                                           with (CONSTANT (IPLUS 512 \UDPOVLEN \TFTPOVLEN)))
                                        (\TFTP.INPUT.BUFFER STREAM UDP))
                                       (T (replace (STREAM CBUFPTR) of STREAM with NIL)
                                          (replace (STREAM ACCESS) of STREAM with NIL)
                                          (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON]
                                    (RETURN T))
                                   [(ILESSP (fetch (TFTP BLOCK#) of UDP)
                                           ACK#)
                                    [COND
                                       (IPTRACEFLG (COND
                                                      ((EQ IPTRACEFLG T)
                                                       (printout IPTRACEFILE 
                                                              "TFTP retransmission on block# " ACK# T
                                                              ))
                                                      (T (PRIN1 "R" IPTRACEFILE]
                                    (\RELEASE.ETHERPACKET UDP)
                                    (SETQ UDP NIL)
                                    (COND
                                       [(EQ (add RETRYCOUNT 1)
                                            TFTP.MAXRETRIES)
                                        (\TFTP.SEND.ERROR TFTPCON 0 
                                               "Timeout awaiting acknowledgement.  Aborting...")
                                        (replace (STREAM STRMBOUTFN) of STREAM
                                           with (FUNCTION \STREAM.NOT.OPEN))
                                        (COND
                                           (NOERRORFLG NIL)
                                           (T (\EOF.ACTION STREAM]
                                       (T (GO LP]
                                   (T (\TFTP.SEND.ERROR TFTPCON 0 
                                             "Protocol error: Block # too high.  Aborting...")
                                      (replace (STREAM STRMBOUTFN) of STREAM
                                         with (FUNCTION \STREAM.NOT.OPEN))
                                      (COND
                                         (NOERRORFLG NIL)
                                         (T (\EOF.ACTION STREAM]
                               ((AND UDP (EQ (fetch (TFTP OPCODE) of UDP)
                                             \TFTP.ERROR))
                                (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION 
                                                                             \STREAM.NOT.OPEN))
                                (\TFTP.ERROR UDP TFTPCON))
                               [UDP [\TFTP.SEND.ERROR TFTPCON 0
                                           (CONCAT 
                                         "Protocol error: Illegal TFTP opcode, expected ACK but got "
                                                  (SELECTC (fetch (TFTP OPCODE) of UDP)
                                                      (\TFTP.RRQ "read request.")
                                                      (\TFTP.WRQ "write request.")
                                                      (\TFTP.DATA "data.")
                                                      (CONCAT "unknown type " (fetch (TFTP OPCODE)
                                                                                 of UDP)
                                                             "."]
                                    (replace (STREAM STRMBOUTFN) of STREAM
                                       with (FUNCTION \STREAM.NOT.OPEN))
                                    (COND
                                       (NOERRORFLG NIL)
                                       (T (\EOF.ACTION STREAM]
                               (T (\TFTP.SEND.ERROR TFTPCON 0 "Protocol error, aborting...")
                                  (replace (STREAM STRMBOUTFN) of STREAM
                                     with (FUNCTION \STREAM.NOT.OPEN))
                                  (COND
                                     (NOERRORFLG NIL)
                                     (T (\EOF.ACTION STREAM])
         (ERROR "Illegal ACCESS" WHATFOR])

(\TFTP.INIT
  [LAMBDA NIL                                                (* ejs%: " 2-Feb-86 12:00")
    (DECLARE (GLOBALVARS \TFTP.DEVICE))
    (OR \TFTP.DEVICE
        (\DEFINEDEVICE NIL
               (SETQ \TFTP.DEVICE
                (create FDEV
                       FDBINABLE _ T
                       FDBOUTABLE _ T
                       NODIRECTORIES _ T
                       RESETABLE _ NIL
                       RANDOMACCESSP _ NIL
                       BUFFERED _ T
                       PAGEMAPPED _ NIL
                       DEVICENAME _ 'TFTP
                       HOSTNAMEP _ (FUNCTION NILL)
                       EVENTFN _ (FUNCTION NILL)
                       FORCEOUTPUT _ (FUNCTION NILL)
                       BIN _ (FUNCTION \BUFFERED.BIN)
                       BOUT _ (FUNCTION \BUFFERED.BOUT)
                       GETNEXTBUFFER _ (FUNCTION \TFTP.GETNEXTBUFFER)
                       READP _ (FUNCTION \TFTP.READP)
                       EOFP _ (FUNCTION \TFTP.EOFP)
                       CLOSEFILE _ (FUNCTION \TFTP.CLOSEFILE])

(\TFTP.INPUT.BUFFER
  [LAMBDA (STREAM UDP)                                       (* ejs%: " 9-Feb-85 20:51")
          
          (* * Sets up the fields of the stream necessary to support buffered operation, 
          with UDP as the next packet)

    (LET [(OFFSET (UNFOLD (IDIFFERENCE (\LOLOC (fetch (TFTP TFTPCONTENTS) of UDP))
                                 (\LOLOC UDP))
                         BYTESPERWORD))
          (LENGTH (IDIFFERENCE (fetch (UDP UDPLENGTH) of UDP)
                         (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN]
         [COND
            ((type? ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM))
             (\RELEASE.ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM]
         (replace (STREAM CBUFPTR) of STREAM with UDP)
         (replace (STREAM COFFSET) of STREAM with OFFSET)
         (replace (STREAM CBUFSIZE) of STREAM with (replace (STREAM CBUFMAXSIZE) of STREAM
                                                      with (IPLUS OFFSET LENGTH)))
         (COND
            ((ILESSP LENGTH 512)
             (replace (TFTPSTREAM LASTPACKETIN) of STREAM with T])

(\TFTP.OPENFILE
  [LAMBDA (FILENAME ACCESS RECOG PARAMETERS)                 (* ejs%: "15-Sep-85 17:48")
          
          (* * Open a file using TFTP)

    (LET* ((HOSTNAME (FILENAMEFIELD FILENAME 'HOST))
           [DEVICE (COND
                      ((DODIP.HOSTP HOSTNAME)
                       (create FDEV using \TFTP.DEVICE DEVICENAME _ HOSTNAME))
                      (T (ERROR "Unknown IP host: " HOSTNAME]
           (STREAM (create STREAM
                          DEVICE _ DEVICE))
           [TFTPCON (replace (FDEV DEVICEINFO) of DEVICE with (create TFTPCON
                                                                     UDPSOCKET _ (UDP.OPEN.SOCKET)
                                                                     STREAM _ STREAM
                                                                     HOST _ (DODIP.HOSTP HOSTNAME]
           (UDP (\ALLOCATE.ETHERPACKET))
           UDPIN)
          (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SOCKET)
                                                     (AND RESETSTATE (UDP.CLOSE.SOCKET SOCKET T]
                                         (fetch (TFTPCON UDPSOCKET) of TFTPCON)))
                 (replace (TFTPCON DESTSOCKET) of TFTPCON with \TFTP.SOCKET)
                 (\TFTP.SETUP UDP TFTPCON (SELECTQ ACCESS
                                              (INPUT \TFTP.RRQ)
                                              (OUTPUT \TFTP.WRQ)
                                              (ERROR "ACCESS must be INPUT or OUTPUT" ACCESS)))
                 (UDP.APPEND.STRING UDP (SUBATOM FILENAME (STRPOS '} FILENAME NIL NIL NIL T)))
                 (UDP.APPEND.BYTE UDP 0)
                 (UDP.APPEND.STRING UDP (COND
                                           ((EQ (CADR (FASSOC 'TYPE PARAMETERS))
                                                'BINARY)
                                            "OCTET")
                                           (T "NETASCII")))
                 (UDP.APPEND.BYTE UDP 0)
                 (for I from 1 to \MAXETHERTRIES do (SETQ UDPIN (UDP.EXCHANGE (fetch (TFTPCON 
                                                                                            UDPSOCKET
                                                                                            )
                                                                                 of TFTPCON)
                                                                       UDP)) until UDPIN
                    finally (\RELEASE.ETHERPACKET UDP))
                 (COND
                    [UDPIN (SELECTC (fetch (TFTP OPCODE) of UDPIN)
                               (\TFTP.ACK (COND
                                             ((AND (EQ ACCESS 'OUTPUT)
                                                   (EQ (fetch (TFTP BLOCK#) of UDPIN)
                                                       0))
                                              (replace (TFTPSTREAM TFTPCON) of STREAM with TFTPCON)
                                              (replace (STREAM ACCESS) of STREAM with ACCESS)
                                              (replace (STREAM FULLFILENAME) of STREAM with FILENAME)
                                              (replace (TFTPCON DESTSOCKET) of TFTPCON
                                                 with (fetch (UDP UDPSOURCEPORT) of UDPIN))
                                              (\TFTP.SETUP UDPIN TFTPCON \TFTP.DATA NIL)
                                              (UDP.APPEND.WORD UDPIN 1)
                                              (add (fetch (UDP UDPLENGTH) of UDPIN)
                                                   512)
                                              (\TFTP.INPUT.BUFFER STREAM UDPIN)
                                              STREAM)))
                               (\TFTP.DATA (COND
                                              ((AND (EQ ACCESS 'INPUT)
                                                    (EQ (fetch (TFTP BLOCK#) of UDPIN)
                                                        1))
                                               (replace (TFTPSTREAM TFTPCON) of STREAM with TFTPCON)
                                               (replace (STREAM ACCESS) of STREAM with ACCESS)
                                               (replace (STREAM FULLFILENAME) of STREAM with FILENAME
                                                      )
                                               (replace (TFTPCON DESTSOCKET) of TFTPCON
                                                  with (fetch (UDP UDPSOURCEPORT) of UDPIN))
                                               (\TFTP.INPUT.BUFFER STREAM UDPIN)
                                               (\TFTP.ACKNOWLEDGE STREAM 1)
                                               STREAM)))
                               (\TFTP.ERROR (\TFTP.ERROR UDPIN))
                               (ERROR "Unknown TFTP opcode" (fetch (TFTP OPCODE) of UDPIN]
                    (T (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)
                              T)
                       NIL])

(\TFTP.READP
  [LAMBDA (STREAM)                                           (* ejs%: " 9-Feb-85 20:48")
    (ILESSP (fetch (STREAM COFFSET) of STREAM)
           (fetch (STREAM CBUFSIZE) of STREAM])

(\TFTP.SEND.ERROR
  [LAMBDA (TFTPCON ERRORCODE ERRORSTRING)                    (* ejs%: " 1-Jun-85 15:34")
          
          (* * Send an error back to the requestor)

    (LET ((TFTP (\ALLOCATE.ETHERPACKET)))
         (\TFTP.SETUP TFTP TFTPCON \TFTP.ERROR NIL)
         (UDP.APPEND.WORD TFTP ERRORCODE)
         (UDP.APPEND.STRING TFTP ERRORSTRING)
         (UDP.APPEND.BYTE TFTP 0)
         (UDP.SEND (fetch (TFTPCON UDPSOCKET) of TFTPCON)
                TFTP])

(\TFTP.SETUP
  [LAMBDA (UDP TFTPCON OPCODE REQUEUE)                       (* ejs%: " 9-Feb-85 20:32")
    (UDP.SETUP UDP (fetch (TFTPCON HOST) of TFTPCON)
           (fetch (TFTPCON DESTSOCKET) of TFTPCON)
           0
           (fetch (TFTPCON UDPSOCKET) of TFTPCON))
    (replace EPREQUEUE of UDP with REQUEUE)
    (UDP.APPEND.WORD UDP OPCODE])
)

(FILESLOAD (SYSLOAD)
       TCPUDP)



(* ;; "TFTP Server functions")


(RPAQ? \TFTP.SERVER.CONNECTIONS )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \TFTP.SERVER.CONNECTIONS)
)
(DEFINEQ

(TFTP.SERVER.PROCESS
  [LAMBDA (LOGSTREAM)                                        (* ejs%: " 3-Jun-85 01:52")
          
          (* * A server for TFTP file transfer)

    (DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS))
    (LET*
     ((DEVICE (create FDEV using \TFTP.DEVICE DEVICENAME _ 'TFTPSERVER))
      (SERVERSOCKET (UDP.OPEN.SOCKET \TFTP.SOCKET T))
      CONNECTION)
     [COND
        ((NULL LOGSTREAM)
         (COND
            ((NOT (HASTTYWINDOWP))
             (\CREATE.TTYDISPLAYSTREAM)))
         (SETQ LOGSTREAM (TTYDISPLAYSTREAM]
     (SETQ \TFTP.SERVER.CONNECTIONS NIL)
     (COND
        (SERVERSOCKET
         (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SOCKET)
                                                    (UDP.CLOSE.SOCKET SOCKET T]
                                        SERVERSOCKET))
                (while T
                   do (LET ((UDP (UDP.GET SERVERSOCKET T)))
                           (SETQ CONNECTION (CONS (fetch (IP IPSOURCEADDRESS) of UDP)
                                                  (fetch (UDP UDPSOURCEPORT) of UDP)))
                           (COND
                              [(NOT (MEMBER CONNECTION \TFTP.SERVER.CONNECTIONS))
                               (push \TFTP.SERVER.CONNECTIONS CONNECTION)
                               (SELECTC (fetch (TFTP OPCODE) of UDP)
                                   (\TFTP.RRQ (ADD.PROCESS `(\TFTP.SEND.FILE %, UDP
                                                                   (QUOTE %, (create TFTPCON 
                                                                                    UDPSOCKET _
                                                                                    (UDP.OPEN.SOCKET)
                                                                                    ))
                                                                   %, DEVICE %, LOGSTREAM)))
                                   (\TFTP.WRQ (ADD.PROCESS `(\TFTP.GET.FILE %, UDP
                                                                   (QUOTE %, (create TFTPCON 
                                                                                    UDPSOCKET _
                                                                                    (UDP.OPEN.SOCKET)
                                                                                    ))
                                                                   %, DEVICE %, LOGSTREAM)))
                                   (PROGN (printout LOGSTREAM "TFTP Server: Unexpected opcode "
                                                 (fetch (TFTP OPCODE) of UDP)
                                                 T)
                                          (SETQ \TFTP.SERVER.CONNECTIONS (DREMOVE CONNECTION 
                                                                             \TFTP.SERVER.CONNECTIONS
                                                                                ))
                                          (\RELEASE.ETHERPACKET UDP]
                              (T                             (* Duplicate request)
                                 (\RELEASE.ETHERPACKET UDP])

(\TFTP.GET.FILE
  [LAMBDA (UDP TFTPCON DEVICE LOGSTREAM)                     (* ; "Edited 14-Apr-87 20:19 by FS")
          
          (* ;; "Try to start receiving a file from the requestor as directed by the contents of the received UDP packet")

    (DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS))
    (LET* ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE)
                                                                                 of UDP)
                                                                       I))
                              finally (RETURN (IDIFFERENCE I BYTESPERWORD]
           (FILENAME (ALLOCSTRING FILENAMELENGTH))
           [MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                          until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of UDP)
                                             I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD 
                                                                                       FILENAMELENGTH 
                                                                                       1]
           (MODE (ALLOCSTRING MODELENGTH))
           (HOST (fetch (IP IPSOURCEADDRESS) of UDP))
           FILE TYPE TFTPSTREAM RESULT)
          (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (TFTPCON)
                                                     (LET* [(UDPSOCKET (fetch (TFTPCON UDPSOCKET)
                                                                          of TFTPCON))
                                                            (CONNECTION (CONS (fetch (TFTPCON HOST)
                                                                                 of TFTPCON)
                                                                              (fetch (TFTPCON 
                                                                                           DESTSOCKET
                                                                                            )
                                                                                 of TFTPCON]
                                                           (SETQ \TFTP.SERVER.CONNECTIONS
                                                            (REMOVE CONNECTION 
                                                                   \TFTP.SERVER.CONNECTIONS))
                                                           (AND RESETSTATE (UDP.CLOSE.SOCKET 
                                                                                  UDPSOCKET T]
                                         TFTPCON))
                 (replace (TFTPCON DESTSOCKET) of TFTPCON with (fetch (UDP UDPSOURCEPORT)
                                                                  of UDP))
                 (replace (TFTPCON HOST) of TFTPCON with HOST)
          
          (* ;; "Read the filename out of the packet")

                 (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
                        BYTESPERWORD
                        (fetch (STRINGP BASE) of FILENAME)
                        (fetch (STRINGP OFFST) of FILENAME)
                        FILENAMELENGTH)
          
          (* ;; "Read the mode out of the packet")

                 (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
                        (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                        (fetch (STRINGP BASE) of MODE)
                        (fetch (STRINGP OFFST) of MODE)
                        MODELENGTH)
                 (SETQ MODE (U-CASE MODE))
                 (printout LOGSTREAM "TFTP Server: Will attempt to receive " FILENAME " in " MODE 
                        " mode from host " (\IP.ADDRESS.TO.STRING HOST)
                        T)
                 (SETQ RESULT
                  (COND
                     [[AND (SETQ TYPE (COND
                                         ((STREQUAL MODE "NETASCII")
                                          'TEXT)
                                         ((STREQUAL MODE "OCTET")
                                          'BINARY)
                                         (T (\TFTP.SEND.ERROR TFTPCON 0 (CONCAT 
                                                                            "Unknown transfer type--" 
                                                                               MODE))
                                            NIL)))
                           (SETQ FILE (LET [(OUTSTREAM
                                             (CAR (NLSETQ (OPENSTREAM FILENAME 'OUTPUT 'NEW
                                                                 (LIST (LIST 'TYPE TYPE]
                                           (COND
                                              ((NULL OUTSTREAM)
                                               (\TFTP.SEND.ERROR TFTPCON 1 (CONCAT 
                                                                                  "Can't open file--" 
                                                                                  FILENAME))
                                               NIL)
                                              (T OUTSTREAM]
          
          (* ;; "Mode is OK, and file is open for input.  Open the TFTP stream back to the requestor")

                      (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (FILE)
                                                       (COND
                                                          (RESETSTATE (CLOSEF? FILE)
                                                                 (DELFILE (FULLNAME FILE]
                                           FILE))
                      (SETQ TFTPSTREAM (create STREAM
                                              DEVICE _ DEVICE))
                      (replace (TFTPCON STREAM) of TFTPCON with TFTPSTREAM)
                      (replace (STREAM ACCESS) of TFTPSTREAM with 'INPUT)
                      (replace (TFTPSTREAM TFTPCON) of TFTPSTREAM with TFTPCON)
          
          (* ;; "Send the first acknowledgement")

                      (\TFTP.ACKNOWLEDGE TFTPSTREAM 0)
                      (\RELEASE.ETHERPACKET UDP)
                      (printout LOGSTREAM "TFTP Server: receiving " (FULLNAME FILE)
                             T)
                      (COND
                         ((NLSETQ (COPYBYTES TFTPSTREAM FILE))
                          (printout LOGSTREAM "TFTP Server: Done receiving " (FULLNAME FILE)
                                 T)
                          (CLOSEF? FILE))
                         (T (printout LOGSTREAM "TFTP Server: Failed to receive " (FULLNAME FILE)
                                   T)
                            (DELFILE (FULLNAME (CLOSEF? FILE]
                     (T (printout LOGSTREAM "TFTP Server: Failed to receive " (FULLNAME FILE)
                               T)
                        (\RELEASE.ETHERPACKET UDP)
                        NIL)))
          
          (* ;; "Remove connection from list.")

                 (LET (UDPSOCKET CONNECTION)
                      (SETQ UDPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON))
                      (SETQ CONNECTION (CONS (fetch (TFTPCON HOST) of TFTPCON)
                                             (fetch (UDP UDPDESTPORT) of UDPSOCKET)))
                      (SETQ \TFTP.SERVER.CONNECTIONS (REMOVE CONNECTION \TFTP.SERVER.CONNECTIONS)))
                 RESULT])

(\TFTP.SEND.FILE
  [LAMBDA (UDP TFTPCON DEVICE LOGSTREAM)                     (* ; "Edited 30-Jun-87 22:12 by scp")
          
          (* ;; "Try to start sending a file to the requestor as directed by the contents of the received UDP packet")

    (DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS))
    (LET*
     ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE)
                                                                            of UDP)
                                                                  I))
                         finally (RETURN (IDIFFERENCE I BYTESPERWORD]
      (FILENAME (ALLOCSTRING FILENAMELENGTH))
      [MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                     until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of UDP)
                                        I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD 
                                                                                  FILENAMELENGTH 1]
      (MODE (ALLOCSTRING MODELENGTH))
      (HOST (fetch (IP IPSOURCEADDRESS) of UDP))
      FILE TYPE TFTPSTREAM RESULT)
     (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (TFTPCON)
                                                (LET* [(UDPSOCKET (fetch (TFTPCON UDPSOCKET)
                                                                     of TFTPCON))
                                                       (CONNECTION (CONS (fetch (TFTPCON HOST)
                                                                            of TFTPCON)
                                                                         (fetch (TFTPCON DESTSOCKET)
                                                                            of TFTPCON]
                                                      (SETQ \TFTP.SERVER.CONNECTIONS (REMOVE 
                                                                                           CONNECTION 
                                                                             \TFTP.SERVER.CONNECTIONS
                                                                                            ))
                                                      (AND RESETSTATE (UDP.CLOSE.SOCKET UDPSOCKET T]
                                    TFTPCON))
            (replace (TFTPCON DESTSOCKET) of TFTPCON with (fetch (UDP UDPSOURCEPORT) of UDP))
            (replace (TFTPCON HOST) of TFTPCON with HOST)
          
          (* ;; "Read the filename out of the packet")

            (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
                   BYTESPERWORD
                   (fetch (STRINGP BASE) of FILENAME)
                   (fetch (STRINGP OFFST) of FILENAME)
                   FILENAMELENGTH)
          
          (* ;; "Read the mode out of the packet")

            (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP)
                   (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                   (fetch (STRINGP BASE) of MODE)
                   (fetch (STRINGP OFFST) of MODE)
                   MODELENGTH)
            (SETQ MODE (U-CASE MODE))
            (printout LOGSTREAM "TFTP Server: Will attempt to send " FILENAME " in " MODE 
                   " mode to host " (\IP.ADDRESS.TO.STRING HOST)
                   T)
            (SETQ RESULT
             (COND
                ([AND (SETQ TYPE (COND
                                    ((STREQUAL MODE "NETASCII")
                                     'TEXT)
                                    ((STREQUAL MODE "OCTET")
                                     'BINARY)
                                    (T (\TFTP.SEND.ERROR TFTPCON 0 (CONCAT "Unknown transfer type--" 
                                                                          MODE))
                                       NIL)))
                      (SETQ FILE
                       (LET* [(FULLFILENAME (INFILEP FILENAME))
                              (INSTREAM (AND FULLFILENAME
                                             (CAR (NLSETQ (OPENSTREAM FULLFILENAME 'INPUT
                                                                 'OLD
                                                                 (LIST (LIST 'TYPE TYPE]
                             (COND
                                ((NULL INSTREAM)
                                 (\TFTP.SEND.ERROR TFTPCON 1 (CONCAT "Can't open file--" FILENAME))
                                 NIL)
                                (T INSTREAM]
          
          (* ;; "Mode is OK, and file is open for input.  Open the TFTP stream back to the requestor")

                 (SETQ TFTPSTREAM (create STREAM
                                         DEVICE _ DEVICE))
                 (replace (TFTPCON STREAM) of TFTPCON with TFTPSTREAM)
                 (replace (STREAM ACCESS) of TFTPSTREAM with 'OUTPUT)
                 (replace (TFTPSTREAM TFTPCON) of TFTPSTREAM with TFTPCON)
          
          (* ;; "Use the incoming packet as the first data packet on the way out")

                 (\TFTP.SETUP UDP TFTPCON \TFTP.DATA NIL)
          
          (* ;; "This is block number 1")

                 (UDP.APPEND.WORD UDP 1)
                 (add (fetch (UDP UDPLENGTH) of UDP)
                      512)
                 (\TFTP.INPUT.BUFFER TFTPSTREAM UDP)
                 (printout LOGSTREAM "TFTP Server: Sending " FILENAME T)
                 (COND
                    ((NLSETQ (PROGN (COPYBYTES FILE TFTPSTREAM)
                                    (\TFTP.GETNEXTBUFFER TFTPSTREAM 'WRITE T)
                                    (\TFTP.CLOSEFILE TFTPSTREAM)))
                     (printout LOGSTREAM "TFTP Server: Done sending " FILENAME T))
                    (T (printout LOGSTREAM "TFTP Server: Failed to send " FILENAME T)))
                 (CLOSEF? FILE))
                (T (printout LOGSTREAM "TFTP Server: Failed to send " FILENAME T)
                   (\RELEASE.ETHERPACKET UDP)
                   NIL)))
          
          (* ;; "Remove connection from list.")

            (LET (UDPSOCKET CONNECTION)
                 (SETQ UDPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON))
                 (SETQ CONNECTION (CONS (fetch (TFTPCON HOST) of TFTPCON)
                                        (fetch (UDP UDPDESTPORT) of UDPSOCKET)))
                 (SETQ \TFTP.SERVER.CONNECTIONS (REMOVE CONNECTION \TFTP.SERVER.CONNECTIONS)))
            RESULT])
)



(* ;; "User functions")

(DEFINEQ

(TFTP.SERVER
  [LAMBDA (LOGSTREAM)                                        (* MPL " 2-Jun-85 19:39")
          
          (* * Create a new TFTP server. LOGSTREAM defaults to a popup window)

    (ADD.PROCESS `(TFTP.SERVER.PROCESS %, LOGSTREAM) 'RESTARTABLE 'HARDRESET])

(TFTP.GET
  [LAMBDA (FROM TO PARAMETERS)                               (* MPL " 2-Jun-85 17:15")
    (LET ((EOLCONVENTION (CADR (FASSOC 'EOLCONVENTION PARAMETERS)))
          (TYPE (FASSOC 'TYPE PARAMETERS))
          (FROMNAME FROM)
          (TONAME TO))
         (RESETLST [SETQ TO (OPENSTREAM TO 'OUTPUT 'NEW NIL (COND
                                                               (TYPE (LIST TYPE]
                (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
                                                 (COND
                                                    ((AND STREAM RESETSTATE)
                                                     (CLOSEF? STREAM)
                                                     (DELFILE (FULLNAME STREAM]
                                     TO))
                (SETQ FROM (\TFTP.OPENFILE FROM 'INPUT 'OLD PARAMETERS))
                (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
                                                 (AND STREAM RESETSTATE (CLOSEF STREAM]
                                     FROM))
                (COND
                   (EOLCONVENTION (replace (STREAM EOLCONVENTION) of FROM with EOLCONVENTION)))
                (COND
                   ((AND FROM TO)
                    (COPYCHARS FROM TO)
                    (AND (OPENP FROM)
                         (CLOSEF FROM))
                    (FULLNAME (CLOSEF TO)))
                   (TO (ERRORX (LIST 9 FROMNAME)))
                   (FROM (ERRORX (LIST 9 TONAME])

(TFTP.PUT
  [LAMBDA (FROM TO PARAMETERS)                               (* ; "Edited 15-Apr-87 20:55 by FS")
    (LET ((EOLCONVENTION (CADR (FASSOC 'EOLCONVENTION PARAMETERS)))
          (TYPE (FASSOC 'TYPE PARAMETERS)))
          
          (* ;; "Why is TYPE not used anywhere?")

         (RESETLST (SETQ FROM (OPENSTREAM FROM 'INPUT 'OLD))
                (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
                                                 (AND RESETSTATE (CLOSEF STREAM]
                                     FROM))
                (SETQ TO (\TFTP.OPENFILE TO 'OUTPUT 'NEW PARAMETERS))
                (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM)
                                                 (AND RESETSTATE (CLOSEF STREAM]
                                     TO))
                (COND
                   (EOLCONVENTION (replace (STREAM EOLCONVENTION) of TO with EOLCONVENTION)))
                (COPYCHARS FROM TO)
                (CLOSEF FROM)
          
          (* ;; "Removed (FULLNAME (CLOSEF TO))")

                (CLOSEF TO])
)



(* ;; "Tracing functions")

(DEFINEQ

(PRINTTFTP
  [LAMBDA (TFTP FILE)                                        (* ejs%: " 2-Jun-85 14:00")
    (DECLARE (GLOBALVARS TFTPOPCODES))
    (PRINTCONSTANT (fetch (TFTP OPCODE) of TFTP)
           TFTPOPCODES FILE "TFTP Opcode: ")
    (SELECTC (fetch (TFTP OPCODE) of TFTP)
        (\TFTP.RRQ (printout FILE " ")
                   (\TFTP.PRINT.REQUEST TFTP FILE))
        (\TFTP.WRQ (printout FILE " ")
                   (\TFTP.PRINT.REQUEST TFTP FILE))
        (\TFTP.ACK (printout FILE " ")
                   (\TFTP.PRINT.ACK TFTP FILE))
        (\TFTP.DATA (printout FILE " ")
                    (\TFTP.PRINT.DATA TFTP FILE))
        (\TFTP.ERROR (printout FILE " ")
                     (\TFTP.PRINT.ERROR TFTP FILE))
        NIL)
    (TERPRI FILE)
    (TERPRI FILE])

(\TFTP.PRINT.ACK
  [LAMBDA (TFTP FILE)                                        (* ejs%: " 2-Jun-85 12:48")
    (printout FILE "Block #: " (fetch (TFTP BLOCK#) of TFTP)
           T])

(\TFTP.PRINT.DATA
  [LAMBDA (TFTP FILE)                                        (* ejs%: " 2-Jun-85 14:00")
    (printout FILE "Block #: " (fetch (TFTP BLOCK#) of TFTP)
           T)
    (PRINTPACKETDATA (fetch (TFTP TFTPCONTENTS) of TFTP)
           \TFTPOVLEN
           '(CHARS 12 |...|)
           (IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP)
                  (CONSTANT (IPLUS \TFTPOVLEN \UDPOVLEN])

(\TFTP.PRINT.ERROR
  [LAMBDA (TFTP FILE)                                        (* ejs%: " 2-Jun-85 13:15")
    (printout FILE "Error code: " (fetch (TFTP ERRORCODE) of TFTP)
           T)
    (PRINTPACKETDATA (fetch (TFTP TFTPCONTENTS) of TFTP)
           0
           '(CHARS |...|)
           (IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP)
                  (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN)))
           FILE])

(\TFTP.PRINT.REQUEST
  [LAMBDA (TFTP FILE)                                        (* ejs%: " 2-Jun-85 13:16")
          
          (* * Try to start sending a file to the requestor as directed by the contents 
          of the received TFTP packet)

    (LET* ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE)
                                                                                 of TFTP)
                                                                       I))
                              finally (RETURN (IDIFFERENCE I BYTESPERWORD]
           (FILENAME (ALLOCSTRING FILENAMELENGTH))
           [MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                          until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of TFTP)
                                             I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD 
                                                                                       FILENAMELENGTH 
                                                                                       1]
           (MODE (ALLOCSTRING MODELENGTH)))
          
          (* * Read the filename out of the packet)

          (\MOVEBYTES (fetch (TFTP TFTPBASE) of TFTP)
                 BYTESPERWORD
                 (fetch (STRINGP BASE) of FILENAME)
                 (fetch (STRINGP OFFST) of FILENAME)
                 FILENAMELENGTH)
          
          (* * Read the mode out of the packet)

          (\MOVEBYTES (fetch (TFTP TFTPBASE) of TFTP)
                 (IPLUS BYTESPERWORD FILENAMELENGTH 1)
                 (fetch (STRINGP BASE) of MODE)
                 (fetch (STRINGP OFFST) of MODE)
                 MODELENGTH)
          (printout FILE (SELECTC (fetch (TFTP OPCODE) of TFTP)
                             (\TFTP.RRQ "Read request for ")
                             (\TFTP.WRQ "Write request for ")
                             (SHOULDNT))
                 FILENAME " in mode " MODE T])
)

(\TFTP.INIT)
(PUTPROPS TCPTFTP COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3785 28418 (\TFTP.ACKNOWLEDGE 3795 . 4474) (\TFTP.CLOSEFILE 4476 . 5171) (\TFTP.EOFP 
5173 . 5530) (\TFTP.ERROR 5532 . 6308) (\TFTP.GETNEXTBUFFER 6310 . 19593) (\TFTP.INIT 19595 . 20684) (
\TFTP.INPUT.BUFFER 20686 . 21902) (\TFTP.OPENFILE 21904 . 27296) (\TFTP.READP 27298 . 27522) (
\TFTP.SEND.ERROR 27524 . 28019) (\TFTP.SETUP 28021 . 28416)) (28610 46223 (TFTP.SERVER.PROCESS 28620
 . 31874) (\TFTP.GET.FILE 31876 . 39527) (\TFTP.SEND.FILE 39529 . 46221)) (46256 49207 (TFTP.SERVER 
46266 . 46555) (TFTP.GET 46557 . 48098) (TFTP.PUT 48100 . 49205)) (49243 53309 (PRINTTFTP 49253 . 
50082) (\TFTP.PRINT.ACK 50084 . 50285) (\TFTP.PRINT.DATA 50287 . 50726) (\TFTP.PRINT.ERROR 50728 . 
51181) (\TFTP.PRINT.REQUEST 51183 . 53307)))))
STOP
\ No newline at end of file
diff --git a/obsolete/tcp/TCPUDP b/obsolete/tcp/TCPUDP
deleted file mode 100644
index 9f0f5b90..00000000
--- a/obsolete/tcp/TCPUDP
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Jun-90 17:46:11" {DSK}<usr>local>lde>lispcore>library>TCPUDP.;2 11429  

      changes to%:  (VARS TCPUDPCOMS)

      previous date%: " 6-Jan-89 16:37:55" {DSK}<usr>local>lde>lispcore>library>TCPUDP.;1)


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

(PRETTYCOMPRINT TCPUDPCOMS)

(RPAQQ TCPUDPCOMS
       [(COMS 
              (* ;; "User Datagram Protocol --- Definitions")

              [DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS UDP)
                                                      (CONSTANTS (\UDPOVLEN 8]
              (FILES (SYSLOAD)
                     TCPLLIP))
        (COMS 
              (* ;; "Internal functions")

              (FNS UDP.GET.BYTE UDP.GET.CELL UDP.GET.STRING UDP.GET.WORD \UDP.FLUSH.SOCKET.QUEUE 
                   \UDP.PORTCOMPARE \UDP.CHECKSUM \UDP.SET.CHECKSUM)
              (FNS \UDP.HANDLE.ICMP))
        (COMS 
              (* ;; "External functions")

              (FNS PRINTUDP UDP.INIT UDP.STOP UDP.OPEN.SOCKET UDP.CLOSE.SOCKET UDP.SOCKET.EVENT 
                   UDP.SOCKET.NUMBER UDP.GET UDP.SEND UDP.EXCHANGE UDP.SETUP UDP.APPEND.BYTE 
                   UDP.APPEND.CELL UDP.APPEND.STRING UDP.APPEND.WORD UDP.INCREMENT.LENGTH)
              (ADDVARS (IPPRINTMACROS (17 . PRINTUDP)))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? 'NILL 'PRINTRPCDATA)
                                                 (UDP.INIT])



(* ;; "User Datagram Protocol --- Definitions")

(DECLARE%: EVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")

(DECLARE%: EVAL@COMPILE

(ACCESSFNS UDP ((UDPBASE (\IPDATABASE DATUM)))
                   (BLOCKRECORD UDPBASE ((UDPSOURCEPORT WORD)
                                         (UDPDESTPORT WORD)
                                         (UDPLENGTH WORD)
                                         (UDPCHECKSUM WORD)))
                   [ACCESSFNS UDP ((UDPCONTENTS (\ADDBASE (\IPDATABASE DATUM)
                                                       (FOLDHI \UDPOVLEN BYTESPERWORD])
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \UDPOVLEN 8)


(CONSTANTS (\UDPOVLEN 8))
)

(* "END EXPORTED DEFINITIONS")

)

(FILESLOAD (SYSLOAD)
       TCPLLIP)



(* ;; "Internal functions")

(DEFINEQ

(UDP.GET.BYTE
(LAMBDA (UDP BYTE#) (* ejs%: "25-Jun-85 21:04") (* * Return a byte from the UDP data area) (COND ((AND (IGEQ BYTE# 0) (ILESSP BYTE# (fetch (UDP UDPLENGTH) of UDP))) (\GETBASEBYTE (fetch (UDP UDPCONTENTS) of UDP) BYTE#))))
)

(UDP.GET.CELL
(LAMBDA (UDP CELL#) (* ejs%: "25-Jun-85 21:09") (* * Return a cell from the UDP data area) (COND ((AND (IGEQ CELL# 0) (ILESSP CELL# (FOLDLO (fetch (UDP UDPLENGTH) of UDP) BYTESPERCELL))) (\MAKENUMBER (\GETBASE (fetch (UDP UDPCONTENTS) of UDP) (UNFOLD CELL# WORDSPERCELL)) (\GETBASE (fetch (UDP UDPCONTENTS) of UDP) (ADD1 (UNFOLD CELL# WORDSPERCELL)))))))
)

(UDP.GET.STRING
(LAMBDA (UDP OFFSET) (* ejs%: "25-Jun-85 21:12") (* * Fetch a string out of the UDP packet) (OR (SMALLP OFFSET) (SETQ OFFSET 0)) (LET* ((LENGTH (IDIFFERENCE (fetch (UDP UDPLENGTH) of UDP) OFFSET)) (STRING (ALLOCSTRING LENGTH))) (\MOVEBYTES (fetch (UDP UDPCONTENTS) of UDP) OFFSET (fetch (STRINGP BASE) of STRING) (fetch (STRINGP OFFST) of STRING) LENGTH) STRING))
)

(UDP.GET.WORD
(LAMBDA (UDP WORD#) (* ejs%: "25-Jun-85 21:06") (* * Return a word from the UDP data area) (COND ((AND (IGEQ WORD# 0) (ILESSP WORD# (FOLDLO (fetch (UDP UDPLENGTH) of UDP) BYTESPERWORD))) (\GETBASE (fetch (UDP UDPCONTENTS) of UDP) WORD#))))
)

(\UDP.FLUSH.SOCKET.QUEUE
(LAMBDA (IPSOCKET) (* ; "Edited 25-Aug-88 12:57 by bvm") (* ;;; "Called to flush input packet queue on an IPSOCKET") (LET ((QUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)) PACKET) (UNINTERRUPTABLY (while (SETQ PACKET (\DEQUEUE QUEUE)) do (\RELEASE.ETHERPACKET PACKET) finally (replace (IPSOCKET IPSQUEUELENGTH) of IPSOCKET with 0)))))
)

(\UDP.PORTCOMPARE
(LAMBDA (UDP IPSOCKET) (* ejs%: " 9-Feb-85 14:37") (* * Compare IPSOCKET until we find the one this UDP was destined for) (EQ (fetch (UDP UDPDESTPORT) of UDP) (fetch (IPSOCKET IPSOCKET) of IPSOCKET)))
)

(\UDP.CHECKSUM
(LAMBDA (UDP ZeroCheckSumIsOK) (* HAS%: "19-Aug-86 16:47") (* * Compute the UDP checksum for the packet UDP. The packet is assumed to have been setup by UDP.SETUP so that source and destination addresses, protocol, and UDP length have already been set.) (COND ((AND ZeroCheckSumIsOK (EQ (fetch (UDP UDPCHECKSUM) of UDP) 0)) (* * BSD Unix strikes again!) 0) (T (LET ((SOURCE (fetch (IP IPSOURCEADDRESS) of UDP)) (DEST (fetch (IP IPDESTINATIONADDRESS) of UDP)) (LENGTH (fetch (UDP UDPLENGTH) of UDP)) CHECKSUM) (SETQ CHECKSUM (IPLUS (bind (BASE _ (LOCF (fetch (IP IPSOURCEADDRESS) of UDP))) for I from 0 to (CONSTANT (SUB1 (TIMES 2 WORDSPERCELL))) sum (\GETBASE BASE I)) (ffetch (IP IPPROTOCOL) of UDP) LENGTH (\IPCHECKSUM UDP (\IPDATABASE UDP) LENGTH))) (SETQ CHECKSUM (IPLUS (LDB (BYTE 16 16) CHECKSUM) (LDB (BYTE 16 0) CHECKSUM))) (COND ((NOT (EQ (LDB (BYTE 16 16) CHECKSUM) 0)) (SETQ CHECKSUM (IPLUS (LDB (BYTE 16 16) CHECKSUM) (LDB (BYTE 16 0) CHECKSUM))))) CHECKSUM))))
)

(\UDP.SET.CHECKSUM
(LAMBDA (UDP) (* ejs%: " 3-Jun-85 00:19") (* * Called to set the UDP checksum in a packet ready to be transmitted) (LET (CHECKSUM) (replace (UDP UDPCHECKSUM) of UDP with 0) (SETQ CHECKSUM (\UDP.CHECKSUM UDP)) (replace (UDP UDPCHECKSUM) of UDP with (COND ((NEQ CHECKSUM MAX.SMALLP) (LOGAND (LOGNOT CHECKSUM) (CONSTANT (MASK.1'S 0 16)))) (T MAX.SMALLP)))))
)
)
(DEFINEQ

(\UDP.HANDLE.ICMP
(LAMBDA (ICMP SENTIP PROTOCOL) (* ; "Edited 13-Sep-88 14:26 by bvm") (* ;; "Handle an ICMP packet sent to a UDP socket.  We allow each UDP client to decide how to handle these.") (LET ((SOCKET (\IP.FIND.SOCKET (ffetch (UDP UDPSOURCEPORT) of SENTIP) PROTOCOL)) FN) (if (OR (NULL SOCKET) (EQ (SETQ FN (ffetch (IPSOCKET IPSICMPFN) of SOCKET)) (QUOTE \UDP.HANDLE.ICMP))) then (* ; "Sender went away already, or else didn't specify a handler (so inherited the default)") (\RELEASE.ETHERPACKET ICMP) else (CL:FUNCALL FN ICMP SENTIP SOCKET))))
)
)



(* ;; "External functions")

(DEFINEQ

(PRINTUDP
(LAMBDA (UDP FILE) (* ; "Edited  6-Jan-89 16:18 by Briggs") (printout FILE "UDP Source port: " (fetch (UDP UDPSOURCEPORT) of UDP) " Dest port: " (fetch (UDP UDPDESTPORT) of UDP) T "Length: " (fetch (UDP UDPLENGTH) of UDP) " Checksum: " (fetch (UDP UDPCHECKSUM) of UDP) T) (COND ((OR (EQ (fetch (UDP UDPDESTPORT) of UDP) \TFTP.SOCKET) (EQ (fetch (UDP UDPSOURCEPORT) of UDP) \TFTP.SOCKET)) (PRINTTFTP UDP FILE)) (T (PRINTRPCDATA (fetch (UDP UDPCONTENTS) of UDP) (- (fetch (UDP UDPLENGTH) of UDP) \UDPOVLEN) FILE))))
)

(UDP.INIT
(LAMBDA NIL (* ; "Edited 25-Aug-88 12:54 by bvm") (COND ((OR \IPFLG (SELECTQ (ASKUSER 15 (QUOTE Y) "IP is not running.  Shall I attempt to initialize it? ") (Y (\IPINIT) \IPFLG) NIL)) (\IP.ADD.PROTOCOL \UDP.PROTOCOL (FUNCTION \UDP.PORTCOMPARE) NIL NIL (FUNCTION \UDP.HANDLE.ICMP)))))
)

(UDP.STOP
(LAMBDA NIL (* ejs%: " 9-Feb-85 14:43") (\IP.DELETE.PROTOCOL \UDP.PROTOCOL)))

(UDP.OPEN.SOCKET
(LAMBDA (SKT# IFCLASH ICMPFN) (* ; "Edited 25-Aug-88 13:03 by bvm") (LET ((UDPCHAIN (\IP.FIND.PROTOCOL \UDP.PROTOCOL))) (if (OR UDPCHAIN (SETQ UDPCHAIN (UDP.INIT))) then (if (NULL SKT#) then (* ; "Open any free socket") (\IP.OPEN.SOCKET \UDP.PROTOCOL NIL NIL NIL NIL NIL ICMPFN) else (* ; "Check for clash") (LET ((IPSOCKET (\IP.FIND.SOCKET SKT# UDPCHAIN))) (if (NULL IPSOCKET) then (\IP.OPEN.SOCKET \UDP.PROTOCOL SKT# NIL NIL NIL NIL ICMPFN) else (SELECTQ IFCLASH ((T ACCEPT) (\UDP.FLUSH.SOCKET.QUEUE IPSOCKET) IPSOCKET) ((DON'T FAIL) NIL) (ERROR "UDP Port is already in use" SKT#))))) else (* ; "IP not inited") (SELECTQ IFCLASH ((DON'T FAIL) NIL) (ERROR!)))))
)

(UDP.CLOSE.SOCKET
(LAMBDA (IPSOCKET NOERRORFLG) (* ejs%: " 9-Feb-85 15:00") (\UDP.FLUSH.SOCKET.QUEUE IPSOCKET) (\IP.CLOSE.SOCKET (fetch (IPSOCKET IPSOCKET) of IPSOCKET) \UDP.PROTOCOL NOERRORFLG))
)

(UDP.SOCKET.EVENT
(LAMBDA (IPSOCKET) (* ejs%: " 9-Feb-85 15:07") (fetch (IPSOCKET IPSEVENT) of IPSOCKET)))

(UDP.SOCKET.NUMBER
(LAMBDA (IPSOCKET) (* ejs%: " 9-Feb-85 15:08") (fetch (IPSOCKET IPSOCKET) of IPSOCKET)))

(UDP.GET
(LAMBDA (IPSOCKET WAIT) (* ; "Edited 13-Sep-88 11:59 by bvm") (* ;;; "Returns the next UDP packet on the queue, or NIL if none exist and WAIT is NIL.  If WAIT is T, this function waits forever.  If WAIT is an integer, it is interpreted as the number of milliseconds to wait before returning NIL or a packet which arrives during that time.  This function therefore is like GETXIP and GETPUP") (PROG ((QUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)) UDP TIMER) LP (UNINTERRUPTABLY (COND ((SETQ UDP (\DEQUEUE QUEUE)) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) -1)))) (COND ((NULL UDP) (COND (WAIT (COND ((EQ WAIT T) (* ; "Wait forever")) (TIMER (COND ((TIMEREXPIRED? TIMER) (RETURN)))) (T (OR (FIXP WAIT) (LISPERROR "NON-NUMERIC ARG" WAIT)) (SETQ TIMER (SETUPTIMER WAIT)) T)) (AWAIT.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET) TIMER T) (GO LP)) (T (BLOCK)))) ((AND (EQ (fetch (IP IPPROTOCOL) of UDP) \UDP.PROTOCOL) (NEQ (fetch (UDP UDPCHECKSUM) of UDP) 0) (NOT (\IP.CHECKSUM.OK (\UDP.CHECKSUM UDP)))) (* ; "Bad checksum on UDP packet.  Any other kind of packet must have been put there by someone else") (\RELEASE.ETHERPACKET UDP) (GO LP))) (RETURN UDP)))
)

(UDP.SEND
(LAMBDA (IPSOCKET UDP) (* ejs%: " 9-Feb-85 15:24") (* * Sends a UDP packet. IP and UDP header assumed set up by UDP.SETUP and \IP.SETUPIP) (\UDP.SET.CHECKSUM UDP) (\IP.TRANSMIT UDP))
)

(UDP.EXCHANGE
(LAMBDA (IPSOCKET OUTUDP TIMEOUT) (* ejs%: " 9-Feb-85 22:28") (* * Send a UDP packet and wait for TIMEOUT to receive a packet (TIMEOUT defaults to \ETHERTIMEOUT)) (\UDP.FLUSH.SOCKET.QUEUE IPSOCKET) (UDP.SEND IPSOCKET OUTUDP) (BLOCK) (UDP.GET IPSOCKET (OR (FIXP TIMEOUT) \ETHERTIMEOUT)))
)

(UDP.SETUP
(LAMBDA (UDP DESTHOST DESTSOCKET ID IPSOCKET REQUEUE) (* ejs%: " 9-Feb-85 16:04") (\IP.SETUPIP UDP DESTHOST ID IPSOCKET REQUEUE) (add (fetch (IP IPTOTALLENGTH) of UDP) \UDPOVLEN) (AND (SMALLP DESTSOCKET) (replace (UDP UDPDESTPORT) of UDP with DESTSOCKET)) (replace (UDP UDPSOURCEPORT) of UDP with (fetch (IPSOCKET IPSOCKET) of IPSOCKET)) (replace (UDP UDPLENGTH) of UDP with \UDPOVLEN) UDP)
)

(UDP.APPEND.BYTE
(LAMBDA (UDP BYTE) (* ejs%: " 9-Feb-85 16:07") (\IP.APPEND.BYTE UDP BYTE) (add (fetch (UDP UDPLENGTH) of UDP) 1))
)

(UDP.APPEND.CELL
(LAMBDA (UDP CELL) (* ejs%: " 9-Feb-85 16:06") (\IP.APPEND.CELL UDP CELL) (add (fetch (UDP UDPLENGTH) of UDP) BYTESPERCELL))
)

(UDP.APPEND.STRING
(LAMBDA (UDP STRING) (* ejs%: " 9-Feb-85 16:10") (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING))) (\IP.APPEND.STRING UDP STRING) (add (fetch (UDP UDPLENGTH) of UDP) (NCHARS STRING)))
)

(UDP.APPEND.WORD
(LAMBDA (UDP WORD) (* ejs%: " 9-Feb-85 16:07") (\IP.APPEND.WORD UDP WORD) (add (fetch (UDP UDPLENGTH) of UDP) WORDSPERCELL))
)

(UDP.INCREMENT.LENGTH
(LAMBDA (UDP INCREMENT) (* ejs%: "12-Apr-86 18:50") (add (fetch (IP IPTOTALLENGTH) of UDP) INCREMENT) (add (fetch (UDP UDPLENGTH) of UDP) INCREMENT) INCREMENT)
)
)

(ADDTOVAR IPPRINTMACROS (17 . PRINTUDP))
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(MOVD? 'NILL 'PRINTRPCDATA)

(UDP.INIT)
)
(PUTPROPS TCPUDP COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2357 5603 (UDP.GET.BYTE 2367 . 2608) (UDP.GET.CELL 2610 . 2984) (UDP.GET.STRING 2986 . 
3371) (UDP.GET.WORD 3373 . 3632) (\UDP.FLUSH.SOCKET.QUEUE 3634 . 3998) (\UDP.PORTCOMPARE 4000 . 4224) 
(\UDP.CHECKSUM 4226 . 5220) (\UDP.SET.CHECKSUM 5222 . 5601)) (5604 6176 (\UDP.HANDLE.ICMP 5614 . 6174)
) (6213 11197 (PRINTUDP 6223 . 6752) (UDP.INIT 6754 . 7053) (UDP.STOP 7055 . 7146) (UDP.OPEN.SOCKET 
7148 . 7833) (UDP.CLOSE.SOCKET 7835 . 8036) (UDP.SOCKET.EVENT 8038 . 8148) (UDP.SOCKET.NUMBER 8150 . 
8261) (UDP.GET 8263 . 9439) (UDP.SEND 9441 . 9639) (UDP.EXCHANGE 9641 . 9947) (UDP.SETUP 9949 . 10356)
 (UDP.APPEND.BYTE 10358 . 10494) (UDP.APPEND.CELL 10496 . 10643) (UDP.APPEND.STRING 10645 . 10857) (
UDP.APPEND.WORD 10859 . 11006) (UDP.INCREMENT.LENGTH 11008 . 11195)))))
STOP
\ No newline at end of file
